-2002-12-19 Christopher Faylor <cgf@redhat.com>
+2002-10-22 Jeff Hobbs <jeffh@ActiveState.com>
- * win/tclWinInit.c (TclpInitLibraryPath): Default to correct location
- for installLib on cygwin.
+ *** 8.4.1 TAGGED FOR RELEASE ***
-2002-12-19 Christopher Faylor <cgf@redhat.com>
+ * changes: updated for 8.4.1 release
- * cygwin/configure.in: Set TCL_BUILD_LIB_SPEC.
- * cygwin/configure: Regenerate.
+ * win/Makefile.in: removed @MEM_DEBUG_FLAGS@ subst.
+ * win/configure: regen
+ * win/configure.in: removed SC_ENABLE_MEMDEBUG call
+ * win/tcl.m4: replaced SC_ENABLE_MEMDEBUG with a more intelligent
+ SC_ENABLE_SYMBOLS that takes yes|no|mem|compile|all as options now.
-2002-10-05 Christopher Faylor <cgf@redhat.com>
+2002-10-22 Daniel Steffen <das@users.sourceforge.net>
- * win/tclWin32Dll.c (tclWinTCharEncoding): Remove 'static' since it is
- declared in header as exportable extern.
+ * library/auto.tcl (tcl_findLibrary):
+ * library/package.tcl (tclPkgUnknown): on macosx, search inside the
+ Resources/Scripts subdirectory of any potential package directory
+ * macosx/Tcl.pbproj/project.pbxproj: add standard Frameworks dirs
+ to TCL_PACKAGE_PATH make argument.
+ * unix/tclUnixInit.c (TclpSetVariables): on macosx, add embedded
+ framework dirs to tcl_pkgPath: @executable_path/../Frameworks and
+ @executable_path/../PrivateFrameworks (if they exist), as well as
+ the dirs in DYLD_FRAMEWORK_PATH (if set). [Patch #624509]
+ use standard MAXPATHLEN instead of literal 1024
-2002-09-13 Keith Seitz <keiths@redhat.com>
+2002-10-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- From Mo Dejong <supermo@bayarea.net>:
- * win/tclWin32Dll.c (DllMain): Remove unused os
- variable since VC++ treats warnings as errors
- when compiling with symbols.
+ * doc/StringObj.3, doc/Object.3: Documented that Tcl_Obj's
+ standard string form is a modified UTF-8; apparently, this was not
+ mentioned anywhere in the main docs, and lead to [Bug 624919].
- * win/tclWinPort.h: Remove undefine of PASCAL
- symbol added on 2001-09-12. It caused
- crashing problems with sockets.
+2002-10-21 Daniel Steffen <das@users.sourceforge.net>
-2002-07-31 Keith Seitz <keiths@redhat.com>
+ * macosx/Tcl.pbproj/project.pbxproj: bumped version to 8.4.1
+ * generic/tcl.h: Added reminder comment to edit
+ macosx/Tcl.pbproj/project.pbxproj when version number changes.
- * generic/tclIntDecls.h (TclIntStubs): Do not include definitions
- for tclpAlloc, tclpFree, or pRealloc on cygwin.
+2002-10-18 Jeff Hobbs <jeffh@ActiveState.com>
- * win/tcl.hpj.in: Copied here from tools/tcl.hpj.in.
-
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Add TCL_DLL_BASE, DDE_DLL_BASE,
- and REG_DLL_BASE variables to define DLL image bases on cygwin.
- Do not link with "-e _WinMain@16" on cygwin.
- * win/configure.in (TCL_DLL_BASE): Substitute into makefile.
- (DDE_DLL_BASE): Likewise.
- (REG_DLL_BASE): Likewise.
- * win/configure: Regenerated.
- * win/Makefile.in: Use TCL_DLL_BASE, DDE_DLL_BASE, and
- REG_DLL_BASE to build DLLs.
+ * library/reg/pkgIndex.tcl:
+ * win/configure:
+ * win/configure.in:
+ * win/Makefile.in:
+ * win/makefile.vc:
+ * win/makefile.bc: Updated to reg1.1
-2002-07-30 Keith Seitz <keiths@redhat.com>
+ * doc/registry.n: Added support for broadcasting changes to
+ * tests/registry.test: the registry Environment. Noted proper code
+ * win/tclWinReg.c: in the docs. [Patch #625453]
- From Mo DeJong <supermo@bayarea.net>
- * cygwin/configure: Regenerated.
- * cygwin/configure.in: Emit a tclConfig.sh file
- so that expect can load it at configure time.
- * win/configure: Regenerated.
- * win/configure.in: Don't emit a ../unix/tclConfig.sh
- file, this was a hack to get expect to build.
+ * unix/Makefile.in (dist): add any mac/tcl*.sea.hqx files
-2002-04-09 Keith Seitz <keiths@redhat.com>
+2002-10-17 Don Porter <dgp@users.sourceforge.net>
- * test/iOUtil.test: Removed. Conflicted with real ioUtil.test
- file.
+ * generic/tclVar.c: Fixed code that check for proper # of args to
+ * tests/var.test: [array names]. Added test. [Bug 624755]
-2001-10-28 Christopher Faylor <cgf@redhat.com>
+2002-10-16 Jeff Hobbs <jeffh@ActiveState.com>
- * cygwin/configure.in: Check for cygwin host rather than cygwin target.
- * cygwin/configure: Regenerate.
+ * win/configure: add workaround for cygwin windres
+ * win/tcl.m4 (SC_CONFIG_CFLAGS): problem. [Patch #624010] (howell)
-2001-10-28 Christopher Faylor <cgf@redhat.com>
+2002-10-15 Jeff Hobbs <jeffh@ActiveState.com>
- * win/configure.in: Modify 2001-10-05 change to check for cygwin host
- rather than cygwin target.
- * win/configure: Regenerate.
+ * README: added archives.tcl.tk note
-Fri Oct 5 16:03:53 2001 Christopher Faylor <cgf@cygnus.com>
+ * unix/configure:
+ * unix/tcl.m4: Correct AIX-5 ppc build flags.
+ Correct HP 11 64-bit gcc building. [Patch #601051] (martin)
- * win/configure.in: Add detection for -mwin32 option requirement under
- cygwin.
- * win/configure: Regenerate.
+2002-10-15 Vince Darley <vincentdarley@users.sourceforge.net>
-2001-09-13 Ian Roxborough <irox@redhat.com>
-
- * generic/tclStubInit.tcl: Export tclAlloc functions
- if __MINGW32__ is defined.
- * generic/tclAlloc.c: Revert changes from 2001-09-12.
- * generic/tcl.h: Use tclAlloc function if __WIN32__
- is defined.
- * win/tclWinPort.h: Fixed typer __MWIN32 should read
- __WIN32__.
-
-2001-09-12 Ian Roxborough <irox@redhat.com>
-
- * Makefile.in: Add 'cygwin' subdirectory to 'make all'
- target.
- * configure.in: Configure 'cygwin' and 'win' directory
- for a cygwin host.
- * configure: Regenerated.
- * cygwin/configure.in: Change version number to 8.3.
- * cygwin/configure: Regenerated.
- * cygwin/Makefile.am: Added/removed files to be build
- for Tcl8.3.
- * cygwin/Makefile.in: Regenerated.
- * generic/tcl.h: Don't define __WIN32__ for cygwin or
- mwing32 builds. Don't define USE_TCLALLOC when building
- for cygwin. Don't use __declspec unless building Tcl or
- tk or build with USE_TCL_STUBS.
- * generic/tclAlloc.c: For cygwin hosts, don't using
- anything in this file unless build with __TCL_UNIX_VARIANT.
- * generic/tclClock.c: Declare 'timezone' as an int, if it
- hasn't been #defined.
- * generic/tclStubInit.c: Don't export any tclAlloc function
- when build for a cygwin host.
- * win/configure.in: Set DL_LIBS and MATH_LIBS. Create
- unix/tclConfig.sh.
- * win/configure: Regenerated.
- * win/tclWinPort.h: Added missing #endif.
- * win/tclWinFile.c (TclpChdir): Don't invert change
- directory results on cygwin.
-
-2001-08-08 Mo DeJong <mdejong@redhat.com>
+ * generic/tclCmdMZ.c:
+ * tests/trace.test: applied patch from Hemang Levana to fix
+ [Bug #615043] in execution traces with idle tasks firing.
- * cygtcl.m4 (TCL_TOOL_PATH, TCL_TOOL_SHARED_LIB_LONGNAME):
- Raise an error if the CYGPATH variable is not defined when
- TCL_TOOL_PATH is invoked. Add cygwin to the list of hosts
- that do not use a "lib" prefix for shared library names.
- * unix/configure: Regen.
- * win/configure: Regen.
+2002-10-14 Jeff Hobbs <jeffh@ActiveState.com>
-2001-08-06 Mo DeJong <mdejong@redhat.com>
+ * generic/tclEnv.c (Tcl_PutEnv): correct possible mem leak.
+ [Patch #623269] (brouwers)
- * cygtcl.m4 (TCL_TOOL_STATIC_LIB_LONGNAME,
- TCL_TOOL_SHARED_LIB_LONGNAME,
- TCL_TOOL_LIB_SHORTNAME): Use TCL_VENDOR_PREFIX instead
- of VENDORPREFIX to support using these macros in
- extensions that load tclConfig.sh.
- * unix/configure: Regen.
- * unix/configure.in: Subst VENDORPREFIX into tclConfig.sh.
- * unix/tclConfig.sh.in: Add TCL_VENDOR_PREFIX.
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Set vendor prefix to "rh"
- instead of "sn" when compiling with VC++ or gcc. When
- compiling with Cygwin set the prefix to "cyg". Set the
- TCL_VENDOR_PREFIX to support the tcl tool macros in Tcl.
- * win/tclConfig.sh.in: Add TCL_VENDOR_PREFIX.
+2002-10-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-2001-08-06 Mo DeJong <mdejong@redhat.com>
+ * generic/tcl.h: Need a different strategy through the maze of
+ #defines to let people building with Cygwin build correctly. Also
+ made some comments less misleading...
- * win/Makefile.in: Subst DDE_DLL_FILE, DDE_LIB_FILE, REG_DLL_FILE,
- REG_LIB_FILE, and PIPE_DLL_FILE from the configure script instead
- of figuring them out in the Makefile.
- * win/configure: Regen.
- * win/configure.in: Use TCL_TOOL_STATIC_LIB_LONGNAME and
- TCL_TOOL_SHARED_LIB_LONGNAME macros to figure out values for
- DDE_DLL_FILE, DDE_LIB_FILE, REG_DLL_FILE, REG_LIB_FILE, and
- PIPE_DLL_FILE and subst them into the Makefile.
-
-2001-08-01 Mo DeJong <mdejong@redhat.com>
-
- * cygtcl.m4 (TCL_TOOL_STATIC_LIB_LONGNAME,
- TCL_TOOL_SHARED_LIB_LONGNAME): Rename
- TCL_TOOL_LIB_LONGNAME to TCL_TOOL_STATIC_LIB_LONGNAME.
- Add new TCL_TOOL_SHARED_LIB_LONGNAME to construct
- shared library names in a cross platform way.
- * unix/configure: Regen.
- * unix/configure.in: Use TCL_TOOL_SHARED_LIB_LONGNAME
- and TCL_TOOL_STATIC_LIB_LONGNAME to generate lib names.
- * win/configure: Regen.
- * win/configure.in: Use TCL_TOOL_SHARED_LIB_LONGNAME
- and TCL_TOOL_STATIC_LIB_LONGNAME to generate lib names.
+2002-10-10 Jeff Hobbs <jeffh@ActiveState.com>
-2001-07-24 Mo DeJong <mdejong@redhat.com>
+ * README: fixed minor nits [Bug #607776] (virden)
* win/configure:
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Don't pass explicit
- Cygwin libs on the command line since linking is now
- done using $CC and not $LD.
+ * win/tcl.m4: enable USE_THREAD_ALLOC (new threaded allocator) by
+ default in cygwin configure on Windows.
-2001-07-24 Mo DeJong <mdejong@redhat.com>
+2002-10-10 Don Porter <dgp@users.sourceforge.net>
- * win/tclWinThrd.c (Tcl_CreateThread, TclpThreadExit):
- When building under Cygwin, call CreateThread instead
- of _beginthreadex and call ExitThread instead of
- _endthreadex. Cygwin does not support these msvcrt
- methods and does not suffer from the memory leak
- problems that prompted their use.
+ * doc/Tcl.n: Clarified that namespace separators are legal in
+ the variable names during $-subtitution. [Bug 615139]
+
+ * doc/regexp.n: Typo correction. Thanks Ronnie Brunner. [Bug 606826]
-2001-07-24 Mo DeJong <mdejong@redhat.com>
+2002-10-10 Vince Darley <vincentdarley@users.sourceforge.net>
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Check for bug in
- Cygwin version of windres and work around that
- case by passing a POSIX path instead of a Windows
- native path. One can't always pass a POSIX path
- because the mingw native toolchain accepts only
- Windows native paths.
+ * unix/tclLoadAout.c
+ * unix/tclLoadDl.c
+ * unix/tclLoadDld.c
+ * unix/tclLoadDyld.c
+ * unix/tclLoadNext.c
+ * unix/tclLoadOSF.c
+ * unix/tclLoadShl.c
+ * win/tclWinLoad.c: allow either full paths or simply dll names
+ to be specified when loading files (the latter will be looked
+ up by the OS on your PATH/LD_LIBRARY_PATH as appropriate).
+ Fixes [Bug 611108]
-2001-07-24 Mo DeJong <mdejong@redhat.com>
+2002-10-09 Jeff Hobbs <jeffh@ActiveState.com>
- * win/tclWinThrd.c (Tcl_CreateThread): Close Windows
- HANDLE returned by _beginthreadex. The MS documentation
- states that this handle is not closed by a later call to
- _endthreadex.
+ * unix/README: doc'ed --enable-symbols options.
+ * unix/Makefile.in: removed @MEM_DEBUG_FLAGS@ subst.
+ * unix/configure: regen
+ * unix/configure.in: removed SC_ENABLE_MEMDEBUG call
+ * unix/tcl.m4: replaced SC_ENABLE_MEMDEBUG with a more intelligent
+ SC_ENABLE_SYMBOLS that takes yes|no|mem|compile|all as options now.
-2001-07-17 Frank Ch. Eigler <fche@redhat.com>
+2002-10-09 Kevin B. Kenny <kennykb@acm.org>
- * generic/tclInitScript.h (initScript): Check that nameofexecutable
- is valid (file exists) before traversing it as a possible link.
+ * win/tclWinTime.c: Added code to set an exit handler that
+ terminates the thread that calibrates the performance counter, so
+ that the thread won't outlive unloading the Tcl DLL. [Tcl bug
+ 620735].
-2001-07-16 Mo DeJong <mdejong@redhat.com>
+2002-10-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * generic/tcl.h: Define __WIN32__ when
- __CYGWIN__ or __MINGW32__ is defined.
- * generic/tclAlloc.c: Define caddr_t when
- compiling with VC++ or mingw. This type is
- already defined when compiling with Cygwin.
+ * doc/binary.n: More clarification of [binary scan]'s behaviour.
-2001-07-16 Mo DeJong <mdejong@redhat.com>
+2002-10-09 Daniel Steffen <das@users.sourceforge.net>
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinPort.h:
- * win/tclWinThrd.c:
- Remove unnecessary #includes of dos.h, direct.h,
- and tchar.h. This will help the Cygwin porting
- effort since these headers do not exist under Cygwin.
+ * generic/tclIntDecls.h: fixed botched regen.
-2001-07-12 Mo DeJong <mdejong@redhat.com>
+2002-10-09 Daniel Steffen <das@users.sourceforge.net>
- * unix/Makefile.in:
- * unix/configure: Regen.
- * unix/configure.in:
- * unix/tcl.m4:
- * win/Makefile.in:
- * win/configure: Regen.
- * win/configure.in:
- * win/tcl.m4:
- Revert ill-conceived EXTRA_CFLAGS changes made on 2001-07-09.
- The change ended up causing big problems with the
- tclConfig.sh file since it exported EXTRA_CFLAGS and did
- not deal with the debug/non-debug case.
+ * generic/tclInt.decls: made TclSetPreInitScript() declaration
+ generic as it is used on mac & aqua as well.
+ * generic/tclIntDecls.h:
+ * generic/tclStubInit.c: regen.
+ * generic/tclCompile.h: added prototype for TclCompileVariableCmd.
-2001-07-11 Mo DeJong <mdejong@redhat.com>
+ * mac/tclMacPort.h: removed incorrect <fcntl.h> definitions
+ and obsolete <stat.h> definitions.
+ * mac/tclMacChan.c: removed obsolete GetOpenMode() and replaced
+ associated constants with the <fcntl.h> analogues (they existing
+ defs were inconsistent with <fcntl.h> which was causing havoc when
+ Tcl_GetOpenMode was used instead of private GetOpenMode).
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Avoid using AC_CHECK_TOOL
- since Tcl's configure script is not setup properly.
+ * mac/tclMacFCmd.c: removed GenerateUniqueName(), use equivalent
+ (and identiaclly named) routine from MoreFiles instead.
-2001-07-11 Mo DeJong <mdejong@redhat.com>
+ * mac/tclMacLoad.c: CONSTification, fixes to Vince's last changes.
- * unix/Makefile.in: Add AR variable for use in STLIB_LD.
- * unix/configure: Regen.
- * unix/configure.in: Use STLIB_LD when defining MAKE_LIB
- and MAKE_STUB_LIB. Subst RANLIB and AR.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Add doc comment about
- STLIB_LD command. Check ${AR} env var when setting
- STLIB_LD and delay evaluation until make time.
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Pass AR arguments in
- STLIB_LD to better match the Unix implementation. Don't
- bother defining AR when using VC++ since it is not used.
+ * mac/tclMacFile.c:
+ * mac/tclMacTest.c:
+ * mac/tclMacUnix.c: CONSTification.
-2001-07-10 Mo DeJong <mdejong@redhat.com>
+ * mac/tclMacOSA.c: CONSTificcation, sprintf fixes, UH 3.4.x changes;
+ fix for missing autoname token from TclOSACompileCmd. (bdesgraupes)
+ * mac/AppleScript.html(AppleScript delete): doc fix. (bdesgraupes)
- * win/configure:
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Use STLIB_LD in MAKE_LIB instead
- of AR which can be overridden on the make command line.
+ * mac/tcltkMacBuildSupport.sea.hqx: updated MoreFiles to 1.5.3,
+ updated build instructions for 8.4.
+ * mac/tclMacProjects.sea.hqx: rebuilt archive.
-2001-07-09 Mo DeJong <mdejong@redhat.com>
+2002-10-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * win/configure:
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Fix quoting of CYGPATH
- argument to AC_CHECK_PROG.
+ * doc/Alloc.3: Added a note to mention that attempting to allocate
+ a zero-length block can return NULL. [Tk bug 619544]
-2001-07-09 Mo DeJong <mdejong@redhat.com>
+2002-10-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * unix/Makefile.in: Add EXTRA_CFLAGS_DEBUG and EXTRA_CFLAGS_OPTIMIZE
- variables. These two do not actually differ in the unix version
- but are there to keep in sync with the Windows version.
- * unix/configure: Regen.
- * unix/configure.in: Don't subst EXTRA_CFLAGS. Subst EXTRA_CFLAGS_DEFAULT,
- EXTRA_CFLAGS_DEBUG, and EXTRA_CFLAGS_OPTIMIZE.
- * unix/tcl.m4 (SC_ENABLE_SYMBOLS, SC_CONFIG_CFLAGS): Define
- EXTRA_CFLAGS_DEFAULT based on the --enable-smbols option.
- Set EXTRA_CFLAGS_DEBUG instead of EXTRA_CFLAGS and then set
- EXTRA_CFLAGS_OPTIMIZE to the value of EXTRA_CFLAGS_DEBUG since
- they are the same under Unix.
- * win/Makefile.in: Add EXTRA_CFLAGS_DEBUG and EXTRA_CFLAGS_OPTIMIZE
- variables. This is needed so that the proper runtime lib gets linked
- into VC++ produced .obj files when CFLAGS is reset on the command line.
- * win/configure: Regen.
- * win/configure.in: Don't subst EXTRA_CFLAGS. Subst EXTRA_CFLAGS_DEFAULT,
- EXTRA_CFLAGS_DEBUG, and EXTRA_CFLAGS_OPTIMIZE.
- * win/tcl.m4 :(SC_ENABLE_SYMBOLS, SC_CONFIG_CFLAGS): Define
- EXTRA_CFLAGS_DEFAULT based on the --enable-smbols option. Set
- EXTRA_CFLAGS_DEBUG and EXTRA_CFLAGS_OPTIMIZE based on the runtime
- option when compiled with VC++.
+ * doc/binary.n: Doc improvements [Patch 616480]
-2001-07-06 Mo DeJong <mdejong@redhat.com>
+ * tests/fCmd.test, tests/winFCmd.test:
+ * tools/eolFix.tcl, tools/genStubs.tcl: [file exist] -> [file exists]
+ Thanks to David Welton.
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Pass -e _WinMain@16 in
- addition to the -mwindows flag to work around a problem
- with ld when it incorrectly uses main() as the executable
- entry point when both WinMain() and main() are available.
+2002-10-03 Don Porter <dgp@users.sourceforge.net>
-2001-07-06 Mo DeJong <mdejong@redhat.com>
+ * doc/tcltest.n: fixed typo [Bug 618018]. Thanks to "JJM".
- * unix/configure: Regen.
- * unix/configure.in: Replace call to SC_ENABLE_GCC with
- AC_PROG_CC so that CC passed in from the caller is respected.
- * unix/tcl.m4: Remove the unused SC_ENABLE_GCC macro.
- * win/configure: Regen.
- * win/configure.in: Replace call to SC_ENABLE_GCC with
- AC_PROG_CC so that CC passed in from the caller is respected.
- * win/tcl.m4: Remove unused SC_ENABLE_GCC macro.
+2002-10-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-2001-07-06 Mo DeJong <mdejong@redhat.com>
+ * tools/man2help2.tcl:
+ * tests/http.test, tests/httpd, tests/httpold.test:
+ * tests/env.test, tests/binary.test, tests/autoMkindex.test:
+ * library/init.tcl, library/http/http.tcl: [info exist] should
+ really be [info exists]. [Bug 602566]
- * win/Makefile.in: Subst DEPARG directly instead
- of relying on a variable. This will make Cygwin
- builds faster since an extra exec will be avoided.
- * win/configure: Regen.
- * win/configure.in: Subst DEPARG.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Set DEPARG based
- on CYGPATH.
+ * doc/lsearch.n: Better specification of what happens when -sorted
+ is mixed with other options. [Bug 617816]
-2001-06-26 Mo DeJong <mdejong@redhat.com>
+2002-10-01 Jeff Hobbs <jeffh@ActiveState.com>
- * cygtcl.m4 (TCL_TOOL_PATH): Use CYGPATH variable instead of
- invoking cygpath directly. Handle cross compile by not
- using CYGPATH when set to echo.
- * unix/configure: Regen.
- * win/Makefile.in: Remove PATHTYPE variable.
- * win/configure: regen.
- * win/configure.in: Remove PATHTYPE subst + extra CYGPATH subst.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Remove PATHTYPE variable. Search
- for cygpath in the PATH and set CYGPATH="cygpath -w" if found.
- Remove old cross compiling hack.
+ * generic/tclProc.c (TclCreateProc): mask out VAR_UNDEFINED for
+ precompiled locals to support 8.3 precompiled code.
+ (Tcl_ProcObjCmd): correct 2002-09-26 fix to look for tclProcBodyType.
-2001-06-26 Mo DeJong <mdejong@redhat.com>
+2002-10-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * win/Makefile.in: Don't use VPSEP in the VPATH,
- just use : as the spearator.
- * win/configure: Regen.
- * win/configure.in: Don't subst VPSEP.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Remove VPSEP.
+ * doc/socket.n: Mentioned that ports may be specified as serivce
+ names as well as integers. [Bug 616843]
-2001-06-25 Mo DeJong <mdejong@redhat.com>
+2002-09-30 Jeff Hobbs <jeffh@ActiveState.com>
- * win/configure: Regen.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): When building with
- gcc, don't attempt to link with LD or support dllwrap.
- Simply require a recent version of Cygwin gcc or Mingw
- gcc that supports -shared. When linking, use gcc instead
- of ld since gcc automatically includes libs like -lmsvcrt.
-
-2001-06-22 Mo DeJong <mdejong@redhat.com>
-
- * unix/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
- Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@. Add LDFLAGS_DEBUG
- and LDFLAGS_OPTIMIZE to match the way CFLAGS_DEFAULT works.
- This will support user set CFLAGS or LDFLAGS at configure time.
- * unix/configure: Regen.
- * unix/configure.in: Don't set CFLAGS to CFLAGS_DEFAULT, instead
- subst CFLAGS_DEFAULT into the Makefile. Add AC_SUBST for CFLAGS_DEFAULT,
- LDFLAGS_DEFAULT, LDFLAGS_DEBUG, and LDFLAGS_OPTIMIZE.
- * unix/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
- it uses a Makefile variable just like CFLAGS_DEFAULT.
- * win/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
- Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@.
- This will support user set CFLAGS or LDFLAGS at configure time.
- * win/configure: Regen.
- * win/configure.in: Don't set CFLAGS or LDFLAGS, instead subst
- CFLAGS_DEFAULT and LDFLAGS_DEFAULT into the Makefile.
- * win/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
- it uses a Makefile variable just like CFLAGS_DEFAULT.
+ * generic/tclCompCmds.c (TclCompileRegexpCmd): correct the
+ checking for bad re's that didn't terminate the re string.
+ Resultant compiles were correct, but much slower than necessary.
-2001-06-22 Mo DeJong <mdejong@redhat.com>
+2002-09-29 David Gravereaux <davygrvy@pobox.com>
- * configure: Regen.
- * configure.in: When a windows32 host is detected
- configure in the win subdirectory.
- * cygtcl.m4 (TCL_TOOL_PATH, TCL_TOOL_LIB_LONGNAME,
- TCL_TOOL_LIB_SHORTNAME, TCL_TOOL_LIB_SPEC):
- Add support for mingw32 and windows32 hosts. Remove
- check for cygwin since we are really cross compiling
- when building win32 executables.
- * unix/configure: Regen.
- * win/configure: Regen.
+ * win/tclAppInit.c: Added proper exiting conditions using Win32
+ console signals. This handles the existing lack of a Ctrl+C exit
+ to call exit handlers when built for thread support. Also, properly
+ handles exits from other conditions such as CTRL_CLOSE_EVENT,
+ CTRL_LOGOFF_EVENT, and CTRL_SHUTDOWN_EVENT signals. In all cases,
+ exit handlers will be called. [Bug 219355]
-2001-06-22 Mo DeJong <mdejong@redhat.com>
+ * win/makefile.vc: Added missing tclThreadAlloc.c to the build
+ rules and defines USE_THREAD_ALLOC when TCL_THREADS is defined
+ to get the new behavior by default.
- * win/configure:
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Don't set LDFLAGS_DEBUG
- to -g or LDFLAGS_OPTIMIZE to -O when compiling with gcc.
- These flags are not needed and can cause problems with
- the Cygwin version of ld.
+2002-09-27 Don Porter <dgp@users.sourceforge.net>
-2001-06-20 Mo DeJong <mdejong@redhat.com>
+ * README: Bumped to version 8.4.1 to avoid confusion
+ * generic/tcl.h: of CVS snapshots with the actual 8.4.0
+ * tools/tcl.wse.in: release.
+ * unix/configure.in:
+ * unix/tcl.spec:
+ * win/configure.in:
- * generic/tcl.h: Define __WIN32__ when __MINGW32__
- is defined to support building under Cygwin gcc
- with the -mno-cygwin flag.
+ * unix/configure: autoconf
+ * win/configure:
-2001-06-14 Mo DeJong <mdejong@redhat.com>
+2002-09-26 Jeff Hobbs <jeffh@ActiveState.com>
- * unix/Makefile.in: Avoid burning install TCL_LIBRARY into
- tclUnixInit.o at compile time.
- * unix/tclUnixInit.c (TclpInitLibraryPath): Fix location
- independence by searching for Tcl library in share/tclX.X
- instead of lib/tclX.X. This logic is no longer effected by a
- burned in TCL_LIBRARY.
- * win/tclWinInit.c (TclpInitLibraryPath): Search for Tcl library
- in share/tclX.X instead of lib/tclX.X. Remove a couple of
- Cygnus local hacks since they were not doing anything useful.
+ * unix/configure: regen.
+ * unix/tcl.m4: improve AIX-4/5 64bit compilation support.
-2001-06-08 Mo DeJong <mdejong@redhat.com>
+ * generic/tclProc.c (Tcl_ProcObjCmd): correct overeager
+ optimization of noop proc to handle the precompiled case. (sofer)
- * win/Makefile.in: Set TCL_LIBRARY to
- $INSTALL/share/tcl8.3 instead of
- $INSTALL/lib/tcl8.3.
+ * unix/ldAix (nmopts): add -X32_64 to make it work for 32 or 64bit
+ mode compilation.
-2001-06-08 Mo DeJong <mdejong@redhat.com>
+ * library/encoding/koi8-u.enc: removed extraneous spaces that
+ confused encoding reader. [Bug #615115]
- * win/tclConfig.sh.in: Correct the definition
- of TCL_LIB_FULL_PATH. It was inclosed in `
- characters instead of ' characters.
+ * unix/Makefile.in: generate source dists with -src designator and
+ do not generate .Z anymore (just .gz and .zip).
-2001-06-05 Mo DeJong <mdejong@redhat.com>
+2002-09-18 Mumit Khan <khan@nanotech.wisc.edu>
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_CONFIG_CFLAGS): Add a TCL_LIB_SUFFIX variable
- to make the TCL_TOOL_LIB_SHORTNAME macro happy.
- * unix/tclConfig.sh.in: Add TCL_LIB_SUFFIX variable.
+ Added basic Cygwin support.
-2001-06-05 Mo DeJong <mdejong@redhat.com>
+ * win/tcl.m4 (SC_PATH_TCLCONFIG): Support one-tree build.
+ (SC_PATH_TKCONFIG): Likewise.
+ (SC_PROG_TCLSH): Likewise.
+ (SC_CONFIG_CFLAGS): Assume real Cygwin port and remove -mno-cygwin
+ flags. Add -mwin32 to extra_cflags and extra_ldflags.
+ Remove ``-e _WinMain@16'' from LDFLAGS_WINDOW.
+ * win/configure.in: Allow Cygwin build.
+ (SEH test): Define to be 1 instead of empty value.
+ (EXCEPTION_DISPOSITION): Add test.
+ * win/configure: Regenerate.
- * cygtcl.m4 (TCL_TOOL_LIB_PATH): Call TCL_TOOL_PATH so that a
- Windows native path is generated for PATH variables.
- * unix/configure: Regen.
- * win/configure: Regen.
+ * generic/tcl.h: Don't explicitly define __WIN32__ for Cygwin, let
+ the user decide whether to use Windows or POSIX personality.
+ (TCL_WIDE_INT_TYPE, TCL_LL_MODIFIER, struct Tcl_StatBuf): Define
+ for Cygwin.
+ * generic/tclEnv.c (Tcl_CygwinPutenv): putenv replacement for
+ Cygwin.
+ * generic/tclFileName.c (Tcl_TranslateFileName): Convert POSIX
+ to native format.
+ (TclDoGlob): Likewise.
+ * generic/tclPlatDecls.h (TCHAR): Define for Cygwin.
+ * win/tclWinPort.h (putenv, TclpSysAlloc, TclpSysFree,
+ TclpSysRealloc): Define for Cygwin.
-2001-06-01 Mo DeJong <mdejong@redhat.com>
+2002-09-26 Daniel Steffen <das@users.sourceforge.net>
- * cygtcl.m4 (TCL_TOOL_PATH, TCL_TOOL_LIB_SHORTNAME): Check that argument to
- TCL_TOOL_PATH is not "". Use new TCL_LIB_SUFFIX variable in the
- TCL_TOOL_LIB_SHORTNAME macro under Windows.
- * unix/configure: Regen.
- * win/configure: Regen.
- * win/configure.in: Don't subst SHLIB_SUFFIX.
- * win/tcl.m4 (SC_CONFIG_CFLAGS): Set TCL_LIB_SUFFIX so that Tcl
- sees the same variable name that an extension will.
- * win/tclConfig.sh.in: Set the TCL_SHLIB_SUFFIX and TCL_LIB_SUFFIX vars.
+ * macosx/Makefile: preserve environment value of INSTALL_ROOT.
+ When embedding only use deployment build. Force relink before
+ embedded build to ensure new linker flags are picked up.
-2001-05-30 Mo DeJong <mdejong@redhat.com>
+ * macosx/Tcl.pbproj/project.pbxproj: add symbolic links to
+ debug lib, stub libs and tclConfig.sh in framework toplevel.
+ Configure target dependency fix. Fix to 'clean' action. Added
+ private tcl headers to framework. Install tclsh symbolic link.
+ Html doc build works when no installed tclsh available. Made
+ html doc structure in framework more like in Apple frameworks.
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_PATH_TCLCONFIG, SC_PATH_TKCONFIG):
- Check in win subdirectory in addition to unix subdirectory for
- tclConfig.sh and tkConfig.sh files.
+2002-09-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-2001-05-30 Mo DeJong <mdejong@redhat.com>
+ * unix/tcl.m4 (SC_TCL_64BIT_FLAGS): Yet more robust 64-bit value
+ detection to close [Bug 613117] on more systems.
- * cygtcl.m4: Add FIXME note.
- * unix/configure: Regen.
- * unix/tcl.m4 (SC_PATH_TCLCONFIG, SC_PATH_TKCONFIG):
- Generate an error instead of a warning if the Tcl, or Tk
- configuration files cannot be found.
+ * generic/tclCompile.c (TclPrintSource): More CONSTifying.
+ * generic/tclExecute.c (EvalStatsCmd): Object-ify to reduce
+ warnings. Thanks to 'CoderX2' on the chat for bringing this to my
+ attention...
-2001-05-26 Mo DeJong <mdejong@redhat.com>
+ * unix/tcl.m4: Forgot to define TCL_WIDE_INT_IS_LONG at the
+ appropriate moment. I believe this is the cause of [Bug 613117]
- * cygtcl.m4 (TCL_TOOL_PATH, TCL_TOOL_LIB_LONGNAME,
- TCL_TOOL_LIB_SHORTNAME, TCL_TOOL_LIB_SPEC): Create cross
- platform versions of the TCL_TOOL* macros.
- * unix/aclocal.m4: Include ../cygtcl.m4.
- * unix/configure: Regen.
- * unix/tcl.m4 (TCL_TOOL_PATH, TCL_TOOL_LIB_LONGNAME,
- TCL_TOOL_LIB_SHORTNAME, TCL_TOOL_LIB_SPEC): Remove macros.
- * win/aclocal.m4: Include ../cygtcl.m4.
- * win/configure: Regen.
- * win/tcl.m4 (TCL_TOOL_PATH, TCL_TOOL_LIB_LONGNAME,
- TCL_TOOL_LIB_SHORTNAME, TCL_TOOL_LIB_SPEC): Remove macros.
-
-2001-05-24 Mo DeJong <mdejong@redhat.com>
+ * doc/lset.n: Changed 'list' to 'varName' for consistency with
+ lappend documentation. Thanks to Glenn Jackman [Bug 611719]
- * unix/configure: Regen.
- * unix/configure.in: Add missing TCL_LIB_FULL_PATH
- variable.
+2002-09-22 Don Porter <dgp@users.sourceforge.net>
-2001-05-11 Mo DeJong <mdejong@redhat.com>
+ * library/tcltest/tcltest.tcl: Corrected [puts -nonewline] within
+ test bodies. Thanks to Harald Kirsch. [Bug 612786, Patch 612788]
+ Also corrected reporting of body return code. Thanks to David
+ Taback [Bug 611922]
+ * library/tcltest/pkgIndex.tcl: Bump to version 2.2.1.
+ * tests/tcltest.test: added tests for these bugs.
- * unix/configure:
- * unix/tcl.m4 (SC_ENABLE_SYMBOLS):
- * win/configure:
- * win/tcl.m4 (SC_ENABLE_SYMBOLS): Back port of CFLAGS_DEFAULT fix
- from Tcl 8.4. A Makefile variable name is now used for the CFLAGS.
+2002-09-15 Mo DeJong <mdejong@users.sourceforge.net>
-2001-05-09 Mo DeJong <mdejong@redhat.com>
+ * unix/configure: Regen.
+ * unix/tcl.m4 (SC_CONFIG_CFLAGS): Add PEEK_XCLOSEIM
+ define under Linux. This is used by Tk to double
+ check that an X input context is cleaned up
+ before it is closed.
- * win/tcl.m4 (TCL_TOOL_PATH): Assign literal macro
- value to a tmp variable before running cygpath
- thus avoiding a problem with a quoted argument.
+2002-09-12 David Gravereaux <davygrvy@pobox.com>
-2001-05-09 Mo DeJong <mdejong@redhat.com>
+ * win/coffbase.txt: Added BLT to the virtual base address
+ listings table should BLT's build tools decide to use it.
- * unix/Makefile.in: Use TCL_STUB_LIB_FILE instead of
- STUB_LIB_FILE subst when defining STUB_LIB_FILE.
- * unix/configure: Regen.
- * unix/configure.in: Use new path macros.
- * unix/tcl.m4 (TCL_TOOL_LIB_LONGNAME, TCL_TOOL_LIB_SHORTNAME,
- TCL_TOOL_LIB_SPEC, TCL_TOOL_LIB_PATH): Add macros
- to deal with library path translations.
- * win/Makefile.in: Add FIXME note.
- * win/configure: Regen.
- * win/configure.in: Use new path macros.
- * win/tcl.m4 (TCL_TOOL_LIB_LONGNAME, TCL_TOOL_LIB_SHORTNAME,
- TCL_TOOL_LIB_SPEC, TCL_TOOL_LIB_PATH): Add macros
- to deal with library path translations.
+2002-09-12 Daniel Steffen <das@users.sourceforge.net>
-2001-04-09 Mo DeJong <mdejong@redhat.com>
+ * generic/tcl.h:
+ * mac/tclMacApplication.r:
+ * mac/tclMacLibrary.r:
+ * mac/tclMacResource.r: unified use of the two equivalent
+ resource compiler header inclusion defines RC_INVOKED and
+ RESOURCE_INCLUDED, now use RC_INVOKED throughout.
- * unix/configure: Regen.
- * unix/tcl.m4: Add placeholder TCL_TOOL_PATH macro.
- * win/configure: Regen.
- * win/configure.in: Set TCL_LIB_FLAG, TCL_BUILD_LIB_SPEC,
- TCL_LIB_SPEC, TCL_LIB_FULL_PATH and subst them.
- * win/tcl.m4: Add TCL_TOOL_PATH macro, it will call
- cygpath -w and replace \ with / to create a native
- Windows path that VC++ will understand.
- * win/tclConfig.sh.in: Add TCL_LIB_FULL_PATH variable.
-
-2001-04-06 Christopher Faylor <cgf@redhat.com>
-
- Throughout change __CYGWIN32__ to __CYGWIN__.
- * cygwin/configure.in: When targeting cygwin, detect if C compiler
- supports -mno-win32 flag and use it if so.
- * cygwin/Makefile.in (EXTRA_CFLAGS): New variable. Holds results of
- -mno-win32 test.
- (COMPILE): Add EXTRA_CFLAGS variable to options.
- * generic/tclEnv.c: Only compile special Cygwin code if building under
- Cygwin and want native windows understanding.
- * win/tclWin32Dll.c (DllMain): #ifdef out CYGWIN impure_ptr stuff.
- * win/Makefile.in: Add -D__USE_W32_SOCKETS to accomodate newer
- newlib/w32api conventions.
-
-2001-04-05 Mo DeJong <mdejong@redhat.com>
+2002-09-10 Mo DeJong <mdejong@users.sourceforge.net>
- * win/configure: Regen.
- * win/configure.in: Subst the TCL_LIB_VERSIONS_OK variable.
- * win/tcl.m4: Add Cygnus local search for tcl8.1/win directory. Add
- TCL_LIB_VERSIONS_OK variable, it will get substituted into the
- tclConfig.sh file. Remve the SC_PROG_TCLSH macro.
+ * unix/README: Add note about building extensions
+ with the same compiler Tcl was built with.
+ [Tk Bug 592096]
-2001-04-05 Mo DeJong <mdejong@redhat.com>
+2002-09-10 Daniel Steffen <das@users.sourceforge.net>
- * generic/tclAlloc.c:
- * win/tclWinPort.h:
- Check for #define of WIN32 instead of VC++ specific symbol.
+ * macosx/Tcl.pbproj/project.pbxproj: disabled building html
+ documentation during embedded build.
-2001-03-31 Mo DeJong <mdejong@redhat.com>
+2002-09-10 Daniel Steffen <das@users.sourceforge.net>
- * unix/Makefile.in: Remove second
- assignment to SCRIPT_INSTALL_DIR
- variable. This seems to have been
- a merge error. It was installing
- Tcl lib files in the lib directory
- instead of share/tcl8.3.
+ * unix/Makefile.in: added DYLIB_INSTALL_DIR variable for macosx
+ and set it to default value ${LIB_RUNTIME_DIR}
+ * unix/tcl.m4 (Darwin): use DYLIB_INSTALL_DIR instead of
+ LIB_RUNTIME_DIR in the -install_name argument to ld.
+ * unix/configure: regen.
-2001-03-28 Ian Roxborough <irox@redhat.com>
+ * macosx/Tcl.pbproj/project.pbxproj:
+ * macosx/Makefile: added support for building Tcl as an embedded
+ framework, i.e. using an dyld install_name containing
+ @executable_path/../Frameworks via the new DYLIB_INSTALL_DIR
+ unix/Makefile variable.
+
+2002-09-10 Jeff Hobbs <jeffh@ActiveState.com>
- * unix/tclConfig.sh.in: Set TCL_CFLAGS to CFLAGS,
- otherwise tclConfig.sh won't work correctly.
+ *** 8.4.0 TAGGED FOR RELEASE ***
-2000-09-15 Syd Polk <spolk@redhat.com>
+2002-09-06 Don Porter <dgp@users.sourceforge.net>
- * Updated for the 8.3.2 release.
+ * doc/file.n: Format correction, and clarified [file normalize]
+ returns an absolute path.
-2000-08-08 Jeff Hobbs <hobbs@ajubasolutions.com>
+ * doc/tcltest.n: Added examples section, as long promised.
- 8.3.2 RELEASE finalized
+2002-09-06 Reinhard Max <max@suse.de>
- * changes: updated for release notes version of ChangeLog
+ * tests/tcltest.test: Added nonRoot flag to tests 8.3, 8.4, and 8.12.
- * library/msgcat1.0/pkgIndex.tcl:
- * library/msgcat1.0/msgcat.tcl: bumped msgcat version to 1.1.
+2002-09-05 Don Porter <dgp@users.sourceforge.net>
-2000-08-07 Jeff Hobbs <hobbs@ajubasolutions.com>
+ * doc/tcltest.n: Clarified phrasing.
- * doc/ChnlStack.3:
- * doc/CrtChannel.3: updated the docs to be aware of the
- TCL_CHANNEL_VERSION_2 style of Tcl channels.
+ * generic/tclBasic.c (TclRenameCommand,CallCommandTraces):
+ * tests/trace.test (trace-27.1): Corrected memory leak when a rename
+ trace deleted the command being traced. Test added. Thanks to
+ Hemang Lavana for the fix. [Bug 604609]
- * generic/tclIO.c (Tcl_CreateChannel): added assertion to verify
- that the new channel versioning will be binary compatible with
- older channel drivers.
+ * generic/tclVar.c (TclDeleteVars): Corrected logic for setting the
+ TCL_INTERP_DESTROYED flag when calling variable traces. [Tk Bug 605121]
- * BACKPORTED FROM 8.4 (HEAD) BRANCH:
+2002-09-04 Miguel Sofer <msofer@users.sourceforge.net>
- * doc/memory.n: Man page for Tcl "memory" command, which is
- created when TCL_MEM_DEBUG is defined at compile time.
+ * generic/tclVar.c (DeleteArray): leak plug [Bug 604239]. Thanks
+ to dkf and dgp for the long and difficult discussion in the chat.
- * doc/TCL_MEM_DEBUG.3: Man page with overall information about
- TCL_MEM_DEBUG usage.
+2002-09-03 Jeff Hobbs <jeffh@ActiveState.com>
- * doc/DumpActiveMemory.3: Man page for Tcl_DumpActiveMemory,
- Tcl_InitMemory, and Tcl_ValidateAllMemory [Bug: 1816, 1835].
+ * generic/tclVar.c (Tcl_UpVar2): code cleanup to not use goto
- * doc/Init.3: Man page for Tcl_Init [Bug: 1820].
+ * unix/configure: remove -pthread from LIBS on FreeBSD in thread
+ * unix/tcl.m4: enabled build. [Bug #602849]
- * unix/Makefile.in: add tclsh.ico and tcl.spec to dist target
+2002-09-03 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/mkLinks: Regen'd with new mkLinks.tcl.
- * unix/mkLinks.tcl: Fixed indentation, made link setup more
- intelligent (only do one existance test per man page, instead of
- one per function).
+ * generic/tclInterp.c (AliasCreate): a Tcl_Obj was leaked on error
+ return from TclPreventAliasLoop.
+
+2002-09-03 Daniel Steffen <das@users.sourceforge.net>
- * doc/AddErrInfo.3:
- * doc/ChnlStack.3:
- * doc/Exit.3:
- * doc/GetIndex.3:
- * doc/Notifier.3:
- * doc/Object.3:
- * doc/RegExp.3:
- * doc/SetResult.3:
- * doc/SplitList.3:
- * doc/Thread.3: Added missing entries to NAME section.
+ * macosx/Tcl.pbproj/project.pbxproj: Bumped version number to
+ 8.4.0 and updated copyright info.
- * doc/AddErrInfo.3:
- * doc/CrtObjCmd.3:
- * doc/RecEvalObj.3: Changed Tcl_EvalObj to Tcl_EvalObjEx
+2002-09-03 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclVar.c (Tcl_UpVar2): a Tcl_Obj was being leaked on
+ error return from TclGetFrame.
- * doc/library.n: Added entries for auto_qualify and auto_import
- [Bug: 1271].
- * doc/library.n: Fixed .SH NAME macro to include each function
- documented on the page, so that mkLinks will know about the
- functions listed there, and so that the Windows help file index
- will get set up correctly [Bug: 1898, 5273].
+2002-09-03 Don Porter <dgp@users.sourceforge.net>
- * doc/expr.n: Added documentation for each of the math library
- functions that expr supports [Bug: 1054].
+ * changes: Updated changes for 8.4.0 release.
- * doc/regsub.n: correct regsub docs [Bug: 5346]
+2002-09-02 Jeff Hobbs <jeffh@ActiveState.com>
- * doc/scan.n: minor doc fixes [Bug: 5396]
+ * unix/tclUnixFile.c (TclpObjLink): removed unnecessary/unfreed
+ extra native char*.
- * doc/RegExp.3: Replaced instances of "Tcl_GetRegExpInfo" with
- "Tcl_RegExpGetInfo", the correct name of the function [Bug: 5901].
+ * unix/tclUnixChan.c (Tcl_MakeTcpClientChannel): make sure to init
+ flags field of TcpState ptr to 0.
- * doc/package.n: Corrected information about [package forget]
- arguments [Bug: 5418].
+ * unix/configure:
+ * unix/tcl.m4: added 64-bit gcc compilation support on HP-11.
+ [Patch #601051] (martin)
- * generic/tclCkalloc.c: Fixed some function headers.
+ * README: Bumped version number to 8.4.0
+ * generic/tcl.h:
+ * tools/tcl.wse.in:
+ * unix/configure:
+ * unix/configure.in:
+ * unix/tcl.spec:
+ * win/README.binary:
+ * win/configure:
+ * win/configure.in:
- * tests/clock.test: Added test for "2 days 2 hours ago" style
- specifications.
+ * generic/tclInterp.c (SlaveCreate): make sure that the memory and
+ checkmem commands are initialized in non-safe slave interpreters
+ when TCL_MEM_DEBUG is used. [Bug #583445]
- * generic/tclDate.c: Regenerated from tclGetDate.y.
+ * win/tclWinConsole.c (ConsoleCloseProc): only wait on writable
+ pipe if there was something to write. This may prevent infinite
+ wait on exit.
- * generic/tclGetDate.y: Tweaked grammar to properly handle the
- "ago" keyword when it follows multiple relative unit specifiers,
- as in "2 days 2 hours ago". [Bug: 5497].
+ * tests/exec.test: marked exec-18.1 unixOnly until the Windows
+ incompatability (in the test, not the core) can be resolved.
- * generic/tclClock.c (FormatClock): correct code to handle locale
- specific return values from strftime, if any. [Bug: 3345]
+ * tests/http.test (http-3.11): added close $fp that was causing an
+ error on Windows because the file was not closed before deleting.
- * unix/tclUnixInit.c (TclpSetInitialEncodings): attempt to
- correct setlocale calls for XIM support and locale issues.
- [BUG: 5422 3345 4236 2522 2521]
+ * unix/tclUnixInit.c (Tcl_MacOSXGetLibraryPath): made this static
+ function only appear when HAVE_CFBUNDLE is defined.
- * library/init.tcl (auto_import): added check to see if a valid
- pattern was coming in, to avoid simple error cases [Bug: 3326]
+2002-08-31 Daniel Steffen <das@users.sourceforge.net>
- * library/history.tcl: Corrected an off-by-one error in HistIndex,
- which was causing [history redo] to start its search at the wrong
- event index. [Bug: 1269].
+ * unix/tcl.m4: added TK_SHLIB_LD_EXTRAS analogue of existing
+ TCL_SHLIB_LD_EXTRAS for linker settings only used when linking Tk.
- * generic/tclPosixStr.c (Tcl_SignalMsg): clarified #defines for
- Linux on Sparc to compile correctly. [Bug: 5364]
+ * unix/configure: regen
- * generic/tclEnv.c: cast cleanup [Bug: 5624]
- * win/tclWinFCmd.c: cast cleanup [Bug: 5627]
+2002-08-31 Daniel Steffen <das@users.sourceforge.net>
- * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Corrected
- caching of the index ptr to account for offsets != sizeof(char *).
- [Bug: 5153]
+ *** macosx-8-4-branch merged into the mainline [tcl patch #602770] ***
- * tests/opt.test:
- * library/opt0.4/optparse.tcl: Applied patch from [Bug: 5922], which
- corrected an incorrect use of [string match].
+ * generic/tcl.decls: added new macosx specific entry to stubs table.
- * tests/stringObj.test: Tweaked tests to avoid hardcoded
- high-ASCII characters (which will fail in multibyte locales);
- instead used \uXXXX syntax. [Bug: 3842].
+ * tools/genStubs.tcl: added generation of platform guards for
+ macosx. This is a little more complex than it seems, because MacOS
+ X IS "unix" plus a little bit, for the purposes of Tcl. BUT
+ unfortunately, Tk uses "unix" to mean X11. So added platform keys
+ for macosx (the little added to "unix"), "aqua" and "x11" to
+ distinguish these for Tk.
+
+ * generic/tcl.h: added a #ifnded RESOURCE_INCLUDED so that tcl.h
+ can be passed to the resource compiler.
+
+ * generic/tcl.h:
+ * generic/tclNotify.c: added a few Notifier procs, to be able to
+ modify more bits of the Tcl notifier dynamically. Required to get
+ Mac OS X Tk to live on top of the Tcl Unix threaded notifier.
+ Changes the size of the Tcl_NotifierProcs structure, but doesn't
+ move any elements around.
-2000-08-05 Jeff Hobbs <hobbs@scriptics.com>
+ * unix/tclUnixNotfy.c: moved the call to Tcl_ConditionNotify till
+ AFTER we are done mucking with the pointer swap. Fixes cases where
+ the thread waiting on the condition wakes & accesses the
+ waitingListPtr before it gets reset, causing a hang.
- * generic/tclIOGT.c (TclChannelTransform): fixed segfault that
- would occur when transforming a channel with a proc that did not
- yet exist. (Kupries)
+ * library/auto.tcl (tcl_findLibrary): added checking the
+ directories in the tcl_pkgPath for library files on macosx to
+ enable support of the standard Mac OSX library locations
- * generic/tclTest.c (TestChannelCmd): added some lint init'ing of
- statePtr and chan vars.
+ * unix/Makefile.in:
+ * unix/configure.in:
+ * unix/tcl.m4: added MAC_OSX_DIR. Added PLAT_OBJS to the OBJS:
+ there are some MacOS X specific files now for Tcl, and when I get
+ he resource & applescript stuff ported over, and restore support
+ for FindFiles, etc, there will be a few more.
+ Added LD_LIBRARY_PATH_VAR configure variable to avoid having to set
+ all possible LD_LIBRARY_PATH analogues on all platforms.
+ LD_LIBRARY_PATH_VAR is "LD_LIBRARY_PATH" by default, "LIBPATH" on
+ AIX, "SHLIB_PATH" on HPUX and "DYLD_LIBRARY_PATH" on Mac OSX.
+ Added configure option to package Tcl as a framework on Mac OSX.
-2000-07-28 Mo DeJong <mdejong@redhat.com>
+ * macosx/tclMacOSXBundle.c (new): support for finding Tcl extension
+ packaged as 'bundles' in the standard Mac OSX library locations.
- * win/Makefile.in:
- * win/configure.in:
- * win/tcl.m4:
- * win/tclConfig.sh.in: Back port of gcc for windows
- build system from 8.4.
+ * unix/tclUnixInit.c: added support for findig the tcl script
+ library inside Tcl packaged as a framework on Mac OSX.
-2000-07-26 Jeff Hobbs <hobbs@scriptics.com>
+ * macosx/Tcl.pbproj/jingham.pbxuser (new):
+ * macosx/Tcl.pbproj/project.pbxproj (new): project for Apple's
+ ProjectBuilder IDE.
- * merged core-8-3-1-io-rewrite back into core-8-3-1-branch.
- The core-8-3-1-io-rewrite branch should now be considered defunct.
+ * macosx/Makefile (new): simple makefile for building the project
+ from the command line via the ProjectBuilder tool 'pbxbuild'.
+ * unix/configure:
* generic/tclStubInit.c:
- * generic/tclDecls.h:
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclIO.c: moved the Tcl_Channel* macros from tcl.h to
- tclIO.c and made them proper stubbed functions. These are:
- Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc,
- Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc,
- Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelSetOptionProc,
- Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc,
- Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc,
- and Tcl_ChannelHandlerProc. These should be used to access the
- Tcl_ChannelType structure instead of direct pointer dereferencing.
+ * generic/tclPlatDecls.h: regen
- * unix/Makefile.in: undid 07-25 Makefile.in changes because we
- don't really want to force all private makefiles on everyone.
- This needs to be addressed again in the future. Best possible
- solution is to create a tcl/ subdir in the installing include dir
- (as is done already with the lib dir).
+2002-08-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
- * tests/iogt.test: added RCS string, marked tests 2.* to be
- unixOnly due to underlying system differences.
+ * win/tclWinThrd.c (TclpFinalizeThreadData, TclWinFreeAllocCache):
+ Applied patch for bug #599428, provided by Miguel Sofer
+ <msofer@users.sourceforge.net>.
- * tests/all.tcl: corrected additional sets by Kupries for testing.
+2002-08-28 David Gravereaux <davygrvy@pobox.com>
-2000-07-26 Syd Polk <spolk@redhat.com>
+ * generic/tclEnv.c:
+ * unix/configure.in:
+ * win/tclWinPort.h: putenv() on some systems copies the buffer
+ rather than taking reference to it. This causes memory leaks
+ and is know to effect mswindows (msvcrt) and NetBSD 1.5.2 . This
+ patch tests for this behavior and turns on -DHAVE_PUTENV_THAT_COPIES=1
+ when approriate. Thanks to David Welton for assistance.
+ [Bug 414910]
- * win/tcl.m4: Building libraries is significantly different on Cygwin
- now; rewhacked.
- * win/configure.in: Ditto.
- * win/Makefile.in: Ditto.
- * win/configure: Regenerated.
- * win/tclWinPort.h: tchar.h and direct.h are not defined on Cygwin,
- nor or they needed.
+ * unix/configure: regen'd
+2002-08-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-2000-07-25 Brent Welch <welch@ajubasolutions.com>
+ * doc/eval.n: Added mention of list command and corrected "SEE ALSO".
- * unix/Makefile.in: Need to install all the Tcl headers because
- Itcl depends on internal headers.
+ * unix/configure.in: Cache handling of ac_cv_type_socklen_t was
+ wrong. [Bug 600931] reported by John Ellson. Fixed by putting the
+ brackets where they belong.
-2000-07-25 Andreas Kupries <a.kupries@westend.com>
+2002-08-26 Miguel Sofer <msofer@users.sourceforge.net>
- * tests/iogt.test: (line 866f) New tests iogt-6.[01], highlighting
- buffering trouble when stacking and unstacking transformations.
- iogt-6.0 is solved, see the changes below. iogt-6.1 remains, for
- now, due to the perceived complexity of solutions.
+ * generic/tclCompCmds.c: fix for [Bug 599788] (error in element
+ name causing segfault), reported by Tom Wilkason. Fixed by copying
+ the tokens instead of the source string.
- * generic/tclIO.h: (line 139f) struct Channel, added a buffer
- queue, to hold data pushed back when stacking a transformation.
+2002-08-26 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclIO.c:
- (line 91f, line 7434f) New internal function 'CopyBuffer'.
- Derived from 'CopyAndTranslateBuffer', with translation
- removed.
- (line 1025f, line 1212f): Initialization of new queue.
- (line 1164f, Tcl_StackChannel): Pushback of input queue.
- (line 1293f, Tcl_UnstackChannel): Discard input and pushback.
- (line 3748f, Tcl_ReadRaw): Modified to use data in the push back
- area before going to the driver. Uses 'CopyBuffer', s.a.
- (line 4702f, GetInput): Modified to use data in the push back
- area before going to the driver.
- (line 4867f, Tcl_Seek): Modified to take pushback of the topmost
- channel in a stack into account.
- (line 5620f, Tcl_InputBuffered): See above. Added
- 'Tcl_ChannelBuffered'. Analogue to 'Tcl_InputBuffered' but for
- the buffer area in the channel.
+ * generic/tclThreadAlloc.c: small optimisation, reducing the
+ new allocator's overhead.
+
+2002-08-23 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tcl.decls: New public API 'Tcl_ChannelBuffered'. S.a.
+ * generic/tclObj.c (USE_THREAD_ALLOC): fixed leak [Bug 597936].
+ Thanks to Zoran Vasiljevic.
-2000-07-19 Jeff Hobbs <hobbs@scriptics.com>
+2002-08-23 Miguel Sofer <msofer@users.sourceforge.net>
- * tests/socket.test: removed doTestsWithRemoteServer constraint
- from socket-12.*. It requires 'exec', not a remote server.
- Cleaned up some coding errors.
+ * generic/tclThreadAlloc.c (USE_THREAD_ALLOC): moving objects
+ between caches as a block, instead of one-by-one.
-2000-07-18 Brent Welch <welch@ajubasolutions.com>
+2002-08-22 Miguel Sofer <msofer@users.sourceforge.net>
- * win/Makefile.in: Added rules for static tcldde and tclreg libraries.
+ * generic/tclBasic.c:
+ * generic/tclCmdMZ.c: fix for freed memory r/w in delete traces
+ [Bug 589863], patch by Hemang Lavana.
-2000-07-17 Jeff Hobbs <hobbs@scriptics.com>
+2002-08-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
- * README:
- * win/README:
- * win/README.binary:
+ * win/Makefile.in (CFLAGS):
+ * unix/Makefile.in (MEM_DEBUG_FLAGS): Added usage of @MEM_DEBUG_FLAGS@.
* win/configure.in:
+ * unix/configure.in: Added usage of SC_ENABLE_MEMDEBUG.
+ * win/tcl.m4:
+ * unix/tcl.m4: Added macro SC_ENABLE_MEMDEBUG. Allows a user of
+ configure to (de)activate memory validation and debugging
+ (TCL_MEM_DEBUG). No need to modify the makefile anymore.
+
+2002-08-20 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclCkalloc.c: CONSTified MemoryCmd and CheckmemCmd.
+
+ * README: Bumped version number to 8.4b3 to distinguish
+ * generic/tcl.h: HEAD from the 8.4b2 release.
+ * tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
- * tools/tcl.wse.in:
- * generic/tcl.h (TCL_RELEASE_SERIAL): updated to patchlevel 8.3.2
+ * win/README.binary:
+ * win/configure.in:
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc: added tclIOGT.c to objects list to compile.
+ * unix/configure: autoconf
+ * win/configure:
- * generic/tclStubInit.c:
- * generic/tclIntDecls.h:
- * generic/tclInt.decls: commented out internal decls for
- TclTestChannelCmd and TclTestChannelEventCmd as they were moved to
- tclTest.c. Added new decls for TclChannelEventScriptInvoker and
- TclChannelTransform.
-
- * generic/tclIO.h: new file that contains the main internal
- structures of Tcl_Channel code to allow for multiple files to
- access them.
- * generic/tclTest.c:
- * generic/tclIO.c: broke into 3 files - tclIO.c core code, tclIO.h
- header code, and tclIOGT.c - the giot test code from Kupries. The
- channel test code also moved to tclTest.c.
- * generic/tclIO.c (CloseChannel): stopped masking out of the
- TCL_READABLE|TCL_WRITABLE bits from the state flags in
- CloseChannel, instead adding extra intelligence to
- CheckChannelErrors with a new CHANNEL_RAW_MODE bit for special
- behavior when called from Raw channel APIs.
+ * library/http/http.tcl: Corrected installation directory of
+ * library/msgcat/msgcat.tcl: the package tcltest 2.2. Added
+ * library/opt/optparse.tcl: comments in other packages to remind
+ * library/tcltest/tcltest.tcl: that installation directories need
+ * unix/Makefile.in: updates to match increasing version
+ * win/Makefile.in: numbers. [Bug 597450]
+ * win/makefile.bc:
+ * win/makefile.vc:
-2000-07-13 Jeff Hobbs <hobbs@scriptics.com>
+2002-08-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
- * generic/tclIO.c (StackSetBlockMode): moved set of chanPtr
- outside of blockModeProc check to avoid infinite loop when
- blockModeProc was NULL (Kupries). updated TransformSeekProc to
- not call Tcl_Seek directly (Kupries).
+ * unix/tclUnixTest.c (TestfilehandlerCmd): Changed
+ readable/writable to the more common readable|writable.
- * win/tclWinChan.c: updated fileChannelType to v2 channel struct
- * win/tclWinConsole.c: updated consoleChannelType to v2 channel struct
- * win/tclWinPipe.c: updated pipeChannelType to v2 channel struct
- * win/tclWinSerial.c: updated serialChannelType to v2 channel struct
- * win/tclWinSock.c: updated tcpChannelType to v2 channel struct
+ Fixes SF #596034 reported by Larry Virden
+ <lvirden@users.sourceforge.net>.
-2000-07-11 Brent Welch <welch@ajubasolutions.com>
+2002-08-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * win/tclConfig.sh.in: Cleaned up unix-specific autoconf variables.
+ * tests/fCmd.test: Added test to make sure that the cause of the
+ problem is detectable with an unpatched Tcl.
+ * doc/ObjectType.3: Added note on the root cause of this problem
+ to the documentation, since it is possible for user code to
+ trigger this sort of behaviour too.
+ * generic/tclIOUtil.c (SetFsPathFromAny): Objects should only have
+ their old representation deleted when we know that we are about to
+ install a new one. This stops a weird TclX bug under Linux with
+ certain kinds of memory debugging enabled which essentally came
+ down to a double-free of a string.
-2000-07-11 Jeff Hobbs <hobbs@scriptics.com>
+2002-08-14 Miguel Sofer <msofer@users.sourceforge.net>
- * tests/iogt.test: made tests [345].0 not run by default as they
- were failing in the new design, but I'm not convinced that the
- returned result isn't correct.
+ * generic/tclInt.h:
+ * generic/tclObj.c: (code cleanup) factored the parts in the macros
+ TclNewObj() / TclDecrRefCount() into a common part for all
+ memory allocators and two new macros TclAllocObjStorage() /
+ TclFreeObjStorage() that are specific to each allocator and fully
+ describe the differences. Removed allocator-specific code from
+ tclObj.c by using the macros.
+
+2002-08-12 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclDecls.h:
- * generic/tclStubInit.c:
- * generic/tcl.decls: added Tcl_GetTopChannel C API that returns
- the current top channel of a channel stack. Tcl_GetChannel was
- changed earlier to return the bottommost channel of a stack
- because that is the one that is guaranteed to stay around the
- longest, and this was needed to compensate for certain
- operations that want to look at the state of the main channel.
- Most channel APIs already compensate for grabbing the top, so it
- shouldn't be needed often.
-
- * generic/tclIO.c (Tcl_StackChannel, Tcl_UnstackChannel): Added
- flushing of buffers (Kupries), removed use of DownChannel macro,
- added Tcl_GetTopChannel public API to get to the top channel of
- the channel stack (necessary for TLS). Rewrote Tcl_NotifyChannel
- for new channel design (Kupries). Did some code cleanup in the
- transform code. tclIO.c must still be broken into bits (separate
- out test code and giot code, create tclIO.h).
-
-2000-07-10 Andreas Kupries <a.kupries@westend.com>
-
- * tests/iogt.test: Reverted some earlier changes as a fix by Jeff
- revived the original and correct behaviour. IOW, the tests showed
- a genuine error and I didn't see it :(.
-
- * generic/tclIO.c (Tcl_Read|Write_Raw): Changed to directly use
- the drivers and not DoRead|DoWrite. The latter use the buffering
- system, encoding and eol-translation and this wreaks havoc with
- the data going through the transformations. Both procedures use
- CheckForchannelErrors and let it believe that there is no
- background copy in progress or else stacked channels could not
- be used for that.
-
- * generic/tclIO.c (TclCopyChannel, CopyData): Moved access to the
- topmost channel from the first to the second procedure to make
- the decision about that at the last possible time (Callbacks can
- change the stacking).
-
- test suite: failures of iogt-[345].0
+ * generic/tclCmdMZ.c: fixing UMR in delete traces, [Bug 589863].
-2000-07-06 Jeff Hobbs <hobbs@scriptics.com>
+2002-08-08 David Gravereaux <davygrvy@pobox.com>
- * tests/iogt.test: new tests for stacked channel stuff based off
- new 'testchannel transform|unstack' code (Kupries IOGT extension).
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclDecls.h:
- * generic/tclStubsInit.c:
- * generic/tclIO.c: complete rewrite of Tcl Channel code for
- stacked channels. Channels are now designed to work in a more
- stacked fashion with a shared ChannelState data structure.
+ * tools/man2help.tcl: Fixed $argv handling bug where if -bitmap
+ wasn't specified $argc was off by one.
-2000-06-16 Syd Polk <spolk@redhat.com>
+2002-08-08 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclEnv.c win/tclWin32Dll.c: Fix impurePtr to work with
- modern Cygwin.
- * win/tcl.m4: Use --compat-implib.
- * win/configure: Regenerate.
+ * tests/uplevel.test: added 6.1 to test [uplevel] with shadowed
+ commands [Bug 524383]
-Sat Jun 10 22:43:00 2000 Christopher Faylor <cgf@cygnus.com>
+ * tests/subst.test: added 5.8-10 as further tests for [Bug 495207]
- * win/tclWinFile.c (TclMatchFiles): Revert Mon Jun 5 18:48:32 2000
- Christopher Faylor <cgf@cygnus.com>. Fails on Windows 95.
+2002-08-08 Don Porter <dgp@users.sourceforge.net>
-Tue Jun 6 22:09:02 2000 Christopher Faylor <cgf@cygnus.com>
+ * tests/README: Noted removal of defs.tcl.
- * win/Makefile.in: Set up and use autoconf variables throughout to
- allow overriding variables from the make command line.
+2002-08-08 Jeff Hobbs <jeffh@ActiveState.com>
-Tue Jun 6 12:17:46 2000 Christopher Faylor <cgf@cygnus.com>
+ * doc/lsearch.n: corrected lsearch docs to use -inline in examples.
- * generic/tclFilename.c (Tcl_TranslateFileName): Reinstate Mon Jun 5
- 18:18:32 2000 Christopher Faylor <cgf@cygnus.com> minus a typo.
+ *** 8.4b2 TAGGED FOR RELEASE ***
-Tue Jun 6 17:05:20 2000 Andrew Cagney <cagney@b1.cygnus.com>
+ * tests/fCmd.test:
+ * tests/unixFCmd.test: updated tests for new link copy behavior.
+ * generic/tclFCmd.c (CopyRenameOneFile): changed the behavior to
+ follow links to endpoints and copy that file/directory instead of
+ just copying the surface link. This means that trying to copy a
+ link that has no endpoint (danling link) is an error.
+ [Patch #591647] (darley)
+ (CopyRenameOneFile): this is currently disabled by default until
+ further issues with such behavior (like relative links) can be
+ handled correctly.
- * generic/tclFileName.c (Tcl_TranslateFileName): Revert Mon Jun 5
- 18:48:32 2000 Christopher Faylor <cgf@cygnus.com>, didn't compile.
+ * tests/README: slight wording improvements
-Mon Jun 5 18:48:32 2000 Christopher Faylor <cgf@cygnus.com>
+2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclFileName.c (Tcl_TranslateFileName): Cygwin paths (and
- Windows in general, actually) do not need to have '/'s translated into
- '\'s.
- (TclDoGlob): Ditto.
- * win/tclWinFile.c (TclMatchFiles): Ditto.
- * generic/tclInitScript.h: Look in "../bin/usr/share" as well as
- "../bin/share".
+ * docs/BoolObj.3: added description of valid string reps for a
+ boolean object [Bug 584794]
+ * generic/tclObj.c: optimised Tcl_GetBooleanFromObj and
+ SetBooleanFromAny to avoid parsing the string rep when it can be
+ avoided [Bugs 584650, 472576]
+
+2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
-2000-06-02 Jeff Hobbs <hobbs@scriptics.com>
+ * generic/tclCompile.h:
+ * generic/tclObj.c: making tclCmdNameType static ([Bug 584567],
+ Don Porter).
+
+2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclIO.c (CloseChannel): removed the &ing out of
- (TCL_READABLE|TCL_WRITABLE) from the flags, as CloseChannel does
- this on the next pass through for the top channel, and it appeared
- to be causing hangs by not allowing the final flush.
+ * generic/tclObj.c (Tcl_NewObj): added conditional code for
+ USE_THREAD_ALLOC; objects allocated through Tcl_NewObj() were
+ otherwise being leaked. [Bug 587488] reported by Sven Sass.
+
+2002-08-06 Daniel Steffen <das@users.sourceforge.net>
-2000-06-01 Jeff Hobbs <hobbs@scriptics.com>
+ * generic/tclInt.decls:
+ * unix/tclUnixThrd.c: Added stubs and implementations for
+ non-threaded build for the tclUnixThrd.c procs TclpReaddir,
+ TclpLocaltime, TclpGmtime and TclpInetNtoa.
+ Fixes link errors in stubbed & threaded extensions that include
+ tclUnixPort.h and use any of the procs readdir, localtime,
+ gmtime or inet_ntoa (e.g. TclX 8.4) [Bug 589526]
+ * generic/tclIntPlatDecls.h:
+ * generic/tclStubInit.c: Regen.
+
+2002-08-05 Don Porter <dgp@users.sourceforge.net>
+
+ * library/tcltest/tcltest.tcl: The setup and cleanup scripts are now
+ * library/tcltest/pkgIndex.tcl: skipped when a test is skipped, fixing
+ * tests/tcltest.test: [Bug 589859]. Test for bug added, and
+ corrected tcltest package bumped to version 2.2.
+
+ * generic/tcl.decls: Restored Tcl_Concat to return (char *). Like
+ * generic/tclDecls.h: Tcl_Merge, it transfers ownership of a dynamic
+ * generic/tclUtil.c: allocated string to the caller.
+
+2002-08-04 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/CmdCmplt.3: Applied Patch 585105 to fully CONST-ify
+ * doc/Concat.3: all remaining public interfaces of Tcl.
+ * doc/CrtCommand.3: Notably, the parser no longer writes on
+ * doc/CrtSlave.3: the string it is parsing, so it is no
+ * doc/CrtTrace.3: longer necessary for Tcl_Eval() to be
+ * doc/Eval.3: given a writable string. Also, the
+ * doc/ExprLong.3: refactoring of the Tcl_*Var* routines
+ * doc/LinkVar.3: by Miguel Sofer is included, so that the
+ * doc/ParseCmd.3: "part1" argument for them no longer needs
+ * doc/SetVar.3: to be writable either.
+ * doc/TraceVar.3:
+ * doc/UpVar.3: Compatibility support has been enhanced so
+ * generic/tcl.decls that a #define of USE_NON_CONST will remove
+ * generic/tcl.h all possible source incompatibilities with
+ * generic/tclBasic.c the 8.3 version of the header file(s).
+ * generic/tclCmdMZ.c The new #define of USE_COMPAT_CONST now does
+ * generic/tclCompCmds.c what USE_NON_CONST used to do -- disable
+ * generic/tclCompExpr.c only those new CONST's that introduce
+ * generic/tclCompile.c irreconcilable incompatibilities.
+ * generic/tclCompile.h
+ * generic/tclDecls.h Several bugs are also fixed by this patch.
+ * generic/tclEnv.c [Bugs 584051,580433] [Patches 585105,582429]
+ * generic/tclEvent.c
+ * generic/tclInt.decls
+ * generic/tclInt.h
+ * generic/tclIntDecls.h
+ * generic/tclInterp.c
+ * generic/tclLink.c
+ * generic/tclObj.c
+ * generic/tclParse.c
+ * generic/tclParseExpr.c
+ * generic/tclProc.c
+ * generic/tclTest.c
+ * generic/tclUtf.c
+ * generic/tclUtil.c
+ * generic/tclVar.c
+ * mac/tclMacTest.c
+ * tests/expr-old.test
+ * tests/parseExpr.test
+ * unix/tclUnixTest.c
+ * unix/tclXtTest.c
+ * win/tclWinTest.c
+
+2002-08-01 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclExecute.c: bugfix (reading freed memory). Testsuite
+ passed on linux/i386, compile-13.1 hung on linux/alpha.
+
+2002-08-01 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclExecute.c: added a reference count for the complete
+ execution stack, instead of Tcl_Preserve/Tcl_Release.
+
+2002-08-01 Mo DeJong <mdejong@users.sourceforge.net>
+
+ * generic/tclCkalloc.c (TclFinalizeMemorySubsystem):
+ Don't lock the ckalloc mutex before invoking the
+ Tcl_DumpActiveMemory function since it also
+ locks the same mutex. This code is only executed
+ when "memory onexit filename" has been executed
+ and Tcl is compiled with -DTCL_MEM_DEBUG.
+
+2002-08-01 Reinhard Max <max@suse.de>
+
+ * win/tclWinPort.h: The windows headers don't provide socklen_t,
+ so we have to do it.
+
+2002-07-31 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclInt.h (USE_THREAD_ALLOC): for unshared objects,
+ TclDecrRefCount now frees the internal rep before the string rep -
+ just like the non-macro Tcl_DecrRefCount/TclFreeObj [Bug 524802].
+ For the other allocators the fix was done on 2002-03-06.
+
+2002-07-31 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclInterp.c: signed/unsigned comparison warning fixed
+ (Vince Darley).
+
+2002-07-31 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ * unix/tcl.m4 (SC_BUGGY_STRTOD): Enabled caching of test results.
+
+ * unix/tcl.m4 (SC_BUGGY_STRTOD): Solaris 2.8 still has a buggy
+ strtod() implementation; make sure we detect it.
+
+ * tests/expr.test (expr-22.*): Marked as non-portable because it
+ seems that these tests have an annoying tendency to fail in
+ unexpected ways. [Bugs 584825, 584950, 585986]
+
+2002-07-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/io.test:
+ * generic/tclIO.c (WriteChars): Added flag to break out of loop if
+ nothing of the input is consumed at all, to prevent infinite
+ looping of called with a non-UTF-8 string. Fixes Bug 584603
+ (partially). Added new test "io-60.1". Might need additional
+ changes to Tcl_Main so that unprintable results are printed as
+ binary data.
+
+2002-07-29 Mo DeJong <mdejong@users.sourceforge.net>
+
+ * unix/Makefile.in: Use CC_SEARCH_FLAGS instead of
+ LD_SEARCH_FLAGS when linking with ${CC}.
+ * unix/configure: Regen.
+ * unix/configure.in: Don't subst CC_SEARCH_FLAGS or
+ LD_SEARCH_FLAGS since this is now done in tcl.m4.
+ * unix/tcl.m4 (SC_CONFIG_CFLAGS): Document and
+ set CC_SEARCH_FLAGS whenever LD_SEARCH_FLAGS is set.
+ [Tcl patch 588290]
- * generic/tclIO.c (CloseChannel): Rewrote CloseChannel code to
- unstack a channel during the close process. Fixed a refcount bug
- in Tcl_UnstackChannel. [Bug: 5623]
- (CloseChannel): further extended CloseChannel in the stacked case
- to effect certain operations on the next channel that would have
- been done in Tcl_Close. Also added CHANNEL_CLOSED and removed
- (TCL_READABLE|TCL_WRITABLE) bits from chanPtr->flags. Changed
- final reset of the WatchProc to check the chanDownPtr's (next)
- interestMask.
+2002-07-29 Reinhard Max <max@suse.de>
-2000-05-29 Sandeep Tamhankar <sandeep@scriptics.com>
+ * unix/tcl.m4 (SC_SERIAL_PORT): Fixed detection for cases when
+ configure's stdin is not a tty.
+
+ * unix/tclUnixPort.h:
+ * generic/tclIOSock.c: Changed size_t to socklen_t in
+ socket-related function calls.
- * tests/http.test
- * doc/http.n
- * library/http2.3/http.tcl: Fixed bug 5741, where unsuccessful
- geturl calls sometimes leaked memory and resources (sockets).
- Also, switched around some of the logic so that http::wait never
- throws an exception. This is because in an asynchronous geturl,
- the command callback will probably end up doing all the error
- handling anyway, and in an asynchronous situation, the user
- expects to check the state when the transaction completes, as
- opposed to being thrown an exception. For the http package, this
- menas the user can check http::status for "error" and http::error
- for the error message after doing the http::wait.
+ * unix/configure.in: Added test and fallback definition
+ for socklen_t.
+
+ * unix/configure: generated.
-2000-04-26 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-29 Miguel Sofer <msofer@users.sourceforge.net>
- 8.3.1 RELEASE
+ * generic/tclObj.c: fixed a comment
- * README:
- * mac/README:
- * tools/tcl.wse.in:
- * unix/README:
- * unix/tcl.spec:
- * win/README:
- * win/README.binary: Updating URLs to reference dev.scriptics.com
+ * generic/tcl.h:
+ * generic/tclBasic.c:
+ * generic/tclInterp.c: added the new flag TCL_EVAL_INVOKE to
+ the interface of the Tcl_Eval* functions, removing the
+ TCL_EVAL_NO_TRACEBACK added yesterday: alias invocations not only
+ require no tracebacks, but also look up the command name in the
+ global scope - see new test interp-9.4
+ * tests/interp.test: added 9.3 to test for safety of aliases to
+ hidden commands, 9.4 to test for correct command lookup scope.
+
+2002-07-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ * generic/regc_locale.c (cclass): [[:xdigit:]] is only a defined
+ concept on western characters, so should not allow any unicode
+ digit, and hence number of ranges in [[:xdigit:]] is fixed.
+ * tests/reg.test: Added test to detect the bug.
+ * generic/regc_cvec.c (newcvec): Corrected initial size value in
+ character vector structure. [Bug 578363] Many thanks to
+ pvgoran@users.sf.net for tracking this down.
+
+2002-07-28 Miguel Sofer <msofer@users.sourceforge.net>
-2000-04-25 Jeff Hobbs <hobbs@scriptics.com>
+ * generic/tcl.h:
+ * generic/tclBasic.c: added the new flag TCL_EVAL_NO_TRACEBACK to
+ the interface of the Tcl_Eval* functions. Modified the error
+ message for too many nested evaluations.
+ * generic/tclInterp.h: changed the Alias struct to be of variable
+ length and store the prefix arguments directly (instead of a
+ pointer to a Tcl_Obj list). Made AliasObjCmd call Tcl_EvalObjv
+ instead of TclObjInvoke - thus making aliases trigger execution
+ traces [Bug 582522].
+ * tests/interp.test:
+ * tests/stack.test: adapted to the new error message.
+ * tests/trace.test: added tests for aliases firing the exec
+ traces.
+
+2002-07-27 Mo DeJong <mdejong@users.sourceforge.net>
+
+ * unix/Makefile.in: Revert fix for Tcl bug 529801
+ since it was incorrect and broke the build on
+ other systems. Fix Tcl bug 587299.
+ Add MAJOR_VERSION, MINOR_VERSION, PATCH_LEVEL,
+ SHLIB_LD_FLAGS, SHLIB_LD_LIBS, CC_SEARCH_FLAGS,
+ LD_SEARCH_FLAGS, and LIB_FILE variables to support
+ more generic library build/install rules.
+ * unix/configure: Regen.
+ * unix/configure.in: Move AC_PROG_RANLIB into
+ tcl.m4. Move shared build test and setting
+ of MAKE_LIB and MAKE_STUB_LIB into tcl.m4.
+ Move subst of a number of variables into
+ tcl.m4 where they are defined.
+ * unix/tcl.m4 (SC_ENABLE_SYMBOLS, SC_CONFIG_CFLAGS):
+ Subst vars where they are defined. Add MAKE_LIB,
+ MAKE_STUB_LIB, INSTALL_LIB, and INSTALL_STUB_LIB
+ rules to deal with the ugly details of running
+ ranlib on static libs at build and install time.
+ Replace TCL_SHLIB_LD_EXTRAS with SHLIB_LD_FLAGS
+ and use it when building a shared library.
+ * unix/tclConfig.sh.in: Add TCL_CC_SEARCH_FLAGS.
+
+2002-07-26 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclExecute.c: fixed Tcl_Obj leak in code corresponding
+ to the macro NEXT_INST_V(x, 0, 1) [Bug 587495].
+
+2002-07-26 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/makefile.vc: updated for http change and some cleanup
- * library/http2.[13]: moved dir http2.1 to http2.3 to match version
+ * generic/tclVar.c (TclObjLookupVar): leak fix and improved
+ comments.
- * doc/Utf.3: clarified docs for Tcl_(UniChar|Utf)AtIndex
+2002-07-26 Jeff Hobbs <jeffh@ActiveState.com>
- * unix/tclUnixThrd.c: removed {}s around PTHREAD_MUTEX_INITIALIZER
- [Bug: 5254]
+ * generic/tclVar.c (TclLookupVar): removed early returns that
+ prevented the parens from being restored. also removed goto label
+ as it was not necessary.
- * unix/tclLoadDyld.c (TclpLoadFile): removed use of interp->result
+2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
-2000-04-25 Eric Melski <ericm@scriptics.com>
+ * generic/tclExecute.c:
+ * tests/expr-old.test: fix for erroneous error messages in [expr],
+ [Bug 587140] reported by Martin Lemburg.
- * unix/mkLinks:
- * doc/AddErrInfo.3: Added information about Tcl_LogCommandInfo
- [Bug: 1818].
+2002-07-25 Joe English <jenglish@users.sourceforge.net>
+ * generic/tclProc.c: fix for Tk Bug #219218 "error handling
+ with bgerror in Tk"
-2000-04-24 Eric Melski <ericm@scriptics.com>
+2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/mkLinks:
- * doc/OpenFileChnl.3: Added man entry for Tcl_Ungets [Bug: 1834].
+ * generic/tclExecute.c: restoring full TCL_COMPILE_DEBUG
+ functionality.
- * unix/mkLinks:
- * doc/SourceRCFile.3: Man page for Tcl_SourceRCFile [Bug: 1833].
+2002-07-24 Don Porter <dgp@users.sourceforge.net>
- * unix/mkLinks:
- * doc/ParseCmd.3: Added documentation for Tcl_ParseVar [Bug: 1828].
+ * tests/unixInit.test: relaxed unixInit-3.1 to accept iso8859-15
+ as a valid C encoding. [Bug 575336]
-2000-04-24 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/tclUnixNotfy.c (Tcl_FinalizeNotifier, NotifierThreadProc):
- added write of 'q' into triggerPipe for notifier in threaded case,
- so that Tcl doesn't hang when children are still running [Bug: 4139]
+ * generic/tclExecute.c: restoring the tcl_traceCompile
+ functionality while I repair tcl_traceExec. The core now compiles
+ and runs also under TCL_COMPILE_DEBUG, but execution in the
+ bytecode engine can still not be traced.
- * unix/tclUnixThrd.c (Tcl_MutexLock): minor comment fixes.
+2002-07-24 Daniel Steffen <das@users.sourceforge.net>
-2000-04-23 Jim Ingham <jingham@cygnus.com>
+ * unix/Makefile.in:
+ * unix/configure.in: corrected fix for [Bug 529801]: ranlib
+ only needed for static builds on Mac OS X.
+ * unix/configure: Regen.
+ * unix/tclLoadDyld.c: fixed small bugs introduced by Vince,
+ implemented library unloading correctly (needs OS X 10.2).
- These changes make some error handling marginally better for Mac
- sockets. It is still somewhat flakey, however.
+2002-07-23 Joe English <jenglish@users.sourceforge.net>
- * mac/tclMacSock.c (TcpClose): Add timeouts to the close - these
- don't seem to be honored, however.
- Use a separate PB for the release, since an async connect socket
- will still be using the original buffer.
- Make sure TCPRelease returns noErr before freeing the recvBuff.
- If the call returns an error, then the buffer is not right.
- * mac/tclMacSock.c (CreateSocket): Add timeouts to the async
- create. These don't seem to trigger, however. Sigh...
- * mac/tclMacSock.c (WaitForSocketEvent): If an TCP_ASYNC_CONNECT
- socket errors out, then return EWOULDBLOCK & error out.
- * mac/tclMacSock.c (NotifyRoutine): Added a NotifyRoutine for
- experimenting with MacTCP.
+ * doc/OpenFileChnl.3: (Updates from Larry Virden)
+ * doc/open.n:
+ * doc/tclsh.1: Fix section numbers in Unix man page references.
+ * doc/lset.n: In EXAMPLES section, include command to set the
+ initial value used in subsequent examples.
+ * doc/http.n: Package version updated to 2.4.
-2000-04-22 Jim Ingham <jingham@cygnus.com>
+2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
- * library/package.tcl (tclPkgUnknown): Fixed a typo in the Mac package
- search part of tclPkgUnknown.
+ * unix/configure: Regen.
+ * unix/tcl.m4 (SC_CONFIG_CFLAGS): Enable 64 bit compilation
+ when using the native compiler on a 64 bit version of IRIX.
+ [Tcl bug 219220]
-2000-04-21 Sandeep Tamhankar <sandeep@scriptics.com>
+2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
- * library/http2.1/http.tcl: Fixed a newly introduced bug where if
- there's a -command callback and something goes wrong, geturl threw
- an exception, called the callback, and unset the token. I changed
- it so that it will not call the callback when throwing an
- exception (so the caller only finds out about a given error from
- one place). Also, fixed http::ncode so that it actually gives you
- back the http return code (i.e. 200, 404, etc.) instead of the
- first digit of the version of HTTP being used (i.e. 1).
+ * unix/Makefile.in: Combine ranlib tests and
+ avoid printing unless ranlib is actually run.
-2000-04-21 Brent Welch <welch@scriptics.com>
+2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
- * library/http2.1/http.tcl: More thrashing with the "server closes
- without reading post data" scenario. Reverted to the previous
- filevent configuratiuon, which seems to work better with small
- amounts of post data.
+ * unix/tcl.m4 (SC_PATH_X): Set XINCLUDES to "" instead
+ of "# no special path needed" or "# no include files found"
+ when x headers cannot be located.
-2000-04-20 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-22 Vince Darley <vincentdarley@users.sourceforge.net>
- * generic/tclAlloc.c: wrapped caddr_t define to not be done on Unix
- * unix/tclUnixPort.h: added Tclp*Alloc defines to allow the use of
- USE_TCLALLOC on Unix. [Bug: 4731]
+ * generic/tclIOUtil.c: made tclNativeFilesystem static
+ (since 07-19 changes removed its usage elsewhere), and
+ added comments about its usage.
+ * generic/tclLoad.c:
+ * generic/tcl.h:
+ * generic/tcl.decls:
+ * doc/FileSystem.3: converted last load-related ClientData
+ parameter to Tcl_LoadHandle opaque structure, removing a
+ couple of casts in the process.
+
+ * generic/tclInt.h: removed tclNativeFilesystem declaration
+ since it is now static again.
+
+2002-07-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-2000-04-19 Jeff Hobbs <hobbs@scriptics.com>
+ * tests/expr.test (expr-22.*): Added tests to help detect the
+ corrected handling.
+ * generic/tclExecute.c (IllegalExprOperandType): Improved error
+ message generated when attempting to manipulate Inf and NaN values.
+ * generic/tclParseExpr.c (GetLexeme): Allowed parser to recognise
+ 'Inf' as a floating-point number. [Bug 218000]
- * library/dde1.1/pkgIndex.tcl:
- * library/reg1.0/pkgIndex.tcl:
- * win/tclWinChan.c:
- * win/tclWinThrd.c: converted CRLF to LF the */tcl.hpj.in files
- were not converted, as it confuses hcw locally. [Bug: 5096]
+2002-07-21 Don Porter <dgp@users.sourceforge.net>
- * win/Makefile.in: expanded cleanup target for help files
+ * tclIOUtil.c: Silence compiler warning. [Bug 584408].
- * doc/Thread.3: minor macro cleanup
+2002-07-19 Vince Darley <vincentdarley@users.sourceforge.net>
- * generic/tclFileName.c (SplitUnixPath): added support for QNX
- node ids.
+ * generic/tclIOUtil.c: fix to GetFilesystemRecord
+ * win/tclWinFile.c:
+ * unix/tclUnixFile.c: fix to subtle problem with links shown
+ up by latest tclkit builds.
-2000-04-18 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-19 Mo DeJong <mdejong@users.sourceforge.net>
- * README:
- * generic/tcl.h:
- * tools/tcl.wse.in:
+ * unix/configure:
* unix/configure.in:
- * unix/tcl.spec:
- * win/configure.in:
- * win/README.binary: bumped version to 8.3.1
+ * win/configure:
+ * win/configure.in: Add AC_PREREQ(2.13) in an attempt
+ to make it more clear that the configure scripts
+ must be generated with autoconf version 2.13.
+ [Bug 583573]
- * win/tcl.hpj.in: updated copyright date
+2002-07-19 Vince Darley <vincentdarley@users.sourceforge.net>
- * generic/tclEnv.c: environment support for Mac OS/X
- * unix/tclUnixPort.h: environment support for Mac OS/X
- * unix/tclLoadDyld.c: new file for Mac OS/X dl functions
- * unix/Makefile.in: added install-strip target; bindir, libdir,
- mandir, includedir vars; tclLoadDyld.c target [Bug: 2527]
+ * unix/Makefile.in: fix to build on MacOS X [Bug 529801], bug
+ report and fix from jcw.
- * unix/tclUnixChan.c (CreateSocket): force a socket back into
- blocking mode (default state) after a -async connect succeeds.
- [Bug: 4388]
+2002-07-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * generic/tclEvent.c (TclInitSubsystems): Moved tclLibraryPath to
- thread-local storage to prevent thread-related race condition.
- [Bug: 5033]
- * unix/tclAppInit.c (main): removed #ifdef TCL_TEST that sets the
- library path as it was unnecessary and conflicts with move of
- tclLibraryPath to thread-local storage.
+ * win/tclWinSerial.c (no_timeout): Made this variable static.
-2000-04-18 Scott Redman <redman@scriptics.com>
+ * generic/tclExecute.c, generic/tclCompile.c, generic/tclBasic.c:
+ * generic/tclCompile.h (builtinFuncTable, instructionTable): Added
+ prefix to these symbols because they are visible outside the Tcl
+ library.
- * win/Makefile.in:
- * win/tcl.rc:
- * win/tclsh.rc:
- * win/tclsh.ico: Modified copyright dates in Windows resource
- files. Added an icon for tclsh.exe.
+ * generic/tclCompExpr.c (operatorTable):
+ * unix/tclUnixTime.c (tmKey):
+ * generic/tclIOUtil.c (theFilesystemEpoch, filesystemWantToModify,
+ filesystemIteratorsInProgress, filesystemOkToModify): Made these
+ variables static.
-2000-04-17 Brent Welch <welch@scriptics.com>
+ * unix/tclUnixFile.c: Renamed nativeFilesystem to
+ * win/tclWinFile.c: tclNativeFilesystem and declared
+ * generic/tclIOUtil.c: it properly in tclInt.h
+ * generic/tclInt.h:
- * generic/tcl.h, generic/tclThreadTest.c, unix/tclUnixThrd.c,
- win/tclWinThread.c, mac/tclMacThread.c:
- Added Tcl_CreateThreadType and TCL_RETURN_THREAD_TYPE
- macros for declaring the NewThread callback proc.
+ * generic/tclUtf.c (totalBytes): Made this array static and const.
-2000-04-14 Jeff Hobbs <hobbs@scriptics.com>
+ * generic/tclParse.c (typeTable): Made this array static and const.
+ (Tcl_ParseBraces): Simplified error handling case so that scans
+ are only performed when needed, and flags are simpler too.
- * unix/tclUnixChan.c (TtyParseMode): Only allow setting mark/space
- parity on platforms that support it [Bug: 5089]
+ * license.terms: Added AS to list of copyright holders; it's only
+ fair for the current gatekeepers to be listed here!
- * generic/tclBasic.c (Tcl_GetVersion): adjusted use of major/minor
- to not conflict with global decl on some systems [Bug: 2882]
+ * tests/cmdMZ.test: Renamed constraint for clarity. [Bug#583427]
+ Added tests for the [time] command, which was previously only
+ indirectly tested!
- * doc/AppInit.3:
- * doc/Async.3:
- * doc/BackgdErr.3:
- * doc/CrtChannel.3:
- * doc/CrtInterp.3:
- * doc/CrtMathFnc.3:
- * doc/DString.3:
- * doc/Eval.3:
- * doc/ExprLong.3:
- * doc/GetInt.3:
- * doc/GetOpnFl.3:
- * doc/Interp.3:
- * doc/LinkVar.3:
- * doc/OpenFileChnl.3:
- * doc/OpenTcp.3:
- * doc/PkgRequire.3:
- * doc/RecordEval.3:
- * doc/SetResult.3:
- * doc/SplitList.3:
- * doc/StaticPkg.3:
- * doc/TraceVar.3:
- * doc/Translate.3:
- * doc/UpVar.3:
- * doc/load.n: removed or updated references to interp->result use.
+2002-07-18 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * generic/tclInt.h:
+ * generic/tcl.h:
+ * */*Load*.c: added comments on changes of 07/17 and
+ replaced clientData with Tcl_LoadHandle in all locations.
+
+ * generic/tclFCmd.c:
+ * tests/fileSystem.test: fixed a 'knownBug' with 'file
+ attributes ""'
+ * tests/winFCmd.test:
+ * tests/winPipe.test:
+ * tests/fCmd.test:
+ * tessts/winFile.test: added 'pcOnly' constraint to some
+ tests to make for more useful 'tests skipped' log from
+ running all tests on non-Windows platforms.
+
+2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclBasic.c (CallCommandTraces): delete traces now
+ receive the FQ old name of the command.
+ [Bug 582532] (Don Porter)
-2000-04-13 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-18 Vince Darley <vincentdarley@users.sourceforge.net>
- * doc/regexp.n: doc clarification [Bug: 5037]
- * doc/update.n: typo fix [Bug: 4996]
+ * tests/ioUtil.test: added constraints to 1.4,2.4 so they
+ don't run outside of tcltest. [Bugs 583276,583277]
+
+2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/tcl.m4 (SC_ENABLE_THREADS): enhanced the detection of
- pthread_mutex_init [Bug: 4359] and (SC_CONFIG_CFLAGS) added
- --enable-64bit-vis switch for Sparc VIS compilation [Bug: 4995]
+ * generic/tclVar.c (DupParsedVarName): nasty bug fixed, reported
+ by Vince Darley.
-2000-04-12 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
- * doc/dde.n: corrected dde poke docs. [Bug: 4991]
+ * generic/tclVar.c (TclPtrIncrVar): missing CONST in declarations,
+ inconsistent with tclInt.h. Thanks to Vince Darley for reporting,
+ boo to gcc for not complaining.
+
+2002-07-17 Vince Darley <vincentdarley@users.sourceforge.net>
-2000-04-11 Eric Melski <ericm@scriptics.com>
+ * generic/tclInt.h:
+ * generic/tclIOUtil.c:
+ * generic/tclLoadNone.c:
+ * unix/tclLoadAout.c:
+ * unix/tclLoadDl.c:
+ * unix/tclLoadDld.c:
+ * unix/tclLoadDyld.c:
+ * unix/tclLoadNext.c:
+ * unix/tclLoadOSF.c:
+ * unix/tclLoadShl.c:
+ * mac/tclMacLoad.c:
+ * win/tclWinLoad.c: modified to move more functionality
+ to the generic code and avoid duplication. Partial replacement
+ of internal uses of clientData with opaque Tcl_LoadHandle. A
+ little further work still needed, but significant changes are done.
+
+2002-07-17 D. Richard Hipp <drh@hwaci.com>
+
+ * library/msgcat/msgcat.tcl: fix a comment that was causing
+ problems for programs (ex: mktclapp) that embed the initialization
+ scripts in strings.
+
+2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
- * win/tclWinPipe.c: Added "CONST" keyword to declaration of char
- *native in TclpCreateTempFile, to supress compiler warnings.
+ * generic/tclInt.decls:
+ * generic/tclIntDecls.h:
+ * generic/tclStubInit.c:
+ * generic/tclVar.c: removing the now redundant functions to access
+ indexed variables: Tcl(Get|Set|Incr)IndexedScalar() and
+ Tcl(Get|Set|Incr)ElementOfIndexedArray().
-2000-04-10 Brent Welch <welch@scriptics.com>
+2002-07-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * generic/tcl.h: Fixed Tcl_CreateThread declaration.
- * library/tcltest1.0/tcltest.tcl: Fixed the "mainThread"
- initialization to work with either testthread or the thread extension
- * unix/tclUnixThrd.c: Fixed compiler warning when compiling
- with -DTCL_THREADS
+ * generic/tclExecute.c (TclExecuteByteCode): Minor fixes to make
+ this file compile with SunPro CC...
-2000-04-10 Eric Melski <ericm@scriptics.com>
+2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
- * win/tclWinPipe.c (TclpCreateTempFile): Added conversion of
- contents string from UTF to native encoding [Bug: 4030].
+ * generic/tclExecute.c: modified to do variable lookup explicitly,
+ and then either inlining the variable access or else calling the new
+ TclPtr(Set|Get|Incr)Var functions in tclVar.c
+ * generic/tclInt.h: declare some functions previously local to
+ tclVar.c for usage by TEBC.
+ * generic/tclVar.c: removed local declarations; moved all special
+ accessor functions for indexed variables to the end of the file -
+ they are unused and ready for removal, but left there for the time
+ being as they are in the internal stubs table.
- * tests/regexp.test: Added tests for infinite looping in [regexp
- -all].
+ ** WARNING FOR BYTECODE MAINTAINERS **
+ TCL_COMPILE_DEBUG is currently not functional; will be fixed ASAP.
- * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all]
- [Bug: 4981].
+2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
- * tests/*.test: Changed all occurances of "namespace import
- ::tcltest" to "namespace import -force ::tcltest" [Bug: 3948].
+ * unix/Makefile.in:
+ * win/Makefile.in: Add a more descriptive warning
+ in the event `make genstubs` needs to be rerun.
-2000-04-09 Brent Welch <welch@scriptics.com>
+2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
- * lib/httpd2.1/http.tcl: Worked on the "server closes before
- reading post data" case, which unfortunately causes different
- error cases on Solaris, which can read the reply, and Linux
- and Windows, which cannot read anything. This is all in the
- loop-back case - client and server on the same host. Also
- unified the error handling so the "ioerror" status goes away
- and errors are reflected in a more uniform way. Updated the
- man page to document the behavior.
+ * unix/Makefile.in: Use dltest.marker file
+ to keep track of when the dltest package
+ is up to date. This fixes [Tcl bug 575768]
+ since tcltest is no longer linked every time.
+ * unix/dltest/Makefile.in: Create ../dltest.marker
+ after a successful `make all` run in dltest.
-2000-04-09 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
- * tests/reg.test (matchexpected): corrected tests to use tcltest
- constraint types to skip certain tests.
+ * unix/configure: Regen.
+ * unix/configure.in: Remove useless subst of TCL_BIN_DIR.
- * generic/tclBasic.c (Tcl_SetCommandInfo): comment fix
+2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/tclUnixThrd.c (Tcl_CreateThread): moved TCL_THREADS ifdef
- inside of func as it is declared for non-threads builds as well.
- In the non-threads case, it always returns TCL_ERROR (couldn't
- create thread).
+ * generic/tclVar.c: inaccurate comment fixed
+
+2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclBasic.c (Tcl_AddObjErrorInfo):
+ * generic/tclExecute.c (TclUpdateReturnInfo):
+ * generic/tclInt.h:
+ * generic/tclProc.c:
+ Added two Tcl_Obj to the ExecEnv structure to hold the fully
+ qualified names "::errorInfo" and "::errorCode" to cache the
+ addresses of the corresponding variables. The two most frequent
+ setters of these variables now profit from the new variable name
+ caching.
+
+2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclVar.c: refactorisation to reuse already looked-up Var
+ pointers; definition of three new Tcl_Obj types to cache variable
+ name parsing and lookup for later reuse; modification of internal
+ functions to profit from the caching.
+
+ * generic/tclInt.decls:
+ * generic/tclInt.h:
+ * generic/tclIntDecls.h:
+ * generic/tclNamesp.c: adding CONST qualifiers to variable names
+ passed to Tcl_FindNamespaceVar and to variable resolvers; adding
+ CONST qualifier to the 'msg' argument to TclLookupVar. Needed to
+ avoid code duplication in the new tclVar.c code.
+
+ * tests/set-old.test:
+ * tests/var.test: slight modification of error messages due to the
+ modifications in the tclVar.c code.
+
+2002-07-15 Don Porter <dgp@users.sourceforge.net>
+
+ * tests/unixInit.test: Improved constraints to protect /tmp.
+ [Bug 581403]
+
+2002-07-15 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * tests/winFCmd.test: renamed 'win2000' and 'notWin2000' to
+ more appropriate constraint names.
+ * win/tclWinFile.c: updated comments to reflect 07-11 changes.
+ * win/tclWinFCmd.c: made ConvertFileNameFormat static again,
+ since no longer used in tclWinFile.c
+ * mac/tclMacFile.c: completed TclpObjLink implementation which
+ was previously lacking.
+ * generic/tclIOUtil.c: comment cleanup and code speedup.
+
+2002-07-14 Don Porter <dgp@users.sourceforge.net>
-2000-04-08 Andreas Kupries <a.kupries@westend.com>
+ * generic/tclInt.h: Removed declarations that duplicated entries
+ in the (internal) stub table.
+
+ * library/tcltest/tcltest.tcl: Corrected errors in handling of
+ configuration options -constraints and -limitconstraints.
- * Overall change: Definition of a public API for the creation of
- new threads.
+ * README: Bumped HEAD to version 8.4b2 so we can
+ * generic/tcl.h: distinguish it from the 8.4b1 release.
+ * tools/tcl.wse.in:
+ * unix/configure*:
+ * unix/tcl.spec:
+ * win/README.binary:
+ * win/configure*:
- * generic/tclInt.h (line 1802f): Removed the definition of
- 'TclpThreadCreate'. (line 793f) Removed the definition of
- 'Tcl_ThreadCreateProc'.
+2002-07-11 Vince Darley <vincentdarley@users.sourceforge.net>
- * generic/tcl.h (line 388f): Readded the definition of
- 'Tcl_ThreadCreateProc'. Added Win32 stuff send in by David
- Graveraux <davygrvy@bigfoot.com> to that too (__stdcall,
- ...). Added macros for the default stacksize and allowed flags.
+ * doc/file.n:
+ * win/tclWinFile.c: on Win 95/98/ME the long form of the path
+ is used as a normalized form. This is required because short
+ forms are not a robust representation. The file normalization
+ function has been sped up, but more performance gains might be
+ possible, if speed is still an issue on these platforms.
- * generic/tcl.decls (line 1356f): Added definition of
- 'Tcl_CreateThread', slot 393 of the stub table. Two new
- arguments in the public API, for stacksize and flags.
+2002-07-11 Don Porter <dgp@users.sourceforge.net>
- * win/tclWinThrd.c:
- * mac/tclMacThrd.c: Renamed TclpThreadCreate to Tcl_CreateThread,
- added handling of the stacksize. Flags are currently ignored.
+ * library/tcltest/tcltest.tcl: Corrected reaction to existing but
+ false ::tcl_interactive.
- * unix/tclUnixThrd.c: See above, but handles joinable
- flag. Ignores the specified stacksize if the macro
- HAVE_PTHREAD_ATTR_SETSTACKSIZE is not defined.
+ * doc/Hash.3: Overlooked CONST documentation update.
- * generic/tclThreadTest.c (line 363): See below.
+2002-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * unix/tclUnixNotfy.c (line 210): Adapted to the changes
- above. Uses default stacksize and no flags now.
+ * generic/tclCkalloc.c: ckalloc() and friends take the block size
+ as an unsigned, so we should use %ud when reporting it in fprintf()
+ and panic().
- * unic/tcl.m4 (line 382f): Added a check for
- 'pthread_attr_setstacksize' to detect platforms not implementing
- this feature of pthreads. If it is implemented, configure will
- define the macro HAVE_PTHREAD_ATTR_SETSTACKSIZE (See
- unix/tclUnixThrd.c too).
+2002-07-11 Miguel Sofer <msofer@users.sourceforge.net>
- * doc/Thread.3: Added Tcl_CreateThread and its arguments to the
- list of described functions. Removed stuff about not providing a
- public C-API for thread-creation.
+ * generic/tclCompile.c: now setting local vars undefined at
+ compile time, instead of waiting until the proc is initialized.
+ * generic/tclProc.c: use macro TclSetVarUndefined instead of
+ directly etting the flag.
-2000-04-07 Jeff Hobbs <hobbs@scriptics.com>
+2002-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * doc/binary.n: clarified docs on sign extension in binary scan
- [Bug: 3466]
+ * tests/cmdAH.test: [file attr -perm] is Unix-only, so add [catch]
+ when not inside a suitably-protected test.
- * library/tcltest1.0/tcltest.tcl (initConstraints): removed win32s
- references (no longer supported)
+2002-07-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * tests/fCmd.test: marked test 8.1 knownBug because it is
- dangerous on poorly configured systems [Bug: 3881]
- and added 8.2 to keep essence of 8.1 tested.
+ * tests/unixFCmd.test, tests/fileName.test:
+ * tests/fCmd.test: Removed [exec] of Unix utilities that have
+ equivalents in standard Tcl. [Bug 579268] Also simplified some
+ of unixFCmd.test while I was at it.
-2000-04-05 Andreas Kupries <a.kupries@westend.com>
+2002-07-10 Don Porter <dgp@users.sourceforge.net>
- * generic/tclIO.c (Tcl_UnstackChannel, line 1831): Forcing
- interest mask to the correct value after an unstack and
- re-initialization of the notifier via the watchProc. Without this
- the first fileevent after an unstack will come through and be
- processed, but no more. [Bug: ??].
+ * tests/tcltest.test: Greatly reduced the number of [exec]s, using
+ slave interps instead.
+ * library/tcltest/tcltest.tcl: Fixed bug uncovered in the conversion
+ where a message was written to stdout instead of [outputChannel].
-2000-03-04 Brent Welch <welch@scriptics.com>
+ * tests/basic.test: Cleaned up, constrained, and reduced the
+ * tests/compile.test: amount of [exec] usage in the test suite.
+ * tests/encoding.test:
+ * tests/env.test:
+ * tests/event.test:
+ * tests/exec.test:
+ * tests/io.test:
+ * tests/ioCmd.test:
+ * tests/regexp.test:
+ * tests/regexpComp.test:
+ * tests/socket.test:
+ * tests/tcltest.test:
+ * tests/unixInit.test:
+ * tests/winDde.test:
+ * tests/winPipe.test:
- * {win,unix}/Makefile.in: added dependency of tclStubInit.c on
- tcl.decls and tclInt.decls
- * generic/tclThread.c: Tweak so this compiles w/out TCL_THREADS
- * generic/{tcl.decls,tclStubInit.c}: Just touched the tcl.decls and
- regenerated the tclStubInit.c file
+2002-07-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-2000-03-29 Sandeep Tamhankar <sandeep@scriptics.com>
+ * tests/cmdAH.test: Removed [exec] of Unix utilities. [Bug 579211]
- * library/http2.1/http.tcl: For the -querychannel option,
- fconfigure the socket to be binary so that we don't translate
- anything while reading the data. This is because we determine the
- content length of the data on the channel by using seek (to the end
- of the file) and tell on the file handle, and we need the
- content-length to match the amount of data actually sent, and
- translation can affect the number of bytes posted.
+ * tests/expr.test: Added tests to make sure that this works.
+ * generic/tclExecute.c (ExprCallMathFunc): Functions should also
+ be able to return wide-ints. [Bug 579284]
-2000-04-03 Andreas Kupries <a.kupries@westend.com>
+2002-07-08 Andreas Kupries <andreas_kupries@users.sourceforge.net>
- * Overall change: Definition of public API's for the finalization
- of conditions and mutexes. [Bug: 4199].
+ * tests/socket.test: Fixed bug #578164. The original reason for
+ the was a DNS outage while running the testsuite. Changed [info
+ hostname] to 127.0.0.1 to bypass DNS, knowing that we operate on
+ the local host.
- * generic/tclInt.h: Removed definitions of TclFinalizeMutex and
- TclFinalizeCondition.
+2002-07-08 Don Porter <dgp@users.sourceforge.net>
- * generic/tcl.decls: Added declarations of Tcl_MutexFinalize and
- Tcl_ConditionFinalize.
+ * doc/tcltest.n: Fixed incompatibility in [viewFile].
+ * library/tcltest/tcltest.tcl: Corrected docs. Bumped to 2.2.1.
+ * library/tcltest/pkgIndex.tcl: [Bug 578163]
- * generic/tclThread.c: Renamed TclFinalizeMutex to
- Tcl_MutexFinalize. Renamed TclFinalizeCondition to
- Tcl_ConditionFinalize.
+2002-07-08 Vince Darley <vincentdarley@users.sourceforge.net>
- * generic/tclNotify.c: Changed usage of TclFinalizeMutex to
- Tcl_MutexFinalize.
+ * tests/cmdAH.test:
+ * tests/fCmd.test:
+ * tests/fileName.test: tests which rely on 'file link' need a
+ constraint so they don't run on older Windows OS. [Bug 578158]
+ * generic/tclIOUtil.c:
+ * generic/tcl.h:
+ * generic/tclInt.h:
+ * generic/tclTest.c:
+ * mac/tclMacChan.c:
+ * unix/tclUnixChan.c:
+ * win/tclWinChan.c:
+ * doc/FileSystem.3: cleaned up internal handling of
+ Tcl_FSOpenFileChannel to remove duplicate code, and make
+ writing external vfs's clearer and easier. No
+ functionality change. Also clarify that objects with refCount
+ zero should not be passed in to the Tcl_FS API, and prevent
+ segfaults from occuring on such user errors. [Bug 578617]
+
+2002-07-06 Don Porter <dgp@users.sourceforge.net>
+
+ * tests/pkgMkIndex.test: Constrained tests of [load] package indexing
+ to those platforms where the testing shared libraries have been built.
+ [Bug 578166].
+
+2002-07-05 Don Porter <dgp@users.sourceforge.net>
+ * changes: added recent changes
+
+2002-07-05 Reinhard Max <max@suse.de>
+
+ * generic/tclClock.c (FormatClock): Convert the format string to
+ UTF8 before calling TclpStrftime, so that non-ASCII characters
+ don't get mangled when the result string is being converted back.
+ * tests/clock.test: Added a test for that.
+
+2002-07-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ * unix/Makefile.in (ro-test,ddd,GDB,DDD): Created new targets to
+ allow running the test suite with a read-only current directory,
+ running under ddd instead of gdb, and factored out some executable
+ names for broken sites (like mine) where gdb and ddd are installed
+ with non-standard names...
+
+ * tests/httpold.test: Altered test names to httpold-* to avoid
+ clashes with http.test, and stopped tests from failing when the
+ current directory is not writable...
+
+ * tests/event.test: Stop these tests from failing
+ * tests/ioUtil.test: when the current directory is
+ * tests/regexp.test: not writable...
+ * tests/regexpComp.test:
+ * tests/source.test:
+ * tests/unixFile.test:
+ * tests/unixNotfy.test:
+
+ * tests/unixFCmd.test: Trying to make these test-files
+ * tests/macFCmd.test: not bomb out with an error when
+ * tests/http.test: the current directory is not
+ * tests/fileName.test: writable...
+ * tests/env.test:
- * unix/tclUnixNotfy.c:
- * generic/tclThreadTest.c: Changed usages of TclFinalizeCondition to
- Tcl_ConditionFinalize.
+2002-07-05 Jeff Hobbs <jeffh@ActiveState.com>
- * generic/tcl.h: Added empty macros for Tcl_MutexFinalize and
- Tcl_ConditionFinalize, to be used when the core is compiled
- without threads.
+ *** 8.4b1 TAGGED FOR RELEASE ***
- * doc/Thread.3: Added description the new API's.
+2002-07-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-2000-04-03 Jeff Hobbs <hobbs@scriptics.com>
+ * tests/cmdMZ.test (cmdMZ-1.4):
+ * tests/cmdAH.test: More fixing of writable-current-dir
+ assumption. [Bug 575824]
- * generic/tclCmdIL.c (InfoVarsCmd): checked for non-NULL procPtr
- to prevent itcl info override crash [Bug: 4064]
+2002-07-04 Miguel Sofer <msofer@users.sourceforge.net>
- * tests/foreach.test:
- * tests/namespace.test:
- * tests/var.test: Added lsorts to avoid random sorted return
- problems. [Bug: 2682]
+ * tests/basic.test: Same issue as below; fixed [Bug 575817]
+
+2002-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/socket.test:
+ * tests/winPipe.test:
+ * tests/pid.test: Fixed SF Bug #575848. See below for a
+ description the general problem.
+
+ * All the bugs below are instances of the same problem: The
+ testsuite assumes [pwd] = [temporaryDirectory] and writable.
+
+ * tests/iogt.test: Fixed bug #575860.
+ * tests/io.test: Fixed bug #575862.
+ * tests/exec.test:
+ * tests/ioCmd.test: Fixed bug #575836.
+
+2002-07-03 Don Porter <dgp@users.sourceforge.net>
+
+ * tests/pkg1/direct1.tcl: removed
+ * tests/pkg1/pkgIndex.tcl: removed
+ * tests/pkgMkIndex.test: Imported auxilliary files from tests/pkg1
+ into the test file pkgMkIndex.test itself. Formatting fixes.
+
+ * unix/Makefile.in: removed tests/pkg/* from `make dist`
+
+ * tests/pkg/circ1.tcl: removed
+ * tests/pkg/circ2.tcl: removed
+ * tests/pkg/circ3.tcl: removed
+ * tests/pkg/global.tcl: removed
+ * tests/pkg/import.tcl: removed
+ * tests/pkg/pkg1.tcl: removed
+ * tests/pkg/pkg2_a.tcl: removed
+ * tests/pkg/pkg2_b.tcl: removed
+ * tests/pkg/pkg3.tcl: removed
+ * tests/pkg/pkg4.tcl: removed
+ * tests/pkg/pkg5.tcl: removed
+ * tests/pkg/pkga.tcl: removed
+ * tests/pkg/samename.tcl: removed
+ * tests/pkg/simple.tcl: removed
+ * tests/pkg/spacename.tcl: removed
+ * tests/pkg/std.tcl: removed
+ * tests/pkgMkIndex.test: Fixed [Bug 575857] where this test file
+ expected to be able to write to [file join [testsDirectory]
+ pkg]. Part of the fix was to import several auxilliary files
+ into the test file itself.
+
+ * tests/main.test: Cheap fix for [Bugs 575851, 575858]. Avoid
+ * tests/tcltest.test: non-writable . by [cd [temporaryDirectory]].
+
+ * library/auto.tcl: Fix [tcl_findLibrary] to be sure it sets
+ $varName only if a successful library script is found.
+ [Bug 577033]
+
+2002-07-03 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclCompCmds.c (TclCompileCatchCmd): return
+ TCL_OUT_LINE_COMPILE instead of TCL_ERROR: let the failure
+ happen at runtime so that it can be caught [Bug 577015].
+
+2002-07-02 Joe English <jenglish@users.sourceforge.net>
+
+ * doc/tcltest.n: Markup fixes, spellcheck.
+
+2002-07-02 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/tcltest.n: more refinements of the documentation.
+
+ * library/tcltest/tcltest.tcl: Added trace to be sure the stdio
+ constraint is updated whenever the [interpreter] changes.
+
+ * doc/tcltest.n: Reverted [makeFile] and [viewFile] to
+ * library/tcltest/tcltest.tcl: their former behavior, and documented
+ * tests/cmdAH.test: it. Corrected misspelling of hook
+ * tests/event.test: procedure. Restored tests.
+ * tests/http.test:
+ * tests/io.test:
- * tests/fileName.test: fixed 14.1 test fragility [Bug: 1482]
+ * library/tcltest/tcltest.tcl: Simplified logic of
+ [GetMatchingFiles] and [GetMatchingDirectories], removing
+ special case processing.
- * tools/man2help2.tcl: fixed winhelp cross-linking error [Bug: 4156]
- improved translation to winhelp [Bug: 3679]
+ * doc/tcltest.n: More documentation updates. Reference sections
+ are complete. Only examples need adding.
- * unix/Makefile.in (MAN_INSTALL_DIR): patch to accept --mandir
- correctly [Bug: 4085]
+2002-07-02 Vince Darley <vincentdarley@users.sourceforge.net>
- * unix/dltest/pkg[a-e].c: Cleaned up test packages [Bug: 2293]
+ * tests/fCmd.test:
+ * generic/tclCmdAH.c: clearer error msgs for 'file link',
+ as per the man page.
-2000-04-03 Eric Melski <ericm@scriptics.com>
+2002-07-01 Joe English <jenglish@users.sourceforge.net>
- * unix/tclUnixFCmd.c (SetGroupAttribute):
- * unix/tclUnixFCmd.c (SetOwnerAttribute): Added (uid_t) and (gid_t)
- casts to avoid compiler warnings.
+ * doc/Access.3:
+ * doc/AddErrInfo.3:
+ * doc/Alloc.3:
+ * doc/Backslash.3:
+ * doc/CrtChannel.3:
+ * doc/CrtSlave.3:
+ * doc/Encoding.3:
+ * doc/Eval.3:
+ * doc/FileSystem.3:
+ * doc/Notifier.3:
+ * doc/OpenFileChnl.3:
+ * doc/ParseCmd.3:
+ * doc/RegExp.3:
+ * doc/Tcl_Main.3:
+ * doc/Thread.3:
+ * doc/TraceCmd.3:
+ * doc/Utf.3:
+ * doc/WrongNumArgs.3:
+ * doc/binary.n:
+ * doc/clock.n:
+ * doc/expr.n:
+ * doc/fconfigure.n:
+ * doc/glob.n:
+ * doc/http.n:
+ * doc/interp.n:
+ * doc/lsearch.n:
+ * doc/lset.n:
+ * doc/msgcat.n:
+ * doc/packagens.n:
+ * doc/pkgMkIndex.n:
+ * doc/registry.n:
+ * doc/resource.n:
+ * doc/safe.n:
+ * doc/scan.n:
+ * doc/tclvars.n: Spell-check, fixed typos (Updates from Larry Virden).
-2000-03-31 Eric Melski <ericm@scriptics.com>
+2002-07-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * generic/tclGet.c (Tcl_GetDouble): Added additional conditions to
- error test (previously only errno was checked, but the return
- value of strtod() should be checked as well). [Bug: 4118].
+ * unix/tcl.m4 (SC_CONFIG_CFLAGS): Made Solaris use gcc for linking
+ when building with gcc to resolve problems with undefined symbols
+ being present when tcl library used with non-gcc linker at later
+ stage. Symbols were compiler-generated, so it is the compiler's
+ business to define them. [Bug #541181]
- * tests/exec.test: Added test for proper conversion of UTF data
- when used with "<< $dataWithUTF" on exec's.
+2002-07-01 Don Porter <dgp@users.sourceforge.net>
- * unix/tclUnixPipe.c (TclpCreateTempFile): Added
- Tcl_UtfToExternalDString call, so that if there is UTF content in
- the string it will be properly converted to the system encoding
- before being written [Bug: 4030].
- (TclpCreateTempFile): Added a check on the return value of tmpnam;
- some systems (Linux, for example) will start to return NULL after
- tmpnam has been called TMP_MAX times; not checking for this can
- have bad results (overwriting temp files, core dumps, etc.)
+ * doc/tcltest.n: more work in progress updating tcltest docs.
-2000-03-30 Jeff Hobbs <hobbs@scriptics.com>
+ * library/tcltest/tcltest.tcl: Change [configure -match] to
+ stop treating an empty list as a list of the single pattern "*".
+ Changed the default value to [list *] so default operation
+ remains the same.
- * generic/tclBasic.c (Tcl_DeleteCommandFromToken): Added comments
- noting the need to pair ckalloc with ckfree. [Bug: 4262]
+ * tests/pkg/samename.tcl: restored. needed by pkgMkIndex.test.
- * generic/tclInt.decls:
- * generic/tclIntPlatDecls.h:
- * generic/tclStubInit.c:
- * win/tclWin32Dll.c: removed TclWinSynchSpawn (vestige of Win32s
- support).
-
- * win/tclWinReg.c: made use of TclWinGetPlatformId instead of
- getting info again
-
- * win/tclWinPort.h:
- * win/Makefile.in:
- * win/configure.in:
- * win/tcl.m4: Added support for gcc/mingw on Windows [Bug: 4234]
-
-2000-03-29 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclCompile.c (TclCleanupByteCode): made ByteCode cleanup
- more aware of TCL_BYTECODE_PRECOMPILED flagged structs (gen'd by
- tbcload), to correctly clean them up.
-
- * generic/tclClock.c (FormatClock): moved check for empty format
- earlier, commented 0 result return value
-
-2000-03-29 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Removed an unnecessary fileevent
- statement from the error processing part of the Write method.
- Also, fixed two potential memory leaks in wait and reset, in which
- the state array wasn't being unset before throwing an exception.
- Prior to this version, Brent checked in a fix to catch a
- fileevent statement that was sometimes causing a stack trace when
- geturl was called with -timeout. I believe Brent's fix is
- necessary because TLS closes bad sockets for secure connections,
- and the fileevent was trying to act on a socket that no longer
- existed.
-
-2000-03-27 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/httpd: removed unnecessary 'puts stderr "Post Dispatch"'
-
- * tests/namespace.test:
- * generic/tclNamesp.c (Tcl_Export): added a uniq'ing test to the
- export list so only one instance of each export pattern would
- exist in the list.
-
- * generic/tclExecute.c (TclExecuteByteCode): optimized case for
- the empty string in ==/!= comparisons
-
-2000-03-27 Eric Melski <ericm@scriptics.com>
-
- * unix/tclUnixChan.c: Added (off_t) type casts in lseek() call
- [Bug: 4409].
-
- * unix/tclLoadAout.c:
- * unix/tclUnixPipe.c: Added (off_t) type casts in lseek() calls
- [Bug: 4410].
-
-2000-03-22 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Fixed a bug where string query data
- that was bigger than queryblocksize would get duplicate characters
- at block boundaries.
-
-2000-03-22 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Fixed bug 4463, where we were getting
- a stack trace if we tried to publish a project to a good host but
- a port where there was no server listening. It turned out the
- problem was a stray fileevent that needed to be cleared. Also,
- fixed a bug where http::code could stack trace if called on a bad
- token (one which didn't represent a successful geturl) by adding
- an http element to the state array in geturl.
-
-2000-03-21 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Modified some tests that were not robust with
- respect to the time zone in which they were run and were thus
- failing.
-
- * doc/clock.n: Clarified meaning of -gmt with respect to -base
- when used with [clock scan] (-gmt does not affect the
- interpretation of -base).
-
-2000-03-19 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: geturl used to throw an exception when
- the connection failed; I accidentally returned a token with the
- error info, breaking backwards compatibility. I changed it back
- to throwing an exception, but unsetting the state array first
- (thus still eliminating the original memory leak problem).
-
-2000-03-19 Sandeep Tamhankar <sandeep@scriptics.com>
-
- * library/http2.1/http.tcl: Added -querychannel option and altered
- some of Brent's modifications to allow asynchronous posts (via
- -command). Also modified -queryprogress so that it calls the
- query callback as <callback> <token> <total size> <current size>
- to be consistent with -progress. Added -queryblocksize option
- with default 8192 bytes for post blocksize. Fixed a bunch of
- potential memory leaks for the case when geturl receives bad args
- or can't open a socket, etc. Overall, the package really rocks
- now.
-
- * doc/http.n: Added -queryblocksize, -querychannel, and
- -queryprogress. Also, changed the description of -blocksize,
- which states that the -progress callback will be called for each
- block, to now qualify that with an "if -progress is specified".
-
- * tests/http.test: Added a querychannel test for synchronous and
- asynchronous posts, altered the queryprogress test such that the
- callback conforms to the -progress format. Also, had to use the
- -queryblocksize option to do the post 16K at a time to match
- Brent's expected results (and to test that -queryblocksize works).
-
-2000-03-15 Brent Welch <welch@scriptics.com>
-
- * library/http2.1/http.tcl: Added -queryprogress callback to
- http::geturl and also changed it so that writing the post data
- is event driven if the queryprogress callback or a timeout is given.
- This allows a timeout to occur when writing lots of post data.
- The queryprogress callback is called after each block of query
- data is posted. It has the same signature as the -progress callback.
-
-2000-03-06 Eric Melski <ericm@scriptics.com>
-
- * library/package.tcl: Applied patch from Bug: 2570; rather than
- setting geometry of slave interp to 0x0 when Tk was loaded, it now
- does "wm withdraw .". Both remove the main window from the
- display, but the former caused some internal structures to get
- initialized to zero, which caused crashes with some extensions.
-
-2000-03-02 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/package.tcl (tclPkgUnknown): extended to allow
- recognizes changes in the auto_path while sourcing in other
- pkgIndex.tcl files
-
- * doc/FindExec.3: fixed doc for declaration of Tcl_FindExecutable
- [Bug: 4275]
-
- * generic/tclFileName.c (Tcl_TranslateFileName): Applied patch
- from Newman to significantly speedup file split/join on Windows
- (replaces regexp with custom parser). [Bug: 2867]
-
- * win/README.binary: change mailing lists from @consortium.org
- to @scriptics.com [Bug: 4173]
-
-2000-02-28 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Added test for ISO bases < 100000
-
- * generic/tclDate.c: (generated on Solaris)
- * generic/tclGetDate.y: Changed condition for deciding if a number
- is an ISO 8601 base from number >= 100000 to numberOfDigits >= 6.
- Previously it would fail to recognize 000000 as an ISO base.
-
-2000-02-14 Eric Melski <ericm@scriptics.com>
-
- * unix/Makefile.in: Added rpm target to generate Tcl binary RPM.
-
- * unix/tcl.spec: RPM specification file for a Tcl binary RPM for
- Linux.
-
-2000-02-10 Jeff Hobbs <hobbs@scriptics.com>
-
- 8.3.0 RELEASE
-
- * changes: updated for 8.3.0 release
-
- * doc/load.n: added notes about dll load errors on Windows
-
- * unix/README:
- * unix/Makefile.in (dist): removed porting.notes and porting.old
- from distribution and CVS. The information was very outdated. Now
- refer to http://dev.scriptics.com/services/support/platforms.html
-
- * tests/unixInit.test: fixed japanese LANG encoding test [Bug: 3549]
-
- * unix/configure.in:
- * unix/tcl.m4: correct CFLAG_WARNING setting,
- fixed gcc config for AIX,
- added -export-dynamic to LDFLAGS for FreeBSD-3+ [Bug: 2998]
-
- * win/tclWinLoad.c (TclpLoadFile): improved error message for load
- failures, could perhaps be even more intelligent.
-
-2000-02-09 Jim Ingham <jingham@cygnus.com>
-
- * mac/tclMacSock.c: Don't panic when you get an error closing an async
- socket. This doesn't seem to hurt anything, and we return the error so
- the caller can do the right thing.
-
- New Files:
- * mac/MW_TclHeader.h:
- * mac/MW_TclTestHeader.h:
- * mac/MW_TclTestHeader.pch:
- * mac/MW_TclAppleScriptHeader.h: More convenient to use .h prefix files
- in the preference panels...
-
- The above are curtesy of Daniel Steffen (steffen@math.mq.edu.au)
-
-2000-02-08 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Added tests for "next monthname" constructs.
- * generic/tclDate.c:
- * generic/tclGetDate.y (Message): Added a grammar rule for "next
- monthname" so that we can handle "next january" and similar
- constructs (bug #4146).
-
-2000-02-08 Jeff Hobbs <hobbs@scriptics.com>
-
- * README:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * win/configure.in:
- * win/README:
- * win/README.binary:
- * generic/tcl.h (TCL_RELEASE_SERIAL): Moved to 8.3.0 patchlevel
-
- * doc/library.n:
- * library/auto.tcl: fixed crufty puts code and docs [Bug: 4122]
-
- * library/tcltest1.0/tcltest.tcl: correctly protected searchDirectory
- list to allow dirnames with spaces
-
- * unix/tcl.m4: changed all -fpic to -fPIC
-
- * generic/tclDecls.h:
- * generic/tcl.decls: change Tcl_GetOpenFile to use decl of 'int
- forWriting' instead of 'int write' to avoid shadowing [Bug: 4121]
-
- * tests/httpold.test: changed test script to source in the httpd
- server procs from httpd instead of having its own set.
-
- * tests/httpd: improved query support in test httpd to handle fix
- in http.tcl. [Bug: 4089 change 2000-02-01]
-
- * unix/README: fixed notes about --enable-shared and add note
- about --disable-shared.
-
-2000-02-07 Eric Melski <ericm@scriptics.com>
-
- * tests/package.test:
- * library/tclIndex:
- * library/package.tcl: Renamed ::package namespace to ::pkg.
-
-2000-02-03 Eric Melski <ericm@scriptics.com>
-
- * doc/Package.n:
- * doc/packagens.n: Renamed Package.n -> packagens.n because Windows
- can't deal with case-sensitive names.
-
-2000-02-02 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/regexp.test: added tests for -all and -inline switches
- * doc/regexp.n: added docs for -all and -inline switches
- * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): added extra comments for
- new -all and -inline switches to regexp command
-
-2000-02-01 Eric Melski <ericm@scriptics.com>
-
- * library/init.tcl: Applied patch from rfe 1734 regarding
- auto_load errors not setting error message and errorInfo properly.
-
-2000-02-01 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/Makefile.in (install-*): reduced verbosity of install
-
- * generic/tclFileName.c (Tcl_JoinPath): improved support for special
- QNX node id prefixes in pathnames [Bug: 4053]
-
- * library/http1.0/http.tcl:
- * library/http2.1/http.tcl: The query data POSTed was newline
- terminated when it shouldn't be altered [Bug: 4089]
-
-2000-01-31 Eric Melski <ericm@scriptics.com>
-
- * tests/package.test:
- * library/tclIndex:
- * library/package.tcl: Added ::package namespace and
- ::package::create function.
-
- * library/init.tcl: Fixed problem with auto_load and determining
- if commands were loaded.
-
- * library/auto.tcl: "Fixed" issues with $ in files to be auto indexed.
-
- * doc/Package.n: New man page for package::create function.
-
- * doc/pkgMkIndex.n: Added additional information.
-
- * doc/library.n: Added additional qualification regarding auto_mkindex.
-
-2000-01-28 Eric Melski <ericm@scriptics.com>
-
- * tests/pkg/magicchar2.tcl:
- * tests/autoMkindex.test: Test for auto loader fix (bug #2480).
-
- * library/init.tcl: auto_load was using [info commands $name] to
- determine if a given command was available; if the command name
- had * or [] it, this would fail because info commands uses
- glob-style matching. This is fixed. (Bug #2480).
-
- * tests/pkg/spacename.tcl:
- * tests/pkgMkIndex.test: Tests for fix for bug #2360.
-
- * library/package.tcl: Fixed to extract only the first element of
- the list returned by auto_qualify (bug #2360).
-
- * tests/pkg/magicchar.tcl:
- * tests/autoMkindex.test: Test for fix for bug #2611.
-
- * library/auto.tcl: Fixed the regular expression that performs $
- escaping before sourcing a file to index. It was erroneously
- adding \ escapes even to $'s that were already escaped,
- effectively "un-escaping" those $'s. (bug #2611).
-
-2000-01-27 Eric Melski <ericm@scriptics.com>
-
- * tests/autoMkindex.test:
- * library/auto.tcl: Applied patch (with slight modification) from
- bug #2701: auto_mkIndex uses platform dependent file paths.
- Added test for fix.
-
-2000-01-27 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Changed NormalizePath to
- normalizePath and exported it as a public proc. This proc
- creates an absolute path given the name of the variable containing
- the path to modify. The path is modified in place.
- * library/tcltest1.0/pkgIndex.tcl: Added normalizePath.
- * tests/all.tcl: Changed code to use normalizePath.
-
-2000-01-27 Eric Melski <ericm@scriptics.com>
-
- * tests/pkg/samename.tcl: test file for bug #1983
-
- * tests/pkgMkIndex.test:
- * doc/pkgMkIndex.n:
- * library/package.tcl: Per rfe #4097, optimized creation of direct
- load packages to bypass computing the list of commands added by
- the new package. Also made direct loading the default, and added
- a -lazy option.
- Fixed bug #1983, dealing with pkg_mkIndex incorrectly handling
- situations with two procs by the same name but in different
- namespaces (ie, foo::baz and bar::baz).
-
-2000-01-26 Eric Melski <ericm@scriptics.com>
-
- * generic/tclNamesp.c: Undid fix for #956, which broke backwards
- compatibility.
-
- * doc/variable.n:
- * doc/trace.n:
- * doc/namespace.n:
- * doc/info.n: Added further information about differences between
- "namespace which" and "info exists".
-
- * doc/SetErrno.3: Added descriptions of ErrnoId() and ErrnoMsg()
- functions.
-
-2000-01-25 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tcl.m4: modified EXTRA_CFLAGS to add -DHAVE_TZSET for
- OSF1-V* and ULTRIX-4.* when not using gcc. Also added higher min
- stack size for OSF1-V* when building with threads. [Bug: 4063]
-
- * generic/tclClock.c (FormatClock): inlined resultPtr, as it
- conflicted with var creation for HAVE_TZSET #def [Bug: 4063]
-
- * generic/tclCmdIL.c (Tcl_LsortObjCmd): fixed potential leak
- when calling lsort -command with bad command [Bug: 4067]
-
- * generic/tclFileName.c (Tcl_JoinPath): added support for special
- QNX node id prefixes in pathnames [Bug: 4053]
-
- * doc/ListObj.3: clarified Tcl_ListObjGetElements docs [Bug: 4080]
-
- * doc/glob.n: clarified Mac path separator determination docs.
-
- * win/makefile.vc: added some support for building helpfile on Windows
-
-2000-01-23 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/init.tcl (auto_execok): added 'start' to list of
- recognized built-in commands for COMSPEC on NT. [Bug: 2858]
-
- * unix/tclUnixPort.h: moved include of <utime.h> lower since some
- systems (UTS) require sys/types.h to be included first [Bug: 4031]
-
- * unix/tclUnixChan.c (CreateSocketAddress): changed comparison
- with -1 to 0xFFFFFFFF, to ensure 32 bit comparison even on 64 bit
- systems. [Bug: 3878]
-
- * generic/tclFileName.c: improved guessing of path separator
- for the Mac. (Darley)
-
- * generic/tclInt.h:
- * generic/tcl.decls: moved Tcl_ProcObjCmd to stubs table [Bug: 3827]
- and removed 'register' from stub definition of
- Tcl_AppendUnicodeToObj [Bug: 4038]
-
-2000-01-21 Eric Melski <ericm@scriptics.com>
-
- * unix/mkLinks:
- * doc/GetHostName.3: Man page for Tcl_GetHostName (bug #1817).
-
- * doc/lreplace.n: Corrected man page with respect to treatment of
- empty lists, and "prettied up" the page. (bug #1705).
-
-2000-01-20 Eric Melski <ericm@scriptics.com>
-
- * tests/namespace.test: Added test for undefined variables with
- namespace which (bug #956).
-
- * generic/tclNamesp.c: Added check for undefined variables in
- NamespaceWhichCmd (bug #956).
-
- * tests/var.test: Added tests for corrected variable behavior
- (bug #981).
-
- * doc/upvar.n: Expanded explanation of upvar behavior with respect to
- variable traces. (bugs 3917 1433 2110).
-
- * generic/tclVar.c: Changed behavior of variable command when name
- refers to an element in an array (ie, "variable foo(x)") to always
- return an error, regardless of existance of that element in the
- array (now behavior is consistant with docs too) (bug #981).
-
-2000-01-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclCmdIL.c (InfoBodyCmd): made [info body] return a
- string if the body has been bytecompiled.
- * generic/tclBasic.c (Tcl_EvalObjEx): added pedantic check for
- originating proc body of bytecompiled code, #def'd out as the
- change for [info body] should make it unnecessary
-
- * unix/tclUnixNotfy.c (Tcl_InitNotifier): added cast for tsdPtr
-
- * tests/set.test: added test for complex array elem name compiling
- * generic/tclCompCmds.c (TclCompileSetCmd): Fixed parsing of array
- elements during compiling, and slightly optimised same [Bug: 3889]
-
- * doc/tclvars.n: added definitions for tcl_(non)wordchars
-
- * doc/vwait.n: added notes about requirement for vwait var being
- globally scoped [Bug: 3329]
-
- * library/word.tcl: changed tcl_(non)wordchars settings to use
- new unicode regexp char class escapes instead of char sequences
-
-2000-01-14 Eric Melski <ericm@scriptics.com>
-
- * tests/var.test: Added a test for the array multiple delete
- protection in Tcl_UnsetVar2.
-
- * generic/tclVar.c: Added protection in Tcl_UnsetVar2 against
- attempts to multiply delete arrays when unsetting them (bug
- #3453). This could happen if there was an unset trace on an array
- element and the trace proc made a global or upvar link to the
- array, and then the array was unset at the global level. See the
- bug reference for more information.
-
- * unix/tclUnixTime.c: New clock format format.
-
- * compat/strftime.c: New clock format format.
-
- * generic/tclGetDate.y: New clock scan format.
-
-2000-01-13 Jeff Hobbs <hobbs@scriptics.com>
-
- * changes: updated changes file to reflect 8.3b2 mods
-
- * README:
- * generic/tcl.h:
- * tools/tcl.wse.in:
- * unix/configure.in:
- * unix/tcl.m4:
- * win/README.binary:
- * win/configure.in: updated to patchlevel 8.3b2
-
- * generic/regexec.c: added var initialization to prevent compiler
- warning
-
-2000-01-13 Eric Melski <ericm@scriptics.com>
-
- * tests/cmdIL.test: Added tests for lsort -dictionary with
- characters that occur between Z and a in ASCII.
-
- * generic/tclCmdIL.c: Modified DictionaryCompare function (used by
- lsort -dictionary) to do upper/lower case equivalency before doing
- character comparisons, instead of after. This fixes bug #1357, in
- which lsort -dictionary [list ` AA c CC] and lsort -dictionary
- [list AA c ` CC] gave different (and both wrong) results.
-
-2000-01-12 Eric Melski <ericm@scriptics.com>
-
- * tests/clock.test: Added tests for "next <day-of-week>" and
- "<day-of-week>"
- Added tests for "monday 1 week ago", etc, from RFE #3671.
-
- * doc/tests/clock.test: Added numerous tests for clock scan.
-
- * doc/generic/tclGetDate.y: Fixed some shift/reduce conflicts in
- clock grammar.
-
- * doc/doc/clock.n: Added documentation for new supported clock
- scan formats and additional explanation of daylight savings time
- correction algorithm.
-
-2000-01-12 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/file.n:
- * tests/unixFCmd.test:
- * unix/tclUnixFCmd.c: added support for symbolic permissions
- setting in SetPermissionsAttribute (file attr $file -perm ...)
- [Bug: 3970]
-
- * generic/tclClock.c: fixed support for 64bit handling of clock
- values [Bug: 1806]
-
- * generic/tclThreadTest.c: upped a buffer size to hold double
-
- * tests/info.test:
- * generic/tclCmdIL.c: fixed 'info procs ::namesp::*' behavior (Dejong)
-
- * generic/tclNamesp.c: made imported commands also import their
- compile proc [Bug: 2100]
-
- * tests/expr.test:
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/tcl.m4: recognize strtod bug on Tru64 v5.0 [Bug: 3378]
- and added tests to prevent unnecessary chmod +x in sources while
- installing, as well as more intelligent setsockopt/gethostbyname
- checks [Bug: 3366, 3389]
-
- * unix/tclUnixThrd.c: added compile time support (through use of
- the TCL_THREAD_STACK_MIN define) for increasing the default stack
- size for a thread. [Bug: 3797, 1966]
-
-2000-01-11 Eric Melski <ericm@scriptics.com>
-
- * generic/tclGetDate.y: Added comments for the Convert function.
- Added a fix for daylight savings time handling for relative time
- spans of days, weeks or fortnights. (bug 3441, 3868).
-
- * generic/tclDate.c: Fixed compiler warning issues.
-
-2000-01-10 Jeff Hobbs <hobbs@scriptics.com>
-
- * compat/waitpid.c: use pid_t type instead of int [Bug: 3999]
-
- * tests/utf.test: fixed test that allowed \8 as octal value
- * generic/tclUtf.c: changed Tcl_UtfBackslash to not allow
- non-octal digits (8,9) in \ooo substs. [Bug: 3975]
-
- * generic/tcl.h: noted need to change win/tcl.m4 and
- tools/tclSplash.bmp for minor version changes
-
- * library/http2.1/http.tcl: trim value for $state(meta) key
-
- * unix/tclUnixFile.c: fixed signature style on functions
-
- * unix/Makefile.in: made sure tcl.m4 would be installed with dist
-
- * unix/tcl.m4: added ELF support for NetBSD [Bug: 3959]
-
-2000-01-10 Eric Melski <ericm@scriptics.com>
-
- * generic/tclGetDate.y: Added rules for ISO 8601 formats (BUG #847):
- CCYY-MM-DD
- CCYYMMDD
- YY-MM-DD
- YYMMDD
- CCYYMMDDTHHMMSS
- CCYYMMDD HHMMSS
- CCYYMMDDTHH:MM:SS
- Fixed "clock scan <number>" to scan the number as an hour for the
- current day, rather than a minute after 00:00 for the current day
- (bug #2732).
-
-
-2000-01-07 Eric Melski <ericm@scriptics.com>
-
- * generic/tclClock.c: Changed switch in Tcl_ClockObjCmd to use
- enumerated values instead of constants. (ie, COMMAND_SCAN instead
- of 3).
-
-1999-12-22 Jeff Hobbs <hobbs@scriptics.com>
-
- * changes: updated changes file
- * tools/tclSplash.bmp: updated to show 8.3
-
-1999-12-21 Jeff Hobbs <hobbs@scriptics.com>
-
- * README:
- * generic/tcl.h:
- * mac/README:
- * unix/configure.in:
- * tools/tcl.wse.in:
- * win/README.binary:
- * win/configure.in: updated to patch level 8.3b1
-
- * unix/Makefile.in: added -srcdir=... for 'make html'
-
- * doc/Hash.3: fixed reference to ckfree [Bug: 3912]
- * doc/RegExp.3: fixed calling params for Tcl_RegExecFromObj
- * doc/open.n: fixed minor formatting errors
- * doc/string.n: fixed minor formatting errors
-
- * doc/lsort.n: added -unique docs
- * tests/cmdIL.test:
- * generic/tclCmdIL.c: added -unique option to lsort
-
- * generic/tclThreadTest.c: changed thread ids to longs [Bug: 3902]
-
- * mac/tclMacOSA.c: fixed applescript for I18N [Bug: 3644]
-
- * win/mkd.bat:
- * win/rmd.bat: removed necessity of tag.txt [Bug: 3874]
-
- * win/tclWinThrd.c: changed CreateThread to _beginthreadex and
- ExitThread to _endthreadex
-
-1999-12-12 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/glob.n:
- * tests/fileName.test:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclEncoding.c:
- * generic/tclFileName.c:
- * mac/tclMacFile.c:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c: enhanced the glob command with the new options
- -types -path -directory and -join. Deprecated TclpMatchFiles with
- TclpMatchFilesTypes, extended TclGlob and TclDoGlob and added
- GlobTypeData structure. [Bug: 2363]
-
-1999-12-10 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/var.test:
- * generic/tclCompile.c: fixed problem where setting to {} array
- would intermittently not work. (Fontaine) [Bug: 3339]
-
- * generic/tclCmdMZ.c:
- * generic/tclExecute.c: optimized INST_TRY_CVT_TO_NUMERIC to
- recognize boolean objects. (Spjuth) [Bug: 2815]
-
- * tests/info.test:
- * tests/parseOld.test:
- * generic/tclCmdAH.c:
- * generic/tclProc.c: changed Tcl_UplevelObjCmd (uplevel) and
- Tcl_EvalObjCmd (eval) to use TCL_EVAL_DIRECT in the single arg
- case as well, to take advantage of potential pure list input
- optimization. This means that it won't get byte compiled though,
- which should be acceptable.
- * generic/tclBasic.c: made Tcl_EvalObjEx pure list object aware in
- the TCL_EVAL_DIRECT case for efficiency.
- * generic/tclUtil.c: made Tcl_ConcatObj pure list object aware,
- and return a list object in that case [Bug: 2098 2257]
-
- * generic/tclMain.c: changed Tcl_Main to not constantly reuse the
- commandPtr object (interactive case) as it could be shared. (Fellows)
-
- * unix/configure.in:
- * unix/tcl.m4:
- * unix/tclUnixPipe.c: removed checking for compatible vfork
- function and use of the vfork function. Modern VM systems rarely
- suffer any performance degradation when fork is used, and it
- solves multiple problems with vfork. Users that still want vfork
- can add -Dfork=vfork to the compile flags. [Bug: 942 2228 1312]
-
-1999-12-09 Jeff Hobbs <hobbs@scriptics.com>
-
- * win/aclocal.m4: made it just include tcl.m4
-
- * doc/exec.n:
- * doc/open.n:
- * win/tclWin32Dll.c:
- * win/tclWinChan.c:
- * win/tclWinFCmd.c:
- * win/tclWinInit.c:
- * win/tclWinPipe.c:
- * win/tclWinSock.c: removed all code that supported Win32s. It
- was no longer officially supported, and likely didn't work anyway.
- * win/makefile.vc: removed 16 bit stuff, cleaned up.
-
- * win/tcl16.rc:
- * win/tclWin16.c:
- * win/winDumpExts.c: these files have been removed from the
- source tree (no longer necessary to build)
-
-1999-12-07 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/io.test: removed 'knownBug' tests that were for
- unsupported0, which is now fcopy (that already has tests)
-
- * mac/tclMacPort.h: added utime.h include
-
- * generic/tclDate.c:
- * unix/Makefile.in: fixed make gendate to swap const with CONST
- so it uses the Tcl defined CONST type [Bug: 3521]
-
- * generic/tclIO.c: removed panic that could occur in FlushChannel
- when a "blocking" channel would receive EAGAIN, instead treating
- it the same as non-blocking. [Bug: 3773]
-
- * generic/tclUtil.c: fixed Tcl_ScanCountedElement to not step
- beyond the end of the counted string [Bug: 3336]
-
-1999-12-03 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/load.n: added note about NT's buggy handling of './' with
- LoadLibrary
-
- * library/http2.1/http.tcl: fixed error handling in http::Event
- [Bug: 3752]
-
- * tests/env.test: removed knownBug limitation from working test
- * tests/all.tcl: ensured that ::tcltest::testsDirectory would be
- set to an absolute path
-
- * tests/expr-old.test:
- * tests/parseExpr.test:
- * tests/string.test:
- * generic/tclGet.c:
- * generic/tclInt.h:
- * generic/tclObj.c:
- * generic/tclParseExpr.c:
- * generic/tclUtil.c:
- * generic/tclExecute.c: added TclCheckBadOctal routine to enhance
- error message checking for when users use invalid octal numbers
- (like 08), as well as replumbed the Expr*Funcs with a new
- VerifyExprObjType to simplify type handling. [Bug: 2467]
-
- * tests/expr.test:
- * generic/tclCompile.c: fixed 'bad code length' error for
- 'expr + {[incr]}' case, with new test case [Bug: 3736]
- and seg fault on 'expr + {[error]}' (different cause) that
- was caused by a correct optimization that didn't correctly
- track how it was modifying the source string in the opt.
- The optimization was removed, which means that:
- expr 1 + {[string length abc]}
- will be not be compiled inline as before, but this should be
- written:
- expr {1 + [string length abc]}
- which will be compiled inline for speed. This prevents
- expr 1 + {[mindless error]}
- from seg faulting, and only affects optimizations for
- degenerate cases [Bug: 3737]
-
-1999-12-01 Scott Redman <redman@scriptics.com>
-
- * generic/tcl.decls :
- * generic/tclMain.c :
- * unix/tclAppInit.c:
- * win/tclAppInit.c: Added two new internal functions,
- TclSetStartupScriptFileName() and TclGetStartupScriptFileName()
- and added hooks into the main() code for supporting TclPro and
- other "big" shells more easily without requiring a copy of the
- main() code.
-
- * generic/tclEncoding.c:
- * generic/tclEvent.c: Moved encoding-related startup code from
- tclEvent.c into the more appropriate tclEncoding.c.
-
-1999-11-30 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIO.c: fix from Kupries for Tcl_UnstackChannel that
- correctly handles resetting translation and encoding.
-
- * generic/tclLoad.c: #def'd out the unloading of DLLs at finalize
- time for Unix in TclFinalizeLoad. [Bug: 2560 3373] Should be
- parametrized to allow for user to specify unload or not.
-
- * win/tclWinTime.c: fixed handling of %Z on NT for time zones
- that don't have DST.
-
-1999-11-29 Jeff Hobbs <hobbs@scriptics.com>
-
- * library/dde1.1/pkgIndex.tcl:
- * library/reg1.0/pkgIndex.tcl: added supported for debugged
- versions of the libraries
-
- * unix/tclUnixPipe.c: fixed PipeBlockModeProc to properly set
- isNonBlocking flag on pipe. [Bug: 1356 710]
- removed spurious fcntl call from PipeBlockModeProc
-
- * tests/scan.test:
- * generic/tclScan.c: fixed scan where %[..] didn't match anything
- and added test case [Bug: 3700]
-
-1999-11-24 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/open.n:
- * win/tclWinSerial.c: adopted patch from Schroedter to handle
- fconfigure $sock -lasterror on Windows. [RFE: 3368]
-
- * generic/tclCmdIL.c: made SORTMODE_INTEGER work with Longs
- [Bug: 3652]
-
-1999-11-23 Scott Stanton <stanton@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Fixed bug where tcltest output
- went to stdout instead of the specified output file in some
- cases.
-
-1999-11-19 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclProc.c: backed out change from 1999-11-18 as it
- could affect return string from upvar as well.
-
- * tools/tcl.wse.in: added tcltest1.0 library to distribution list
-
- * doc/http.n:
- * library/http2.1/http.tcl:
- * library/http2.1/pkgIndex.tcl: updated http package to 2.2
-
-1999-11-18 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tcl.m4: added defined for _THREAD_SAFE in --enable-threads
- case; added check for pthread_mutex_init in libc; in AIX case,
- with --enable-threads ${CC}_r is used; fixed flags when using gcc
- on SCO
-
- * generic/tclProc.c: corrected error reporting for default case
- at the global level for uplevel command.
-
- * generic/tclIOSock.c: changed int to size_t type for len
- in TclSockMinimumBuffers.
-
- * generic/tclCkalloc.c: fixed Tcl_DbCkfree to return a value
- on NULL input. [Bug: 3400]
-
- * generic/tclStringObj.c: fixed support for passing in negative
- length to Tcl_SetUnicodeObj, et al handling routines. [Bug: 3380]
-
- * doc/scan.n:
- * tests/scan.test:
- * generic/tclScan.c: finished support for inline scan by
- supporting XPG identifiers.
-
- * doc/http.n:
- * library/http2.1/http.tcl: added register and unregister
- commands to http:: package (better support for tls/SSL),
- as well as -type argument to http::geturl. [RFE: 2617]
-
- * generic/tclBasic.c: removed extra decr of numLevels in
- Tcl_EvalObjEx that could cause seg fault. (mjansen@wendt.de)
-
- * generic/tclEvent.c: fixed possible lack of MutexUnlock in
- Tcl_DeleteExitHandler [Bug: 3545]
-
- * unix/tcl.m4: Added better pthreads library check and inclusion
- of _THREAD_SAFE in --enable-threads case
- Added support for gcc config on SCO
-
- * doc/glob.n: added note about ..../ glob behavior on Win9*
- * doc/tcltest.n: fixed minor example errors [Bug: 3551]
-
-1999-11-17 Brent Welch <welch@scriptics.com>
- * library/http2.1/http.tcl: Correctly fixed the -timeout
- problem mentioned in the 10-29 change. Also added error
- handling for failed writes on the socket during the protocol.
-
-1999-11-09 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/open.n: corrected docs for 'a' open mode.
-
- * generic/tclIOUtil.c: changed Tcl_Alloc to ckalloc
-
- * generic/tclInt.h:
- * generic/tclObj.c: rolled back changes from 1999-10-29
- Purify noted new leaks with that code
-
- * generic/tclParse.c: added code in Tcl_ParseBraces to test for
- possible unbalanced open brace in a comment
-
- * library/init.tcl: removed the installed binary directory from
- the auto_path variable
-
- * tools/tcl.wse.in: updated to 8.3a1, fixed install of twind.tcl
- and koi8-r.enc files
-
- * unix/tcl.m4: added recognition of pthreads library for AIX
-
-1999-10-29 Brent Welch <welch@scriptics.com>
- * generic/tclInt.h: Modified the TclNewObj and TclDecrRefCount
- in two ways. First, in the case of TCL_THREADS, we do not use
- the special Tcl_Obj allocator because that is a source of
- lock contention. Second, general code cleanup to eliminate
- duplicated code. In particular, TclDecrRefCount now uses
- TclFreeObj instead of duplicating that code, so it is now
- identical to Tcl_DecrRefCount.
-
- * generic/tclObj.c: Changed Tcl_NewObj so it uses the
- TclNewObj macro instead of duplicating the code. Adjusted
- TclFreeObj so it understands the TCL_THREADS case described
- above.
-
- * library/http2.1/http.tcl: Fixed a bug in the handling of
- the state(status) variable when the -timeout flag is specified.
- Previously it was possible to leave the status undefined
- instead of empty, which caused errors in http::status
-
-1999-10-28 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/aclocal.m4: made it just include tcl.m4
-
- * library/tcltest1.0/tcltest.tcl: updated makeFile to return
- full pathname of file created
-
- * generic/tclStringObj.c: fixed Tcl_AppendStringsToObjVA so it only
- iterates once over the va_list (avoiding a memcpy of it,
- which is not portable).
-
- * generic/tclEnv.c: fixed possible ABR error in environ array
-
- * tests/scan.test:
- * generic/tclScan.c: added support for use of inline scan,
- XPG3 currently not included
-
- * tests/incr.test:
- * tests/set.test:
- * generic/tclCompCmds.c: fixed improper bytecode handling of
- 'eval {set array($unknownvar) 5}' (also for incr) [Bug: 3184]
-
- * win/tclWinTest.c: added testvolumetype command, as atime is
- completely ignored for Windows FAT file systems
- * win/tclWinPort.h: added sys/utime.h to includes
- * unix/tclUnixPort.h: added utime.h to includes
- * doc/file.n:
- * tests/cmdAH.test:
- * generic/tclCmdAH.c: added time arguments to atime and mtime
- file command methods (support 'touch' functionality)
-
-1999-10-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/tclUnixNotfy.c: fixed event/io threading problems by
- making triggerPipe non-blocking [Bug: 2792]
-
- * library/tcltest1.0/tcltest.tcl:
- * generic/tclThreadTest.c: fixed mem leaks in threads
-
- * generic/tclResult.c: fixed Tcl_AppendResultVA so it only
- iterates once over the va_list (avoiding a memcpy of it,
- which is not portable).
-
- * generic/regc_color.c: fixed mem leak and assertion, from HS
-
- * generic/tclCompile.c: removed savedChar trick that appeared to
- be causing a segv when the literal table was released
-
- * tests/string.test:
- * generic/tclCmdMZ.c: fixed [string index] to return ByteArrayObj
- when indexing into one (test case string-5.16) [Bug: 2871]
-
- * library/http2.1/http.tcl: protected gets with catch [Bug: 2665]
-
-1999-10-19 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * doc/tcltest.n:
- * library/tcltest1.0/tcltest.tcl: Removed the extra return at the
- end of the tcltest.tcl file, added version information about tcl.
-
- Applied patches sent in by Andreas Kupries to add helper procs for
- debug output, add 3 new flags (-testsdir, -load, -loadfile), and
- internally refactors common code for dealing with paths into
- separate procedures. [Bug: 2838, 2842]
-
- Merged code from core-8-2-1 branch that changes the checks for the
- value of tcl_interactive to also incorporate a check for the
- existence of the variable.
-
- * tests/autoMkindex.test:
- * tests/pkgMkIndex.test: Explicitly cd to
- ::tcltest::testsDirectory at the beginning of the test run
-
- * tests/basic.test: Use version information defined in tcltest
- instead of hardcoded version number
-
- * tests/socket.test: package require tcltest before attempting to
- use variable defined in tcltest namespace
-
- * tests/unixInit.test:
- * tests/unixNotfy.test: Added explicit exits needed to avoid
- problems when the tests area run in wish.
-
-1999-10-12 Jim Ingham <jingham@scriptics.com>
-
- * mac/tclMacLoad.c: Stupid bug - we converted the filename to
- external, but used the unconverted version.
- * mac/tclMacFCmd.c: Fix a merge error in the bug fix for [Bug: 2869]
-
-1999-10-12 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/regc_color.c:
- * generic/regc_cvec.c:
- * generic/regc_lex.c:
- * generic/regc_locale.c:
- * generic/regcomp.c:
- * generic/regcustom.h:
- * generic/regerrs.h:
- * generic/regex.h:
- * generic/regexec.c:
- * generic/regguts.h:
- * generic/tclRegexp.c:
- * generic/tclTest.c:
- * tests/reg.test: updated to Henry Spencer's new regexp engine
- (mid-Sept 99). Should greatly reduce stack space reqs.
-
- * library/tcltest1.0/pkgIndex.tcl: fixed procs in pkgIndex.tcl file
-
- * generic/tclEnv.c: fixed mem leak with putenv and DStrings
- * doc/Encoding.3: corrected docs
- * tests/basic.test: updated test cases for 8.3
- * tests/encoding.test: fixed test case that change system
- encoding to a double-byte one (this causes a bogus mem read
- error for purify)
- * unix/Makefile.in: purify has to use -best-effort to instrument
- * unix/tclAppInit.c: identified potential mem leak when compiling
- tcltest (not critical)
- * unix/tclUnixPipe.c: fixed mem leak in TclpCreateProcess when
- doing alloc between vfork and execvp.
- * unix/tclUnixTest.c: fixed mem leak in findexecutable test command
-
-1999-10-05 Jeff Hobbs <hobbs@scriptics.com>
-
- * {win,mac,unix,tools,}/README:
- * win/README.binary:
- * win/makefile.vc:
- * {win,unix}/configure.in:
- * generic/tcl.h:
- * library/init.tcl: updated to 8.3a1 from 8.2.0.
-
- * library/http2.1/http.tcl: fixed possible use of global c var.
-
- * win/tclWinReg.c: fixed registry command to properly 'get'
- HKEY_PERFORMANCE_DATA root key data. Needs more work.
-
- * generic/tclNamesp.c:
- * generic/tclVar.c:
- * generic/tclCmdIL.c: fixed comment typos
-
- * mac/tclMacFCmd.c: fixed filename stuff to support UTF-8 [Bug: 2869]
-
- * win/tclWinSerial.c: changed SerialSetOptionProc to return
- TCL_OK by default. (patch from Rolf Schroedter)
-
-1999-09-21 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Applied patches sent in by
- Andreas Kupries to fix typos in comments and ::tcltest::grep,
- fix hook redefinition problems, and change "string compare" to
- "string equal." [Bug: 2836, 2837, 2839, 2840]
-
-1999-09-20 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/env.test:
- * unix/Makefile.in: added support for AIX LIBPATH env var [Bug: 2793]
- removed second definition of INCLUDE_INSTALL_DIR (the one that
- referenced @includedir@) [Bug: 2805]
- * unix/dltest/Makefile.in: added -lc to LIBS [Bug: 2794]
-
-1999-09-16 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/timer.test: changed after delay in timer test 6.29 from
- 1 to 10. [Bug: 2796]
-
- * tests/pkg.test:
- * generic/tclPkg.c: fixed package version check to disallow 1.2..3
- [Bug: 2539]
-
- * unix/Makefile.in: fixed gendate target - this never worked
- since RCS was intro'd.
- * generic/tclGetDate.y: updated to reflect previous changes
- to tclDate.c (leap year calc) and added CEST and UCT time zone
- recognition. Fixed 4 missing UCHAR() casts. [Bug: 2717, 954,
- 1245, 1249]
-
- * generic/tclCkalloc.c: changed Tcl_DumpActiveMemory to really
- dump to stderr and close it [Bug: 725] and changed Tcl_Ckrealloc
- and Tcl_Ckfree to not bomb when NULL was passed in [Bug: 1719]
- and changed Tcl_Alloc, et al to not panic when a alloc request
- for zero came through and NULL was returned (valid on AIX, Tru64)
- [Bug: 2795, etc]
-
- * tests/clock.test:
- * doc/clock.n:
- * generic/tclClock.c: added -milliseconds switch to clock clicks
- to guarantee that the return value of clicks is in the millisecs
- granularity [Bug: 2682, 1332]
-
-1999-09-15 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclIOCmd.c: fixed potential core dump in conjunction
- with stacked channels with result obj manipulation in
- Tcl_ReadChars [Bug: 2623]
-
- * tests/format.test:
- * generic/tclCmdAH.c: fixed translation of %0#s in format [Bug: 2605]
-
- * doc/msgcat.n: fixed \\ bug in example [Bug: 2548]
-
- * unix/tcl.m4:
- * unix/aclocal.m4: added fix for FreeBSD-[1-2] recognition
- [Bug: 2070] and fix for IRIX SHLIB_LB_LIBS. [Bug: 2610]
-
- * doc/array.n:
- * tests/var.test:
- * tests/set.test:
- * generic/tclVar.c: added an array unset operation, with docs
- and tests. Variation of [Bug: 1775]. Added fix in TclArraySet
- to check when trying to set in a non-existent namespace. [Bug: 2613]
-
-1999-09-14 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/linsert.test:
- * doc/linsert.n:
- * generic/tclCmdIL.c: fixed end-int interpretation of linsert
- to correctly calculate value for end, added test and docs [Bug: 2693]
-
- * doc/regexp.n:
- * doc/regsub.n:
- * tests/regexp.test:
- * generic/tclCmdMZ.c: add -start switch to regexp and regsub
- with docs and tests
-
- * doc/switch.n: added proper use of comments to example.
- * generic/tclCmdMZ.c: changed switch to complain when an error
- occurs that seems to be due to a misplaced comment.
-
- * generic/tclCmdMZ.c: fixed illegal ref for \[0-9] substitutions
- in regsub [Bug: 2723]
-
- * generic/tclCmdMZ.c: changed [string equal] to return an Int
- type object (was a Boolean)
-
-1999-09-01 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl: Process command-line arguments
- only ::tcltest doesn't have a child namespace (requires that
- command-line args are processed in that namespace)
-
-1999-09-01 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclParseExpr.c: changed '"' to '\"' to make FreeBSD
- happy [Bug: 2625]
- * generic/tclProc.c: moved static buf to better location and
- changed static msg that would overflow in ProcessProcResultCode
- [Bug: 2483] and added Tcl_DStringFree to Tcl_ProcObjCmd.
- Also reworked size of static buffers.
- * tests/stringObj.test: added test 9.11
- * generic/tclStringObj.c: changed Tcl_AppendObjToObj to
- properly handle the 1-byte dest and mixed src case where
- both had had Unicode string len checks made on them. [Bug: 2678]
- * unix/aclocal.m4:
- * unix/tcl.m4: adjusted fix from 8-21 to add -bnoentry to the
- AIX-* case and readjusted the range
-
-1999-08-31 Jennifer Hom <jenn@scriptics.com>
-
- * library/tcltest1.0/tcltest.tcl:
- * doc/tcltest.n:
- * tests/README: Modified testConstraints variable so that it isn't
- unset every time ::tcltest::initConstraints is called and cleaned up
- documentation in the README file and the man page.
-
-1999-08-27 Jennifer Hom <jenn@scriptics.com>
-
- * tests/env.test:
- * tests/exec.test:
- * tests/io.test:
- * tests/event.test:
- * tests/tcltest.test: Added 'exit' calls to scripts that the tests
- themselves write, and removed accidental checkin of knownBugThreaded
- constraints for Solaris and Linux.
-
- * library/tcltest1.0/tcltest.tcl: Modified tcltest so that
- variables are only initialized to their default values if they did
- not previously exist.
-
-1999-08-26 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl: Added a -args flag that sets a
- variable named ::tcltest::parameters based on whatever's being
- sent in as the argument to the -args flag.
-
-1999-08-23 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test: Added additional tests for -tmpdir, marked
- all tests that use exec as unixOrPc.
-
- * tests/encoding.test:
- * tests/interp.test:
- * tests/macFCmd.test:
- * tests/parseOld.test:
- * tests/regexp.test: Applied patches from Jim Ingham to add
- encoding to a Mac only interp test, change an error message in
- macFCmd.tet, put a comment in parseOld.test, fix tests using the
- testencoding path command, and put unixOrPc constraints on tests
- that use exec.
-
-1999-08-21 Jeff Hobbs <hobbs@scriptics.com>
-
- * unix/aclocal.m4: Changed AIX-4.[2-9] check to AIX-4.[1-9]
- [Bug: 1909]
-
-1999-08-20 Jeff Hobbs <hobbs@scriptics.com>
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
-Thu Apr 20 17:01:19 2000 Andrew Cagney <cagney@b1.cygnus.com>
-=======
- * generic/tclPosixStr.c: fixed typo [Bug: 2592]
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
- From Alexandre Oliva <aoliva@cygnus.com>
- * generic/tclPosixStr.c (Tcl_SignalId, Tcl_SignalMsg): Do not
- issue SIGPWR case if it's the same as SIGLOST.
-=======
- * doc/*: fixed various nroff bugs in man pages [Bug: 2503 2588]
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
-2000-01-26 DJ Delorie <dj@cygnus.com>
-=======
-1999-08-19 Jeff Hobbs <hobbs@scriptics.com>
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
- * win/tclWin32Dll.c (DllMain): Use standard _imp__reent_data,
- not old-style __imp_reent_data
- * generic/tclEnv.c (environ): ditto for _imp____cygwin_environ
-
-2000-01-17 Drew Moseley <dmoseley@cygnus.com>
-=======
- * win/README.binary: fixed version info and some typos [Bug: 2561]
-
- * doc/interp.n: updated list of commands available in a safe
- interpreter [Bug: 2526]
-
- * generic/tclIO.c: changed Tcl_GetChannelNames* to use style guide
- headers (pleases HP cc)
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
- * cygwin/configure.in: Fixed bug in setting of shell variable which
- caused it to be interpreted as a subcommand rather than a variable.
- * cygwin/configure: Regenerated.
-=======
-1999-08-18 Jeff Hobbs <hobbs@scriptics.com>
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
-1999-11-09 DJ Delorie <dj@cygnus.com>
-=======
- * doc/Eval.3: fixed doc on input args [Bug: 2114]
-
- * doc/OpenFileChnl.3:
- * doc/file.n:
- * tests/cmdAH.test:
- * tclIO.c:
- * tclCmdAH.c: added "file channels ?pattern?" tcl command, with
- associated Tcl_GetChannelNames and Tcl_GetChannelNamesEx public
- C APIs (added to tcl.decls as well), with docs and tests.
-
- * tests/expr.test:
- * generic/tclCompile.c: add TCL_TOKEN_VARIABLE to the part types
- that cause differed compilation for exprs, to correct the expr
- double-evaluation problem for vars. Added test cases.
- Related to [Bug: 732]
-
- * unix/Makefile.in: changed the dependency structure so that
- install-* is dependent on * (ie - install-binaries is dependent
- on binaries).
-
- * library/auto.tcl:
- * library/init.tcl:
- * library/ldAout.tcl:
- * library/package.tcl:
- * library/safe.tcl:
- * library/word.tcl:
- * library/http2.1/http.tcl:
- * library/msgcat1.0/msgcat.tcl: updated libraries to better
- Tcl style guide (no more string comparisons with == or !=, spacing
- changes).
-
-1999-08-05 Jim Ingham <jingham@cygnus.com>
-
- * mac/tclMacProjects.sea.hqx: Rearrange the projects so that the build
- directory is separate from the sources. Much more convenient!
-
-1999-08-13 Scott Redman <redman@scriptics.com>
-
- * /: 8.2.0 tagged for final release
-
-1999-08-12 Scott Stanton <stanton@scriptics.com>
-
- * win/Makefile.in: Added COMPILE_DEBUG_FLAGS macro to make it
- easier to turn on compiler tracing.
-
- * tests/parse.test:
- * generic/tclParse.c: Fixed bug in Tcl_EvalEx where the termOffset
- was not being updated in cases where the evaluation returned a non
- TCL_OK error code. [Bug: 2535]
-
-1999-08-12 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSerial.c: Applied patch from Petteri Kettunen to
- remove compiler warning.
-
-1999-08-10 Scott Redman <redman@scriptics.com>
-
- * generic/tclAlloc.c:
- * generic/tclCmdIL.c:
- * generic/tclIO.c:
- * generic/tclThread.c:
- * win/tclWinThrd.c:
- * unix/tclUnixThrd.c: Fixed Brent's changes so that they work on
- Windows (and he fixed the bug in the Unix thread implementation).
-
-1999-08-09 Brent Welch <welch@scriptics.com>
-
- * generic/tcl.decls:
- * generic/tclAlloc.c:
- * generic/tclCkalloc.c:
- * generic/tclCmdIL.c:
- * generic/tclDecls.h:
- * generic/tclIO.c:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclVar.c:
- * mac/tclMacThrd.c:
- * unix/tclUnixThrd.c:
- * win/tclWinThrd.c: Added use of Tcl_GetAllocMutex to tclAlloc.c
- and tclCkalloc.c so they can be linked against alternate thread
- packages. Added Tcl_GetChannelNames to tclIO.c. Added
- TclVarTraceExists hook so "info exists" triggers read traces
- exactly like it did in Tcl 7.6. Stubs table changes to reflect new
- internal and external APIs.
-
-1999-08-09 Jeff Hobbs <hobbs@scriptics.com>
-
- * tests/string.test: added largest_int proc to adapt for >32 bit
- machines and int overflow testing.
- * tests/tcltest.test: fixed minor error in 8.2 result (from dgp)
-
- * doc/Object.3: clarified Tcl_DecrRefCount docs [Bug: 1952]
- * doc/array.n: clarified array pattern docs [Bug: 1330]
- * doc/clock.n: fixed clock docs [Bug: 693]
- * doc/lindex.n: clarified to account for new end-int behavior.
- * doc/string.n: fixed formatting errors [Bug: 2188 2189]
- * doc/tclvars.n: fixed doc error [Bug: 2042]
- * library/init.tcl: fixed path handling in auto_execok (it could
- miss including the normal path on some Windows machines) [Bug: 1276]
-
-1999-08-05 Jeff Hobbs <hobbs@scriptics.com>
-
- * doc/tclvars.n: Made it clear that tcl_pkgPath was not set
- for Windows (already mentioned in init.tcl) [Bug: 2455]
- * generic/tclLiteral.c: fixed reference to bytes that might
- not be null terminated (using objPtr->bytes, which is) [Bug: 2496]
- * library/http2.1/http.tcl: Made use of "i" in init section use
- local var and start at 0 (was 1). [Bug: 2502]
-
-1999-08-04 Scott Stanton <stanton@scriptics.com>
-
- * tests/reg.test: Added test for REG_EXPECT bug fixed by Henry's
- patch.
-
- * generic/regc_nfa.c:
- * generic/regcomp.c:
- * generic/rege_dfa.c:
- * generic/regexec.c:
- * generic/regguts.h: Applied patches supplied by Henry Spencer to
- greatly enhance the performance of certain classes of regular
- expressions. [Bug: 2440, 2447]
-
-1999-08-03 Scott Redman <redman@scriptics.com>
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
- * cygwin/*: redone with automake for cygwin-specific info (from cgf)
- to support cross-host builds
-=======
- * win/tclWinInt.h: Remove function declarations in header that was
- moved to tclInt.decls file in previous changes.
->>>>>>> 1.1.1.5
-
-<<<<<<< ChangeLog
-1999-10-26 DJ Delorie <dj@cygnus.com>
-
- * cygwin/*: new; replicate unix/* setup (other modules look
- in unix/* for "local" builds; we don't want them to find the
- cygwin version)
- * unix/Makefile.in: undo
- * configure.in: For cygwin, build win and cygwin
- * Makefile.in: re-enable multi-dir support
-
-Tue Oct 26 13:16:09 1999 Christopher Faylor <cgf@cygnus.com>
-
- * win/configure.in: Add better detection of cross-compilation
- environment.
- * win/configure: Regenerate.
-=======
-1999-08-02 Scott Redman <redman@scriptics.com>
-
- * unix/configure.in:
- * win/configure.in: Change beta level to b2.
-
- * generic/tcl.h:
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclInt.h:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclRegexp.h:
- * generic/tclStubInit.c: Move some exported public and internal
- functions to the stub tables. Removed functions that are in the
- stub tables (from this and previous changes) from the original
- header files.
-
-1999-08-01 Scott Redman <redman@scriptics.com>
-
- * win/tclWinSock.c: Added comment block to SocketThread()
- function. Added code to avoid calling TerminateThread(), but
- instead to send a message to the socket event window to tell it to
- terminate its thread.
-
-1999-07-30 Jennifer Hom <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl: Exit with non-zero status if
- there were problems with the way the test suite was started
- (e.g. wrong # arguments).
-
-1999-07-30 Jeff Hobbs <hobbs@scriptics.com>
-
- * generic/tclInt.decls: added declaractions necessary for the
- Tcl test code to work wth stubs [Bug: 2445]
-
-1999-07-30 <redman@scriptics.com>
-
- * win/tclWinPipe.c:
- * win/Makefile.in: Fixing launching of 16-bit apps on Win9x from
- wish. The command line was primed with tclpip82.dll, but it was
- ignored. Fixed that, then fixed the gmake makefile to build
- tclpip82.dll as an executable.
-
- * win/tclWinSock.c: Applied small patch to get thread-specific
- data after initializing the socket driver.
-
- * unix/tclUnixThrd.c: Applied patch to fix threads on Irix 6.5.
- Patch from James Dennett. [Bug: 2450]
-
- * tests/info.test: Enable test for tclParse.c change (info
- complete).
-
-1999-07-30 <hobbs@scriptics.com>
-
- * tclIO.c: added fix for Kupries' trf patch [Bug: 2386]
-
- * tclParse.c: fixed bug in info complete regarding nested square
- brackets [Bug: 2382, 2466]
-
-1999-07-29 <redman@scriptics.com>
-
- * win/tclWinChan.c: Allow tcl to open CON and NUL, even for std
- channels. Checking for bad/unusable std channels was moved to Tk
- since its only purpose was to check whether to use the Tk Console
- Window for the std channels. [Bug: 2393 2392 2209 2458]
-
- * unix/mkLinks.tcl: Applied patch to avoid linking pack.n to
- pack-old.n. Patch from Don Porter. [Bug: 2469]
-
- * doc/Encoding.n: Applied patch to fix typo in .SH NAME line.
- Patch from Don Porter. [Bug: 2451]
-
- * win/tclWinSock.c: Free Win32 Event handles when destroying
- the socket helper thread.
-
-1999-07-28 <jenn@scriptics.com>
-
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl: Fixed the condition under which
- ::tcltest::PrintError had an infinite loop problem and added a
- test case for it. Added an optional argument to
- ::tcltest::getMatchingFiles telling it where to search for test
- files.
-
-1999-07-27 <redman@scriptics.com>
-
- * tools/tclSplash.bmp: Updated Windows installer bitmap
- to ready Tcl/Tk Version 8.2.
-
-1999-07-26 <redman@scriptics.com>
-
- * tests/tcltest.test: Need to close the new core file, there
- seems to be a hang in threaded WinNT if the file isn't closed.
- Open issue, need to fix that hang.
-
- * tests/httpold.test: Add time delay in response from Http server
- so that test cases can properly detect timeout conditions with
- threads enabled on multi-CPU WinNT.
-
- * tests/winFCmd.test: Test case winFcmd-1.33 was looking for
- c:\windows, which may not exist. Instead, create a new directory
- on c:\ and use it for the test.
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSock.c: Fix terminating helper threads by holding any
- mutexes from the primary thread while waiting for the helper
- thread to terminate. Without these changes, the test suite hangs
- on WinNT with 2 CPUs and threads enabled. Open issue, seems to be
- a sporadic hang on dual CPU systems still (very rare).
-
-1999-07-26 Jennifer Hom <jenn@scriptics.com>
+ * library/tcltest/tcltest.tcl: restored writeability testing of
+ -tmpdir, augmented by a special exception for the deafault value.
- * tests/tcltest.test:
- * library/tcltest1.0/tcltest.tcl:
- * doc/tcltest.n: Cleaned up code in ::tcltest::PrintError, revised
- documentation, and added tests for the tcltest package.
-
-1999-07-23 <redman@scriptics.com>
-
- * tests/info.test:
- * generic/tclParse.c: Removed patch for info command, breaks test
- cases on Unix. Patch was bad and needs to be redone
- properly. [Bug: 2382]
-
-1999-07-22 <redman@scriptics.com>
-
- * Changed version to 8.2b2.
-
- * win/tclWinSock.c: Fixed hang with threads enabled, fixed
- semaphores with threads disabled.
-
- * win/safe.test: Fixed safe-6.3 with threads enabled.
-
- * win/Makefile.in: Fixed calling of tcltest to fix safe.test
- failures due to path TCL_LIBRARY path.
-
- * win/tclWinPort.h: Block out include of sys/*.h in order to
- build extensions with MetroWerks compiler for Win32. [Bug: 2385]
-
- * generic/tclCmdMZ.c:
- * generic/tclIO.c: Fix ANSI-style prototypes based on patch from
- Ulrich Ring. [Bug: 2391]
-
- * unix/Makefile.in: Need to make install-sh executable before
- calling (with chmod +x). [Bug: 2413]
-
- * tests/var.test:
- * generic/tclVar.c: Fixed bug that caused a seg. fault when using
- "array set a(b) {}", which is a bad array name anyway. Now the
- "array set" command will return an error in this case. Added test
- case and fixed existing test. [Bug: 2427]
-
-1999-07-21 <redman@scriptics.com>
-
- * tests/info.test:
- * generic/tclParse.c: Applied patch to fix "info complete"
- for the string {[a [b]}. Patch from Peter Spjuth. [Bug: 2382]
-
- * doc/Utf.3:
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclUtf.c: Changed function declarations in
- non-platform-specific public APIs to use "unsigned long" instead of
- "size_t", which may not be defined on certain compilers (rather
- than include sys/types.h, which may not exist).
-
- * unix/Makefile.in: Added the Windows configure script to the
- distribution file list, already shipping configure.in and the .m4
- files, but needed the configure script itself.
-
- * win/makefile.vc: Changed version number of DDE package in VC++
- makefile to use 1.1 instead of 1.0.
-
- * doc/open.n: Added documentation of \\.\comX notation for opening
- serial ports on Windows (alternative to comX:).
-
- * tests/ioCmd.test:
- * doc/open.n:
- * win/tclWinSerial.c: Applied patch from Rolf Schroedter to add
- -pollinterval option to fconfigure to modify the maxblocktime used
- in the fileevent polling. Added documentation and fixed the test
- case as well.
-
- * win/tclWinSock.c: Modified 8.1.0 version of the Win32 socket
- driver to move the handling of the socket event window in a
- separate thread. It also turned out that Win95 & Win98 were, in
- some cases, getting multiple FD_ACCEPTs but only handling one.
- Added a count for the FD_ACCEPT to take care of this. Tested on
- NT4 SP3, NT4 SP4, Win95, and Win98.
- [Bug: 2178 2256 2259 2329 2323 2355]
-
-1999-07-21 <jpeek@scriptics.com>
-
- * README: Small tweaks to clean up typos and wording.
-
-1999-07-20 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * generic/tclInitScript.h:
- * unix/tclUnixInit.c: merged code with 8.0.5. We now use an
- intermediate global tcl var "tclDefaultLibrary" to keep the
- "tcl_library" var from being set by the default value in the
- Makefile. Also fixed a bug in which caused the value of
- TCL_LIBRARY env var to be ignored.
- * unix/tclWinInit.c: just updated some comments.
-
-1999-07-19 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * library/http2.1/http.tcl: updated -useragent text to say version
- 2.1.
+2002-07-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1999-07-16 <redman@scriptics.com>
+ * doc/concat.n: Documented the *real* behaviour of [concat]!
- * generic/tcl.decls:
- * generic/tclDecls.h:
- * generic/tclStubInit.c: Add Tcl_SetNotifier to stub table.
- [Bug: 2364]
-
- * unix/aclocal.m4:
- * unix/tcl.m4: Add check for Alpha/Linux to correct the IEEE
- floating flag to the compiler, should be -mieee. Patch from Don
- Porter.
-
- * tools/tcl.hpj.in: Change version number of .cnt file referenced
- in .HPJ file.
-
-1999-07-15 <redman@scriptics.com>
-
- * tools/tcl.wse.in: Fixed naming of target files for Windows.
-
-1999-07-14 <jpeek@scriptics.com>
-
- * doc/re_syntax.n: Deleted sentence as suggested by Scott S.
-
-1999-07-12 <jpeek@scriptics.com>
-
- * doc/re_syntax.n: Removed two notes to myself (oops), cleaned
- up wording, fixed changebars, made two examples easier to read.
-
-1999-07-11 <redman@scriptics.com>
-
- * win/makefile.vc: Since the makefile.vc should continue to work
- while we're working out bugs/issues in the new TEA-style
- autoconf/configure/gmake build mechanism for Windows, the version
- numbers of the Tcl libraries need to remain in sync. Modified the
- version numbers in the makefile to reflect the change to 8.2b1.
-
-1999-07-09 <redman@scriptics.com>
-
- * win/configure.in: Eval DLLSUFFIX, LIBSUFFIX, and EXESUFFIX in
- the configure script so that substitutions get expanded before
- being placed in the Makefile. The "d" portion for debug libraries
- and DLLs was not being set properly.
-
-1999-07-08 <stanton@scriptics.com>
-
- * tests/string.test:
- * generic/tclCmdMZ.c: Fixed bug in string range bounds checking
- code.
+2002-06-30 Don Porter <dgp@users.sourceforge.net>
-1999-07-08 Jennifer Hom <jenn@scriptics.com>
+ * doc/tcltest.n: more work in progress updating tcltest docs.
- * doc/tcltest.n:
- * library/tcltest1.0/tcltest.tcl: Removed -asidefromdir and
- -relateddir flags, removed unused ::tcltest::dotests proc, cleaned
- up implementation of core file checking, and fixed the code that
- checks for 1-letter flag abbreviations.
-
-1999-07-08 <stanton@scriptics.com>
-
- * win/Makefile.in: Added tcltest target so runtest works
- properly. Added missing names to the clean/distclean targets.
-
- * tests/reg.test:
- * generic/rege_dfa.c: Applied fix supplied by Henry Spencer for
- bug in DFA state caching under lookahead conditions. [Bug: 2318]
-
-1999-07-07 <stanton@scriptics.com>
-
- * doc/fconfigure.n: Clarified default buffering behavior for the
- standard channels. [Bug: 2335]
-
-1999-07-06 <redman@scriptics.com>
+ * tests/README: Updated the instructions on running and
+ * tests/cmdMZ.test: adding to the test suite. Also updated
+ * tests/encoding.test: several tests, mostly to correctly create
+ * tests/fCmd.test: and destroy any temporary files in the
+ * tests/info.test: [temporaryDirectory] of tcltest.
+ * tests/interp.test:
- * win/tclWinSerial.c: New implementation of serial port driver
- from Rolf Shroedter (Rolf.Schroedter@dlr.de) that allows more than
- one byte to be read from the port. Implemented using polling
- instead of threads, there is a max. 10ms latency between checking the
- port for file events. [Bug: 1980 2217]
+ * library/tcltest/tcltest.tcl: Stopped checking for writeability
+ of -tmpdir value because no default directory can be guaranteed to
+ be writeable.
-1999-07-06 <welch@scriptics.com>
+ * tests/autoMkindex.tcl: removed.
+ * tests/pkg/samename.tcl: removed.
+ * tests/pkg/magicchar.tcl: removed.
+ * tests/pkg/magicchar2.tcl: removed.
+ * tests/autoMkindex.test: Updated auto_mkIndex tests to use
+ [makeFile] and [removeFile] so tests are done in [temporaryDirecotry]
+ where write access is guaranteed.
- * library/http2.0/http.tcl: Fixed the -timeout option so it
- handles timeouts that occur during connection attempts to
- hosts that are down (the only case that really matters!)
+ * library/tcltest/tcltest.tcl: Fixed [makeFile] and [viewFile] to
+ * tests/cmdAH.test: accurately reflect a file's contents.
+ * tests/event.test: Updated tests that depended on buggy
+ * tests/http.test: behavior. Also added warning messages
+ * tests/io.test: to "-debug 1" operations to debug test
+ * tests/iogt.test: calls to (make|remove)(File|Directory).
-1999-07-03 <welch@scriptics.com>
+ * unix/mkLinks: `make mklinks` on 6-27 commits.
- * doc/ChnlStack.3:
- * generic/tcl.decls:
- * generic/tclIO.c: Added a new variant of the "Trf patch"
- from Andreas Kupres that adds new C APIs Tcl_StackChannel,
- Tcl_UnstackChannel, and Tcl_GetStackedChannel.
+2002-06-28 Miguel Sofer <msofer@users.sourceforge.net>
-1999-07-03 <welch@scriptics.com>
+ * generic/tclCompile.h: modified the macro TclEmitPush to not
+ call its first argument repeatedly or pass it to other macros,
+ [Bug 575194] reported by Peter Spjuth.
- * generic/tclNotify.c:
- * unix/tclUnixNotfy.c:
- * unix/tclXtTest.c:
- * unix/tclXtNotify.c:
- * win/tclWinNotify.c:
- * mac/tclMacNotify.c: Added Tcl_SetNotifier and the associated
- hook points in the notifiers to be able to replace the notifier
- calls at runtime The Xt notifier and test program use this hook.
+2002-06-28 Don Porter <dgp@users.sourceforge.net>
-1999-07-03 <welch@scriptics.com>
+ * docs/tcltest.n: Doc revisions in progress.
+ * library/tcltest/tcltest.tcl: Corrected -testdir default value.
+ Was not reliable, and disagreed with docs! Thanks to Hemang Lavana.
+ [Bug 575150]
- * generic/tclParse.c: Changed parsing of variable names to
- allow empty array names. Now "$(foo)" is a variable reference!
- Previous you had to use something like $::(foo), which is slower.
- This change is requested by Jean-Luc Fontaine for his STOOOP
- package.
+2002-06-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1999-07-01 <redman@scriptics.com>
+ * unix/tclUnixThrd.c: Renamed the Tcl_Platform* #defines to
+ * unix/tclUnixPipe.c: TclOS* because they are only used
+ * unix/tclUnixFile.c: internally. Also stopped double-#def
+ * unix/tclUnixFCmd.c: of TclOSlstat [Bug #566099, post-rename]
+ * unix/tclUnixChan.c:
+ * unix/tclUnixPort.h:
- * generic/tclCmdAH.c:
- * generic/tclFCmd.c: Call TclStat instead of TclpStat in order to
- allow Tcl_Stat hooks to work properly.
+ * doc/string.n: Improved documentation for [string last] along
+ lines described in Bug #574799 so it indicates that the supplied
+ index marks the end of the search space.
-1999-06-29 Jennifer Hom <jenn@scriptics.com>
+2002-06-27 Don Porter <dgp@users.sourceforge.net>
- * library/tcltest1.0/pkgIndex.tcl:
- * library/tcltest1.0/tcltest.tcl:
+ * doc/dde.n: Work in progress updating the documentation
+ * doc/http.n: of the packages that come bundled with
+ * doc/msgcat.n: the Tcl source distribution, notably tcltest.
+ * doc/registry.n:
* doc/tcltest.n:
- * tests/all.tcl: Added -preservecore, -limitconstraints, -help,
- -file, -notfile, -relateddir and -asidefromdir flags to the
- tcltest package along with exported proc
- ::tcltest::getMatchingFiles. The documentation was modified to
- match and all.tcl was modified to use the new functionality
- instead of implementing -file itself.
-
-1999-06-28 <redman@scriptics.com>
-
- * generic/tclIndexObj.c:
- * doc/GetIndex.3:
- * tests/binary.test:
- * tests/winDde.test: Applied patch from Peter Hardie (with
- changes) to fix problem with Tcl_GetIndexFromObj() when the key
- being passed is the empty string. It used to match "" and return
- TCL_OK, but it should have returned TCL_ERROR instead. Added test
- case to "binary" and "dde" commands to check the behavior. Added
- documentation note as well.
-
-1999-06-26 <redman@scriptics.com>
-
- * win/tclWinDde.c: Applied patch from Peter Hardie to add poke
- command to dde. Also rev'd version of dde package to 1.1.
- [Bug: 1738]
-
-1999-06-25 Jennifer Hom <jenn@scriptics.com>
-
- * unix/Makefile.in:
- * win/Makefile.in:
- * library/tcltest1.0/pkgIndex.tcl:
- * library/tcltest1.0/tcltest.tcl:
- * library/tcltest1.0: Added initial implementation of the Tcl test
- harness package. This package was based on the defs.tcl file that
- was part of the tests directory. Reversed the way that tests were
- evaluated to fix a problem with false passes.
-
- * doc/tcltest.n: Added documentation for the tcltest package.
-
- * tests/README:
- * tests/defs.tcl:
- * tests/all.tcl: Modified all test files (tests/*.test) and
- all.tcl to use the new tcltest package and removed references to
- the defs.tcl file. Modified the README file to point to the man
- page for tcltest.
-
-1999-06-25 <stanton@scriptics.com>
-
- * tests/reg.test:
- * generic/regexec.c: Fixed bugs in non-greedy quantifiers.
-
-1999-06-23 <jpeek@scriptics.com>
-
- * doc/re_syntax.n:
- * doc/switch.n:
- * doc/lsearch.n:
- * doc/RegExp.3:
- * doc/regexp.n:
- * doc/regsub.n: Moved information about syntax of 8.1 regular
- expressions from regexp(n) manpage into new re_syntax(n) page.
- Added pointers from other manpages to new re_syntax(n) page.
-
-1999-06-23 <stanton@scriptics.com>
-
- * unix/Makefile.in: Changed install-doc to install-man.
-
- * tools/uniParse.tcl:
- * tools/uniClass.tcl:
- * tools/README:
- * tests/string.test:
- * generic/regc_locale.c:
- * generic/tclUniData.c:
- * generic/tclUtf.c:
- * doc/string.n: Updated Unicode character tables to reflect latest
- Unicode 2.1 data. Also rationalized "regexp" and "string is"
- definitions of character classes.
-
-1999-06-21 <stanton@scriptics.com>
-
- * unix/tclUnixThrd.c (TclpThreadCreate): Fixed memory leak where
- thread attributes were not being released. [Bug: 2254]
-
-1999-06-17 <stanton@scriptics.com>
-
- * tests/regexp.test:
- * generic/tclCmdMZ.c:
- * generic/tclCmdIL.c: Changed to use new regexp interfaces. Added
- -expanded, -line, -linestop, and -lineanchor switches to regsub.
-
- * doc/RegExp.3: Documented the new regexp interfaces and
- the compile/execute flags.
-
- * generic/tclTest.c:
- * generic/tclRegexp.h:
- * generic/tclRegexp.c:
- * generic/tcl.h:
- * generic/tcl.decls: Renamed Tcl_RegExpMatchObj to
- Tcl_RegExpExecObj and added a new Tcl_RegExpMatchObj that is
- equivalent to Tcl_RegExpMatch. Added public macros for the regexp
- compile/execute flags. Changed to store either an object pointer
- or a string pointer in the TclRegexp structure. Changed to avoid
- adding a reference to the object or copying the string.
-
- * generic/regcomp.c: lint
-
- * tests/reg.test:
- * generic/regex.h:
- * generic/regc_lex.c: Added REG_BOSONLY flag to allow Expect to
- iterate through a string an only find matches that start at the
- current position within the string.
-
-1999-06-16 <wart@scriptics.com>
-
- * unix/configure.in:
- * unix/Makefile.in:
- * unix/tcl.m4:
- * unix/aclocal.m4: Numerous build changes to make Tcl conform to the
- proposed TEA spec
-
-1999-06-16 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * generic/tclVar.c (Tcl_VariableObjCmd): fixed premature increment
- in loop that was causing out-of-bounds reads on array "varName".
-
-1999-06-16 <stanton@scriptics.com>
-
- * tests/execute.test:
- * generic/tclExecute.c (TclExecuteByteCode): Fixed crash caused by
- a bug in INST_LOAD_SCALAR1 where the scalar index was read as
- a signed 1 byte value instead of unsigned. [Bug: 2243]
-
-1999-06-14 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * doc/StringObj.3
- * test/stringObj.test
- * unix/Makefile.in
- * win/Makefile.in
- * win/makefile.vc
- * generic/tclStringObj.c:
- Merged String and Unicode object types. Added new functions to
- the puplic API: Tcl_NewUnicodeObj, Tcl_SetUnicodeObj,
- Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange,
- Tcl_AppendUnicodeToObj.
-
-1999-06-09 <stanton@scriptics.com>
-
- * generic/tclUnicodeObj.c: Lots of cleanup and simplification.
- Fixed several memory bugs. Added TclAppendUnicodeToObj.
-
- * generic/tclInt.h: Added declarations for various Unicode string
- functions.
-
- * generic/tclRegexp.c:
- * generic/tclCmdMZ.c: Changed to use new Unicode string interfaces
- for better performance.
-
- * generic/tclRegexp.h:
- * generic/tclRegexp.c:
- * generic/tcl.h:
- * generic/tcl.decls: Added Tcl_RegExpMatchObj and
- Tcl_RegExpGetInfo calls to access lower level regexp API. These
- features are needed by Expect. This is a preliminary
- implementation pending final review and cleanup.
-
- * generic/tclCmdMZ.c:
- * tests/string.test: Fixed bug where string map failed on null
- strings.
-
- * generic/regexec.c:
- * unix/tclUnixNotfy.c: lint
-
- * tools/genStubs.tcl: Changed to always write output in LF mode.
-
-1999-06-08 <stanton@scriptics.com>
-
- * win/tclWinSock.c: Rolled back to the 8.1.0 implementation
- because of serious problems with the new driver. Basically no
- incoming socket connections would be reported to a server port.
- The 8.1.1 code needs to be redesigned and fixed correctly.
-
-1999-06-07 Melissa Hirschl <hershey@matisse.scriptics.com>
-
- * tests/string.test:
- * generic/tclVar.c (Tcl_SetVar2Ex):
- * generic/tclStringObj.c (Tcl_AppendObjToObj):
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): optimized the string
- index, string length, string range, and append command in cases
- where the object's internal rep is a bytearray. Objects with
- other internal reps are converted to have the new unicode internal
- rep.
-
- * unix/Makefile.in:
- * win/Makefile.in:
- * win/Makefile.vc:
- * tests/unicode.test:
- * generic/tclInt.h:
- * generic/tclObj.c:
- * generic/tclUnicodeObj.c: added a new object type to store the
- unicode representation of a string.
-
- * generic/tclTestObj.c: added the objtype option to the testobj
- command. This option returns the name of the type of internal rep
- an object has.
-
-1999-06-04 <stanton@scriptics.com>
-
- * win/configure.in:
- * win/Makefile.in: Windows build now handles static/dynamic
- debug/nodebug builds and supports the standard targets using
- Cygwin user tools plus GNU make and autoconf.
-
-1999-06-03 <stanton@scriptics.com>
-
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * tests/string.test: Fixed bug where string equal/compare -nocase
- reported wrong result on null strings. [Bug: 2138]
-
-1999-06-02 <stanton@scriptics.com>
-
- * generic/tclUtf.c (Tcl_UtfNcasecmp): Fixed incorrect computation
- of relative ordering. [Bug: 2135]
-
-1999-06-01 <stanton@scriptics.com>
-
- * unix/configure.in: Fixed various small configure.in patches
- submitted by Jan Nijtmans. [Bug: 2121]
-
- * tests/reg.test:
- * generic/regc_color.c:
- * generic/regc_cvec.c:
- * generic/regc_lex.c:
- * generic/regc_locale.c:
- * generic/regc_nfa.c:
- * generic/regcomp.c:
- * generic/regcustom.h:
- * generic/rege_dfa.c:
- * generic/regerror.c:
- * generic/regerrs.h:
- * generic/regex.h:
- * generic/regexec.c:
- * generic/regfree.c:
- * generic/regfronts.c:
- * generic/regguts.h:
- * generic/tclCmdMZ.c:
- * generic/tclRegexp.c:
- * generic/tclRegexp.h:
- * generic/tclTest.c: Applied Henry Spencer's latest regexp patches
- that fix an infinite loop bug and add support for testing whether
- a string could match with additional input. [Bug: 2117]
-
-1999-05-28 <stanton@scriptics.com>
-
- * generic/tclObj.c: Changed to eliminate use of isupper/tolower in
- favor of the Unicode versions.
-
- * win/Makefile.in:
- * win/configure.in: Added preliminary TEA implementation.
-
- * win/tclWinDde.c: Fixed bug where dde calls were being passed an
- invalid dde handle because Initialize had not been called.
- [Bug: 2124]
-
-1999-05-26 <redman@scriptic.com>
-
- * generic/tclThreadTest.c: Fixed race condition in testthread
- code that showed up in the WinNT test suite intermittently.
-
- * win/tclWinSock.c: Fixed a hang in the WinNT socket driver, wake
- up the socket thread every 100ms to check for events on the
- sockets that did not wake up the thread (race condition).
-
-1999-05-24 <stanton@scriptics.com>
-
- * tools/genStubs.tcl: Changed to allow a list of platforms instead
- of just one at a time.
-
- * generic/tcl.decls:
- * generic/tclCmdMZ.c:
- * generic/tclDecls.h:
- * generic/tclInt.decls:
- * generic/tclIntDecls.h:
- * generic/tclPort.h:
- * generic/tclStubInit.c:
- * generic/tclStubLib.c: Various header file related changes and other
- lint to try to get the Mac builds working.
-
-1999-05-21 <redman@scriptics.com>
-
- * win/tclWinPipe.c: Fix bug when launching command.com on
- Win95/98. Need to wait for the procInfo.hProcess of the process that
- was created, not the hProcess of the current process. [Bug: 2105]
-
-1999-05-20 <redman@scriptics.com>
-
- * library/init.tcl: Add the directory where the executable is, and
- the ../lib directory relative to that, to the auto_path variable.
-
-1999-05-19 <stanton@scriptics.com>
-
- Merged in various changes submitted by Jeff Hobbs:
-
- * generic/tcl.decls:
- * generic/tclUtf.c: Added Tcl_UniCharIs* functions for control,
- graph, print, and punct classes.
-
- * generic/tclUtil.c:
- * doc/StrMatch.3: Added Tcl_StringCaseMatch() implementation to
- support case-insensitive globbing.
-
- * doc/string.n:
- * unix/mkLinks:
- * tests/string.test:
- * generic/tclCmdMZ.c: Added additional character class tests,
- added -nocase switch to "string match", changed string first/last
- to use offsets.
-
-1999-05-19 <redman@scriptics.com>
-
- * generic/tcl.h: Add extern "C" block around entire header file for
- C++ compilers to fix linkage issues. Submitted by Don Porter and
- Paul Duffin.
-
- * generic/tclRegexp.c: Fix bug when the regexp cache is empty
- and an empty pattern is used in regexp ( such as {} or "" ).
-
-1999-05-18 <stanton@scriptics.com>
-
- * win/tclWinChan.c: Modified initialization code to avoid
- inherenting closed or invalid channels. If the standard input is
- anything other than a console, file, serial port, or pipe, then we
- fall back to the standard Tk window console.
-
-1999-05-14 <stanton@scriptics.com>
-
- * generic/tclCmdAH.c (Tcl_ForObjCmd): Fixed crash caused by
- failure to reset the result before evaluating the test
- expression.
-
-1999-05-14 <surles@scriptics.com>
-
- * generic/tclBasic.c (Tcl_CreateInterp): Added introspection
- variable for threaded interps. If the interp was compiled with
- threads enabled, the tcl_platform(threaded) variable will exist.
-
-1999-05-14 <redman@scriptics.com>
-
- * generic/tclDate.c: Applied patch to fix 100-year and 400-year
- boundaries in leap year code, from Isaac Hollander. [Bug: 2066]
-
-1999-05-13 <stanton@scriptics.com>
-
- * unix/Makefile.in:
- * unix/tclAppInit.c: Minor cleanup related to Xt notifier.
-
- * unix/tclUnixInit.c (TclpSetInitialEncodings): Tcl now looks for
- an encoding subfield in the LANG/LC_ALL variables in cases where
- the locale is not found in the locale table. Ensure that
- setlocale() is called at least once so X11 will initialize
- properly. Also, forces the LC_NUMERIC locale to be "C" so numeric
- processing in scripts is not affected by the current locale
- setting. [Bug: 1989]
-
- * generic/tclRegexp.c: Increased per-thread regexp cache to 30
- slots. This seems to be about the right number for larger
- applications like exmh. [Bug: 1063]
-
-1999-05-12 <stanton@scriptics.com>
-
- * doc/tclsh.1: Updated references to rc script names to accurately
- reflect the platform differences on Windows.
-
- * tests/regexp.test:
- * generic/tclInt.h:
- * generic/tclBasic.c:
- * generic/tclRegexp.h:
- * generic/tclRegexp.c: Replaced the per-interpreter regexp cache
- with a per-thread cache. Changed the Regexp object to take
- advantage of this extra cache. Added a reference count to the
- TclRegexp type so regexps can be shared by multiple objects.
- Removed the per-interp regexp cache from the interpreter. Now
- regexps can be used with no need for an interpreter. [Bug: 1063]
-
- * win/tclWinInit.c (TclpSetVariables): Avoid calling GetUserName
- if the value can be determined from the USERNAME environment
- variable. GetUserName is very slow.
-
-1999-05-07 <stanton@scriptics.com>
-
- * win/winDumpExts.c:
- * win/makefile.vc: Removed incorrect patch. [Bug: 1998]
-
- * generic/tcl.decls: Replaced const with CONST.
-
- * generic/tclResult.c (Tcl_AppendResultVA):
- * generic/tclStringObj.c (Tcl_AppendStringsToObjVA): Fixed to copy
- arglist using memcpy instead of assignment so it works properly on
- OS/390. [Bug: 1997]
-
- * generic/tclLoadNone.c: Updated to use current interfaces, added
- TclpUnloadFile. [Bug: 2003]
-
- * win/winDumpExts.c:
- * win/makefile.vc: Changed to emit library name in defs
- file. [Bug: 1998]
-
- * unix/configure.in: Added fix for OS/390. [Bug: 1976]
-
-1999-05-06 <stanton@scriptics.com>
-
- * tests/string.test:
- * generic/tclCmdMZ.c:
- * doc/string.n: Fixed bug in string equal/compare code when using
- -length option. Cleaned up docs a bit more.
-
- * tests/http.test: Unset "data" array before running tests to
- avoid failures due to previous tests.
-
- * doc/string.n:
- * tests/cmdIL.test:
- * tests/cmdMZ.test:
- * tests/error.test:
- * tests/ioCmd.test:
- * tests/lindex.test:
- * tests/linsert.test:
- * tests/lrange.test:
- * tests/lreplace.test:
- * tests/string.test:
- * tests/cmdIL.test:
- * generic/tclUtil.c:
- * generic/tclCmdMZ.c: Replaced "string icompare/iequal" with
- -nocase and -length switches to "string compare/equal". Added a
- -nocase option to "string map". Changed index syntax to allow
- integer or end?-integer? instead of a full expression. This is
- much simpler with safeTcl scripts since it avoids double
- substitution issues.
-
- * doc/Utf.3:
- * generic/tclStubInit.c:
- * generic/tclDecls.h:
- * generic/tclUtf.c:
- * generic/tcl.decls: Added Tcl_UtfNcmp and Tcl_UtfNcasecmp.
-
-1999-05-05 <stanton@scriptics.com>
-
- * win/makefile.vc: Added encoding directory to install-libraries
- target.
-
-1999-05-03 <stanton@scriptics.com>
- * doc/string.n:
- * tests/cmdMZ.test:
- * tests/string.test:
- * generic/tclCmdMZ.c (Tcl_StringObjCmd): Changed "string length"
- to avoid regenerating the string rep of a ByteArray object.
-
- * tests/cmdIL.test:
- * tests/cmdMZ.test:
- * tests/error.test:
- * tests/lindex.test:
- * tests/linsert.test:
- * tests/lrange.test:
- * tests/lreplace.test:
- * tests/string.test:
- * generic/tclCmdMZ.c (Tcl_StringObjCmd):
- * generic/tclUtil.c (TclGetIntForIndex): Applied Jeff Hobbs's
- string patch which includes the following changes [Bug: 1845]:
-
- - string compare now takes optional length arg (for strncmp
- behavior)
-
- - added string equal (just a few lines of code blended
- in with string compare)
-
- - added string icompare/iequal for case-insensitive comparisons
-
- - string index's index can now be ?end[+-]?expression
- I made this change in the private TclGetIntForIndex,
- which means that the list commands also benefit, as
- well as string range, et al.
-
- - added [string repeat string count]
- Repeats given string number of times
-
- - added string replace, string equiv to lreplace
- (quasi opposite of string range):
- string replace first last ?string?
- Example of use, replacing end of string with ...
- should the string be more than 16 chars long:
- string replace $string 16 end "..."
- This just returns the string len < 16, so it
- will only affect the long strings.
-
- - added optional first and last args to string to*
- This allows you to just affect certain regions of
- a string with the command (like just capping the
- first letter). I found the original totitle to
- be too draconian to be useful.
-
- - added [string map charMap string]
- where charMap is a {from to from to} list that equates to
- what one might get from [array get]. Each and
- can be multiple chars (or none at all). For Tcl/CGI users,
- this is a MAJOR speed booster.
-
- * generic/tclParse.c (Tcl_ParseCommand): Changed to avoid
- modifying eval'ed strings that are already null terminated.
- [Bug: 1793]
+ * library/tcltest/tcltest.tcl: Made sure that the TCLTEST_OPTIONS
+ environment variablle configures tcltest at package load time.
- * tests/binary.test:
- * generic/tclBinary.c (DupByteArrayInternalRep): Fixed bug where
- type was not being set in duplicated object. [Bug: 1975, 2047]
+2002-06-26 Vince Darley <vincentdarley@users.sourceforge.net>
-1999-04-30 <stanton@scriptics.com>
-
- * Changed version to 8.1.1.
+ * tests/fileSystem.test:
+ * generic/tclIOUtil.c: fix to handling of empty paths ""
+ which are not claimed by any filesystem (Bug #573758).
+ Ensure good error messages are given in all cases.
+ * tests/cmdAH.test:
+ * unix/tclUnixFCmd.c: fix to bug reported as part of
+ (Patch #566669). Thanks to Taguchi, Takeshi for the report.
-1999-04-30 <stanton@scriptics.com>
-
- * Merged changes from 8.1.0 branch:
-
- * generic/tclParse.c: Fixed memory leak in CommandComplete.
-
- * generic/tclPlatDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclIntDecls.h:
- * generic/tclDecls.h:
- * tools/genStubs.tcl: Added 'extern "C" {}' block around the stub
- table pointer declaration so the stub library can be used from
- C++. [Bug: 1934]
-
- * Lots of documentation and other release engineering fixes.
-
-1999-04-28 <stanton@scriptics.com>
-
- * mac/tclMacResource.c:
- * generic/tclListObj.c:
- * generic/tclObj.c:
- * generic/tclStringObj.c: Changed to avoid freeing the string
- representation before freeing the internal rep. This helps with
- debugging since the string rep will still be valid when the free
- proc is invoked.
-
-1999-04-27 <stanton@scriptics.com>
-
- * generic/tclLiteral.c (TclHideLiteral): Fixed so hidden literals
- get duplicated to avoid accidental sharing in the global object
- table.
-
-1999-04-23 <stanton@scriptics.com>
-
- * generic/tclStubInit.c:
- * tools/genStubs.tcl: Changed to avoid the need for forward
- declarations in stub initializers.
+2002-06-26 Reinhard Max <max@suse.de>
-1999-04-23 <stanton@scriptics.com>
+ * unix/tclUnixTime.c: Make [clock format] respect locale settings.
+ * tests/clock.test: Bug #565880. ***POTENTIAL INCOMPATIBILITY***
- * library/encoding/koi8-r.enc:
- * tools/encoding/koi8-r.txt: Added support for the koi8-r Cyrillic
- encoding. [Bug: 1771]
+2002-06-26 Miguel Sofer <msofer@users.sourceforge.net>
-1999-04-22 <stanton@scriptics.com>
-
- * win/tclWinFCmd.c:
- * win/tclWin32Dll.c: Changed uses of "try" to "__try", since that
- is the actual keyword. This eliminates the need for some -D flags
- from the makefile.
-
- * generic/tclPort.h: Added include of tcl.h since it defines
- various Windows macros that are needed before deciding which
- platform porting file to use.
-
- * generic/tclEvent.c: lint
-
- * win/tclWinInit.c (TclpInitPlatform): Added call to TclWinInit
- when building a static library since DllMain will not be invoked.
- This could break old code that explicitly called TclWinInit, but
- should be simpler in the long run.
-
-1999-04-22 Scott Stanton <stanton@scriptics.com>
-
- * generic/tclInt.h:
- * generic/tclInt.decls:
- * generic/tclCompile.c: Added TclSetByteCodeFromAny that takes a
- hook procedure to invoke after compilation but before the byte
- codes are emitted. This makes it possible to do postprocessing on
- the compiled byte codes before the ByteCode is generated.
-
- * generic/tclLiteral.c: Added TclHideLiteral and TclAddLiteralObj
- to make it possible to create local unshared literal objects.
-
- * win/tclWinInit.c:
- * unix/tclUnixInit.c: Changed initial search path to match that
- found used by tcl_findLibrary.
-
-1999-04-22 <redman@scriptics.com>
-
- * win/tclWinPort.h:
- * win/tclWinSock.c: Added code to use WinSock 2.0 API on NT to
- avoid creating a window to handle sockets. API not available on
- Win95 and needs to be fixed on Win98, until then continue to use
- the older (window-based) scheme on those two OSes.
+ * doc/CrtInterp.3:
+ * doc/StringObj.3: clarifications by Don Porter, bugs #493995 and
+ #500930.
-1999-04-15 <stanton@scriptics.com>
+2002-06-24 Don Porter <dgp@users.sourceforge.net>
- * Merged 8.1 back into the main trunk
+ * library/tcltest/tcltest.tcl: Corrected suppression of -verbose skip
+ * tests/tcltest.test: and start by [test -output]. Also
+ corrected test suite errors exposed by corrected code. [Bug 564656]
-1999-04-13 <stanton@scriptics.com>
+2002-06-25 Reinhard Max <max@suse.de>
- * library/encoding/gb2312.enc:
- * library/encoding/euc-cn.enc:
- * tools/encoding/gb2312.txt:
- * tools/encoding/cp950.txt:
- * tools/encoding/Makefile: Restored the double byte definition of
- GB2312 and added the EUC-CN encoding. EUC-CN is a variant of
- GB2312 that shifts the characters into bytes with the high bit set
- and includes ASCII as a subset. [Bug: 632]
+ * unix/tcl.m4: New macro SC_CONFIG_MANPAGES.
+ * unix/configure.in: Added support for symlinks and compression
+ * unix/Makefile.in: when installing the manpages. [Patch 518052]
+ * unix/mkLinks.tcl: Default is still hardlinks and no compression.
-1999-04-13 <redman@scriptics.com>
-
- * win/tclWinSock.c: Apply patch to allow write access to a socket
- if FD_WRITE is sent but FD_CONNECT is not. Some strange problem
- with either Win32 or a socket driver. [Bug: 1664 1776]
-
-1999-04-09 <redman@scriptics.com>
+ * unix/mkLinks: generated
+ * unix/configure:
- * unix/tclUnixNotfy.c: Fixed notifier deadlock situation when the
- pipe used to talk back notifier thread is filled with data. When
- calling the write() function to feed data down that pipe, unlock
- the notifierMutex to allow the notifier to wake up again. Found
- as a result of the focus.test for Tk hanging. [Bug: 1700]
+ * unix/README: Added documentation for the new features.
-1999-04-06 <stanton@scriptics.com>
+ * unix/tcl.m4 (SC_PATH_TCLCONFIG): Replaced ${exec_prefix}/lib by
+ ${libdir}.
- * tests/unixNotfy.test: Fixed hang in tests when built with thread
- support.
+2002-06-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * tests/httpold.test: Fixed broken test that didn't wait long
- enough for events to arrive.
+ * generic/tclUtil.c (TclGetIntForIndex): Fix of critical bug
+ #533364 generated when the index is bad and the result is a shared
+ object. The T_ASTO(T_GOR, ...) idiom likely exists elsewhere
+ though. Also removed some cruft that just complicated things to
+ no advantage.
+ (SetEndOffsetFromAny): Same fix, though this wasn't on the path
+ excited by the bug.
- * tests/unixInit.test: Fixed race condition in test.
-
- * tests/unixInit.test:
- * tests/fileName.test: Minor test nits.
+2002-06-24 Don Porter <dgp@users.sourceforge.net>
- * unix/tclUnixInit.c (TclpSetInitialEncodings): Fixed bad initial
- encoding string.
+ * library/tcltest/tcltest.tcl: Implementation of TIP 101. Adds
+ * tests/parseOld.test: and exports a [configure] command
+ * tests/tcltest.test: from tcltest.
-1999-04-06 <surles@scriptics.com>
+2002-06-22 Don Porter <dgp@users.sourceforge.net>
- * generic/tclVar.c:
- * generic/tclEnv.c: Moved the "array set" C level code into a
- common routine (TclArraySet). The TclSetupEnv routine now uses
- this API to create an env array w/ no elements.
+ * changes: updated changes file for 8.4b1 release.
- * generic/tclEnv.c:
- * generic/tclWinInit.h:
- * generic/tclUnixInit.h:
- * generic/tclInt.h: Made the Env module I18N compliant. Changed the
- FindVariable routine to TclpFindVariable, that now does a case
- insensitive string comparison on Windows, and not on UNIX. [Bug:
- 1299, 1500]
+ * library/tcltest/tcltest.tcl: Corrections to tcltest and the
+ * tests/basic.test: Tcl test suite so that a test
+ * tests/cmdInfo.test: with options -constraints knownBug
+ * tests/compile.test: -limitConstraints 1 only tests the
+ * tests/encoding.test: knownBug tests. Mostly involves
+ * tests/env.test: replacing direct access to the
+ * tests/event.test: testConstraints array with calls
+ * tests/exec.test: to the testConstraint command
+ * tests/execute.test: (which requires tcltest version 2)
+ * tests/fCmd.test:
+ * tests/format.test:
+ * tests/http.test:
+ * tests/httpold.test:
+ * tests/ioUtil.test:
+ * tests/link.test:
+ * tests/load.test:
+ * tests/namespace.test:
+ * tests/pkgMkIndex.test:
+ * tests/reg.test:
+ * tests/result.test:
+ * tests/scan.test:
+ * tests/stack.test:
-1999-04-05 <stanton@scriptics.com>
+2002-06-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * tests/io.test: Minor test cleanup.
+ * tools/tcl.wse.in (Disk Label), unix/tcl.spec (version):
+ * win/README.binary, README, win/configure.in, unix/configure.in:
+ * generic/tcl.h (TCL_RELEASE_*, TCL_PATCH_LEVEL): Bump to beta1.
- * generic/tclEncoding.c (Tcl_CreateEncoding): Minor lint to make
- it easier to compile on Digital-unix. [Bug: 1659]
+2002-06-21 Joe English <jenglish@users.sourceforge.net>
- * unix/configure.in:
- * unix/tclUnixPort.h: Applied patch for OS/390 to handle lack of
- sys/param.h. [Bug: 1725]
+ * generic/tclCompExpr.c:
+ * generic/tclParseExpr.c: LogSyntaxError() should reset
+ the interpreter result [Bug 550142 "Tcl_ExprObj -> abort"]
- * unix/configure.in: Fixed BSD/OS 4.* configuration to support
- shared libraries properly. [Bug: 1730]
+2002-06-21 Don Porter <dgp@users.sourceforge.net>
-1999-04-05 <redman@scriptics.com>
-
- * win/tclWinDde.c: decrease timeout value for DDE calls to 30k
- [Bug: 1639]
-
- * generic/tcl.decls:
+ * unix/Makefile.in: Updated all package install directories
+ * win/Makefile.in: to match current Major.minor versions
+ * win/makefile.bc: of the packages. Added tcltest package
+ * win/makefile.vc: to installation on Windows.
+
+ * library/init.tcl: Corrected comments and namespace style
+ issues. Thanks to Bruce Stephens. [Bug 572025]
+
+2002-06-21 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * tests/cmdAH.test: Added TIP#99 implementation
+ * tests/fCmd.test: of 'file link'. Supports creation
+ * tests/fileName.test: of symbolic and hard links in the
+ * tests/fileSystem.test: native filesystems and in vfs's,
+ * generic/tclTest.c: when the individual filesystem
+ * generic/tclCmdAH.c: supports the concept.
+ * generic/tclIOUtil.c:
* generic/tcl.h:
- * generic/tclDecls.h:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclStubInit.c:
- * generic/tclUtil.c: Added more functions to the Tcl stubs table,
- including all Tcl_ functions not already in it (except Cmd
- functions) and Tcl_GetCwd() and Tcl_Chdir() (new functions).
-
- * tests/safe.test:
- * doc/safe.n:
- * generic/tclBasic.c:
- * library/safe.tcl: The encoding command is not safe as-is, so
- create a safe alias to mask out the "encoding system <name>" but
- allow all other uses including "encoding system". Added test cases
- and updated the man page for Safe Tcl.
-
-1999-04-05 <stanton@scriptics.com>
-
- * tests/winTime.test:
- * win/tclWinTime.c: Fixed crash in clock command that occurred
- when manipulating negative time values in timezones east of
- GMT. [Bug: 1142, 1458]
-
- * tests/platform.test:
- * tests/fileName.test: Fixed broken tests.
-
- * generic/tclFileName.c: Moved global regexps into thread local
- storage.
-
- * tests/socket.test: Changed so tests don't reuse sockets,
- since Windows is slow to release sockets.
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c: Fixed race condition where background
- threads were terminated while they still held a lock in the
- notifier.
-
-1999-04-02 <stanton@scriptics.com>
-
- * tests/http.test: Fixed bad test initialization code.
-
- * generic/tclThreadTest.c (ThreadExitProc): Fixed bug where static
- memory was being returned instead of a dynamically allocated
- result in error cases.
-
-1999-04-02 <redman@scriptics.com>
-
- * doc/dde.n:
- * tools/tcl.wse.in:
- * win/makefile.vc:
- * win/pkgIndex.tcl:
- * win/tclWinDde.c: Add new DDE package, code removed from Tk now
- separated into its own package. Changed DDE-based send code into
- "dde eval" command. Can be loaded into tclsh (not just wish).
- Windows only.
-
-1999-04-02 <stanton@scriptics.com>
-
- * tests/expr.test:
- * tests/for-old.test:
- * tests/for.test:
- * tests/foreach.test:
- * tests/format.test:
- * tests/httpold.test:
- * tests/if.test:
- * tests/init.test:
- * tests/interp.test:
- * tests/while.test: Added some tests for known bugs (marked with
- knownBug constraint), and cleaned up a few bad tests.
-
- * generic/regc_locale.c:
- * generic/regcustom.h:
- * generic/tcl.decls:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclInt.h:
- * generic/tclRegexp.c:
- * generic/tclScan.c:
- * generic/tclTest.c:
- * generic/tclUtf.c:
- * win/tclWinFCmd.c:
- * win/tclWinFile.c: Made various Unicode utility functions
- public. The following functions were made public and added to the
- stubs table:
- Tcl_UtfToUniCharDString, Tcl_UniCharToUtfDString,
- Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharIsAlnum,
- Tcl_UniCharIsAlpha, Tcl_UniCharIsDigit, Tcl_UniCharIsLower,
- Tcl_UniCharIsSpace, Tcl_UniCharIsUpper, Tcl_UniCharIsWordChar
-
-1999-04-01 <stanton@scriptics.com>
-
- * tests/registry.test:
- * win/tclWinReg.c: Internationalized the registry code. It now
- uses Unicode interfaces on NT. [Bug: 1197]
-
- * tests/parse.test:
- * generic/tclParse.c: Fixed crash due to multiple frees in parser
- during error cleanup when parsing commands with more tokens than
- will fit in the static area of the parse structure. [Bug: 1681]
-
- * generic/tclInt.h: Removed duplicate declarations.
-
- * generic/tclInt.decls:
- * generic/tcl.decls: Added Tcl_WinUtfToTChar and Tcl_WinTCharToUtf
- to the tclPlat table.
-
-1999-04-01 <redman@scriptics.com>
-
* generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclDecls.h:
- * generic/StubInit.c:
- * tools/genStubs.tcl:
- * unix/Makefile.in:
- * win/makefile.vc: Applied patch from Jan Nijtmans to fix Ultrix
- multiple symbol definition problem. Now, even Tcl includes a copy
- of the Tcl stub library. Also fixed TCL_MEM_DEBUG mode (for Tk).
-
-1999-03-31 <redman@scriptics.com>
-
- * win/tclWinConsole.c: WinNT has a bug when reading a single
- character from the console. Rewrote the code for the console to
- read an entire line at a time using the reader thread.
-
-1999-03-30 <stanton@scriptics.com>
-
- * unix/Makefile.in: Removed trailing backslash that broke the
- "depend" target.
-
- * unix/tclUnixInit.c (TclpSetInitialEncodings): Changed to avoid
- calling setlocale(). We now look directly at env(LANG) and
- env(LC_CTYPE) instead. [Bug: 1636]
-
- * generic/tclFileName.c:
- * generic/tclDecls.h:
- * generic/tcl.decls: Removed CONST from Tcl_JoinPath and
- Tcl_TranslateFileName because it changes the signature of
- Tcl_JoinPath in an incompatible manner.
-
- * generic/tclInt.h:
- * generic/tclLoad.c (TclFinalizeLoad):
- * generic/tclEvent.c (Tcl_Finalize): Defer unloading of loadable
- modules until all exit handlers have been invoked.
- [Bug: 998, 1273, 1573, 1593]
+ * doc/FileSystem.3:
+ * doc/file.n:
+ * mac/tclMacFile.c:
+ * unix/tclUnixFile.c:
+ * win/tclWinFile.c: Also enhanced speed of 'file normalize' on
+ Windows.
-1999-03-29 <stanton@scriptics.com>
+2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclFileName.c:
- * generic/tclDecls.h:
- * generic/tcl.decls: Added CONST to Tcl_JoinPath and
- Tcl_TranslateFileName.
+ * generic/tclBasic.c (TclEvalObjvInternal): fix for [Bug 571385]
+ in the implementation of TIP#62 (command tracing). Vince Darley,
+ Hemang Lavana & Don Porter: thanks.
-1999-03-29 <redman@scriptics.com>
+2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
- * tools/genStubs.tcl:
- * unix/configure.in:
- * unix/Makefile.in:
- * win/makefile.vc:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclDecls.h:
- * generic/tclIntDecls.h:
- * generic/tclPlatDecls.h:
- * generic/tclIntPlatDecls.h: Removed the stub functions and
- changed the stub macros to just use the name without params. Pass
- &tclStubs into the interp (don't use tclStubsPtr because of
- collisions with the stubs on Solaris).
-
-1999-03-27 <redman@scriptics.com>
+ * generic/tclExecute.c (TclCompEvalObj): clarified and simplified
+ the logic for compilation/recompilation.
- * win/makefile.bc: Removed makefile for Borland compiler, no
- longer supported.
+2002-06-19 Joe English <jenglish@users.sourceforge.net>
+ * doc/file.n: Fixed indentation. No substantive changes.
-1999-03-26 <redman@scriptics.com>
+2002-06-19 Jeff Hobbs <jeffh@ActiveState.com>
- * win/tclWinSerial.c:
- * win/tclWinConsole.c:
- * win/tclWinPipe.c: Don't close the Win32 handle for a channel if
- it's a stdio handle (GetStdHandle()) during shutdown of a thread
- to prevent it from destroying the stdio of other threads.
+ * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): get the resultPtr again
+ as the Tcl_ObjSetVar2 may cause the result to change.
+ [Patch #558324] (watson)
-1999-03-26 <suresh@scriptics.com>
+2002-06-19 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/configure.in
- --nameble-shared is now the default and build Tcl as a shared
- library; specify --disable-shared to build a static Tcl library
- and shell.
+ * generic/tclExecute.c (TEBC): removing unused "for(;;)" loop;
+ improved comments; re-indentation.
-1999-03-25 <stanton@scriptics.com>
+2002-06-18 Miguel Sofer <msofer@users.sourceforge.net>
- * tests/interp.test:
- * generic/tclInterp.c (AliasObjCmd): Changed so aliases are
- invoked at current scope in the target interpreter instead of at
- the global scope. This was an incompatibility introduced in 8.1
- that is being removed. [Bug: 1153, 1556]
-
- * library/encoding/big5.enc:
- * library/encoding/gb2312.enc:
- * tools/encoding/big5.enc:
- * tools/encoding/gb2312.enc: Added ASCII to big5 and gb2312
- encodings. [Bug: 632]
-
- * generic/tclPkg.c (Tcl_PkgRequireEx): Fixed broken clientData
- initialization in package code.
+ * generic/tclExecute.c (TEBC):
+ - elimination of duplicated code in the non-immediate INST_INCR
+ instructions.
+ - elimination of 103 (!) TclDecrRefCount macros. The different
+ instructions now jump back to a common "DecrRefCount zone" at
+ the top of the loop. The macro "ADJUST_PC" was replaced by two
+ macros "NEXT_INST_F" and "NEXT_INST_V" that take three params
+ (pcAdjustment, # of stack objects to discard, resultObjPtr
+ handling flag). The only instructions that retain a
+ TclDecrRefCount are INST_POP (for speed), the common code for
+ the non-immediate INST_INCR, INST_FOREACH_STEP and the two
+ INST_LSET.
- * unix/Makefile.in (dist): Added tcl.decls and tclInt.decls to
- source distribution. [Bug: 1571]
+ The object size of tclExecute.o was reduced by approx 20% since
+ the start of the consolidation drive, while making room for some
+ peep-hole optimisation at runtime.
- * doc/Thread.3: Updated documentation of Tcl_MutexLock to indicate
- that the recursive locking behavior is undefined. On Windows, it
- does not block, on Unix it deadlocks. [Bug: 1275]
+2002-06-18 Miguel Sofer <msofer@users.sourceforge.net>
-1999-03-24 <stanton@scriptics.com>
+ * generic/tclExecute.c (TEBC, INST_DONE): small bug in the panic
+ code for tcl-stack corruption.
- * tests/execute.test:
- * generic/tclExecute.c (TclExecuteByteCode): Fixed expression code
- that incorrectly returned floating point values for integers if
- the internal rep happened to be a double. Now we check to see if
- the object has a string rep that looks like an integer before
- using the double internal rep. [Bug: 1516]
+2002-06-17 David Gravereaux <davygrvy@pobox.com>
-1999-03-24 <redman@scriptics.com>
+ Trims to support the removal of RESOURCE_INCLUDED from rc
+ scripts from FR #565088.
- * generic/tclAlloc.c:
- * generic/tclEncoding.c:
- * generic/tclProc.c:
- * unix/tclUnixTime.c:
- * win/tclWinSerial.c: Fixed compilation warnings/errors for VC++
- 5.0 and 6.0 and HP-UX native compiler without -Aa or -Ae.
- [Bug: 1323 1518 1324 1583 1585 1586]
-
- * win/tclWinSock.c: Make sockets thread-safe on Windows. The
- current implementation uses windows to handle events on the
- socket, one for each thread (thread local storage). Previously,
- there was only one window shared between threads, which didn't
- work. [Bug: 1326]
-
-1999-03-23 <stanton@scriptics.com>
-
- * tools/tcl.wse: Fixed file association to look in the right place
- for the wish icon. [Bug: 1544]
-
- * tests/winNotify.test:
- * tests/ioCmd.test:
- * tests/event.test: Changed to use new style conditionals.
-
- * tests/encoding.test: Fixed nonportable test.
-
- * unix/dltest/configure.in:
- * unix/dltest/Makefile.in: Added missing DBGX macros. [Bug: 1564]
-
- * tests/winNotify.test:
- * mac/tclMacNotify.c:
- * win/tclWinNotify.c:
- * unix/tclUnixNotfy.c:
- * generic/tclNotify.c: Added a new Tcl_ServiceModeHook interface
- that is invoked whenever the service mode changes. This is needed
- to allow the Windows notifier to create a communication window the
- first time Tcl is about to enter an external modal event loop
- instead of at startup time. This will avoid the various problems
- that people have been seeing where the system hangs when tclsh
- is running outside of the event loop. [Bug: 783]
+ * generic/tcl.h: moved the #ifndef RC_INVOKED start block up in
+ the file. rc scripts don't need to know thread mutexes.
- * generic/tclInt.h:
- * generic/tcl.decls: Renamed TclpAlertNotifier back to
- Tcl_AlertNotifier since it is part of the public notifier driver
- API.
+ * win/tcl.rc:
+ * win/tclsh.rc: removed the #define RESOURCE_INCLUDED to let the
+ built-in -DRC_INVOKED to the work.
-1999-03-23 <redman@scriptics.com>
+2002-06-17 Jeff Hobbs <jeffh@ActiveState.com>
- * win/tclWinSerial.c: Fixed problem with fileevent on the serial
- port and nonblocking mode. Gets no longer hangs, fileevents fire
- whenever there is any character data on the port.
-
- * tests/winConsole.test:
- * win/tclWinConsole.c: Fixed problem with fileevents and gets from
- a console stdin. Previously, fileevents were firing before an
- entire line was available for reading, which meant that when you
- did a gets or read, it blocked (even in nonblocking mode). Now, it
- should work the same as Unix: fileevents fire when an entire line
- is ready, and gets and read do not block in non-blocking mode.
- Added an interactive test case to check for this.
+ * doc/CrtTrace.3: Added TIP#62 implementation of command
+ * doc/trace.n: execution tracing [FR #462580] (lavana).
+ * generic/tcl.h: This includes enter/leave tracing as well
+ * generic/tclBasic.c: as inter-procedure stepping.
+ * generic/tclCmdMZ.c:
+ * generic/tclCompile.c:
+ * generic/tclExecute.c:
+ * generic/tclInt.decls:
+ * generic/tclInt.h:
+ * generic/tclIntDecls.h:
+ * generic/tclStubInit.c:
+ * generic/tclVar.c:
+ * tests/trace.test:
-1999-03-22 <stanton@scriptics.com>
+2002-06-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
- * tests/reg.test:
- * generic/regc_color.c: Applied regexp bug fix from Henry Spencer.
+ * win/tclWinPipe.c (BuildCommandLine): Fixed bug #554068 ([exec]
+ on windows did not treat { in filenames well.). Bug reported by
+ Vince Darley <vincentdarley@users.sourceforge.net>, patch
+ provided by Vince too.
-1999-03-19 <redman@scriptics.com>
+2002-06-17 Joe English <jenglish@users.sourceforge.net>
- * generic/tclCmdIL.c: Fixed the initialization of an array so that
- the Sun 5.0 C compiler wouldn't complain.
+ * generic/tcl.h: #ifdef logic for K&R C backwards compatibility
+ changed to assume modern C by default. See SF FR #565088 for
+ full details.
- * unix/configure.in: Added support for --enable-64bit. For now,
- this is only supported on Solaris 7 64bit (SunOS 5.7) using the Sun
- compiler (not gcc).
-
-1999-03-18 <stanton@scriptics.com>
+2002-06-17 Don Porter <dgp@users.sourceforge.net>
- * win/tclWinChan.c (TclpOpenFileChannel, Tcl_MakeFileChannel):
- Changed to only test for console or comm handles when the type is
- FILE_TYPE_CHAR to avoid useless tests on simple files. Also
- reordered tests so consoles are tested first as this is more
- common.
+ * doc/msgcat.n: Corrected en_UK references to en_GB. UK is not
+ a country designation recognized in ISO 3166.
- * win/makefile.vc: Regularized usage of mkd and rmd and rm.
+ * library/msgcat/msgcat.tcl: More Windows Registry locale codes
+ from Bruno Haible.
- * library/encoding/shiftjis.enc:
- * tools/encoding/shiftjis.txt: Missing/incorrect characters in
- shift-jis table. [Bug: 1008, 1526]
+ * doc/msgcat.n:
+ * library/msgcat/msgcat.tcl:
+ * library/msgcat/pkgIndex.tcl:
+ * tests/msgcat.test: Revised locale initialization to interpret
+ environment variable locale values according to XPG4, and to
+ recognize the LC_ALL and LC_MESSAGES values over that of LANG.
+ Also added many Windows Registry locale values to those
+ recognized by msgcat. Revised tests and docs. Bumped to
+ version 1.3. Thanks to Bruno Haible for the report and
+ assistance crafting the solution. [Bug 525522, 525525]
- * generic/tclInt.decls:
- * generic/tcl.decls: Eliminated use of "string" and "list" from
- argument lists to avoid conflicts with C++ STL. [Bug: 1181]
+2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
- * win/tclWinFile.c (TclpMatchFiles): Changed to ignore the
- FS_CASE_IS_PRESERVED bit and always return exactly what we get
- from the system.
+ * generic/tclCompile.c (TclCompileTokens): a better algorithm for
+ the previous bug fix.
-1999-03-17 <stanton@GASPODE>
+2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
- * win/README.binary:
- * win/README:
- * unix/configure.in:
- * generic/tcl.h:
- * README: Updated version to 8.1b3.
-
-1999-03-14 <stanton@GASPODE>
-
- * win/tclWinConsole.c:
- * win/tclWinPipe.c:
- * win/tclWinSerial.c: Changed so channel drivers wait for the
- reader/writer threads to exit before returning during a close
- operation. This ensures that the main thread is the last thread
- to exit, so the process return value is set properly.
-
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclIntPlatStubs.c:
- * generic/tclIntStubs.c:
- * generic/tclPlatDecls.h:
- * generic/tclPlatStubs.c:
- * generic/tclStubInit.c:
- * generic/tclStubs.c: Fixed bad eol characters.
+ * generic/tclCompile.c (TclCompileTokens):
+ * tests/compile.test: [Bug 569438] in the processing of dollar
+ variables; report by Georgios Petasis.
- * generic/tclInt.decls: Changed "const" to "CONST" in
- declarations for better portability.
+2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tcl.decls: Renamed panic and panicVA to Tcl_Panic and
- Tcl_PanicVA in the stub files.
+ * generic/tclExecute.c: bug in the consolidation of the
+ INCR_..._STK instructions; the bug could not be exercised as the
+ (faulty) instruction INST_INCR_ARRAY_STK was never compiled-in
+ (related to [Bug 569438]).
- * generic/tclInterp.c (Tcl_MakeSafe): Remove tcl_platform(user)
- from safe interps.
+2002-06-14 Miguel Sofer <msofer@users.sourceforge.net>
-1999-03-11 <stanton@GASPODE>
+ * generic/tclExecute.c (TclExecuteByteCode): runtime peep-hole
+ optimisation of variables (INST_STORE, INST_INCR) and commands
+ (INST_INVOKE); faster check for the existence of a catch.
+ (TclExecuteByteCode): runtime peep-hole optimisation of
+ comparisons.
+ (TclExecuteByteCode): runtime peep-hole optimisation of
+ INST_FOREACH - relies on peculiarities of the code produced by the
+ bytecode compiler.
- * unix/Makefile.in:
- * unix/configure.in: Include compat files in the stub library in
- addition to the main library. Compat files are now built for
- dynamic use in all cases.
-
- * generic/tcl.h: Changed magic number so it doesn't match the plus
- patch, at Jan's request.
-
- * unix/tclConfig.sh.in:
- * unix/dltest/Makefile.in:
- * unix/dltest/configure.in:
- * unix/dltest/pkga.c:
- * unix/dltest/pkgb.c:
- * unix/dltest/pkgc.c:
- * unix/dltest/pkgd.c:
- * unix/dltest/pkge.c:
- * unix/dltest/pkgf.c: Changed package tests to build against the
- stubs library.
-
-1999-03-10 <stanton@GASPODE>
+2002-06-14 David Gravereaux <davygrvy@pobox.com>
- * generic/tcl.h:
- * generic/tcl.decls: Changed Tcl_ReleaseType from an enum to
- macros so it can be used in .rc files.
- Added Tcl_GetString.
+ * win/rules.vc: The test for compiler optimizations was in error.
+ Thanks goes to Roy Terry <royterry@earthlink.net> for his
+ assistance with this.
- * mac/tclMacNotify.c:
- * generic/tclNotify.c:
- * generic/tclInt.h:
- * win/tclWinNotify.c:
- * generic/tcl.h: Renamed Tcl_AlertNotifier to TclpAlertNotifier.
+2002-06-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * generic/tclInt.decls: Added TclWinAddProcess to make it possible
- for expect to use Tcl_WaitForPid(). This patch is from Gordon
- Chaffee.
+ * doc/trace.n, tests/trace.test:
+ * generic/tclCmdMZ.c (Tcl_TraceObjCmd,TclTraceCommandObjCmd)
+ (TclTraceVariableObjCmd): Changed references to "trace list" to
+ "trace info" as mandated by TIP#102.
- * mac/tclMacPort.h:
- * win/tclWinInit.c:
- * unix/tclUnixPort.h:
- * generic/tclAsync.c: Added TclpAsyncMark to fix bug in async
- handling on Windows where async events don't wake up the event
- loop. This patch comes from Gordon Chaffee.
+2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tcl.decls: Fixed declarations of reserved slots.
-
-1999-03-10 <redman@scriptic.com>
+ * generic/tclExecute.c (TclExecuteByteCode): consolidated code for
+ the conditional branch instructions.
- * generic/tclCompile.h: Ensure that the ByteCode struct is binary
- compatible with the version in 8.0.6.
+2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tcl.h:
- * generic/tclBasic.c: Add Tcl_GetVersion() function to the public
- C API to allow programs to check the version number of the Tcl
- library at runtime. Also added an enum to clarify the release
- level (alpha, beta, final).
+ * generic/tclExecute.c (TclExecuteByteCode): fixed the previous
+ patch - wouldn't compile with TCL_COMPILE_DEBUG set.
-1999-03-09 <stanton@GASPODE>
+2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
- * Integrated changes from Tcl 8.0 including:
- stubs mechanism
- configure patches from Jan Nijtmans
- rename of panic to Tcl_Panic
-
-1999-03-08 <lfb@scriptics.com>
+ * generic/tclExecute.c (TclExecuteByteCode): consolidated the
+ handling of exception returns to INST_INVOKE and INST_EVAL, as
+ well as most of the code for INST_CONTINUE and INST_BREAK, in the
+ new jump target "processExceptionReturn".
+
+2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
- * win/tclWin32Dll.c: Removed Dll instance from thread-local
- storage.
+ * generic/tclExecute.c (TclExecuteByteCode): consolidated variable
+ handling opcodes, replaced redundant code with some 'goto'. All
+ store/append/lappend opcodes on the same data type now share the
+ main code; same with incr opcodes.
+ * generic/tclVar.c: added the bit TCL_TRACE_READS to the possible
+ flags to Tcl_SetVar2Ex - it causes read traces to be fired prior
+ to setting the variable. This is used in the core for [lappend].
-1999-03-08 <stanton@GASPODE>
+ ***NOTE*** the usage of TCL_TRACE_READS in Tcl_(Obj)?GetVar.* is
+ not documented; there, it causes the call to create the variable
+ if it does not exist. The new usage in Tcl_(Obj)?SetVar.* remains
+ undocumented too ...
- * generic/tcl.h: Moved Tcl_Mutex, etc. macros above the inclusion
- of tclDecls.h to avoid macro conflicts.
+2002-06-13 Vince Darley <vincentdarley@users.sourceforge.net>
- * generic/tclInt.h:
- * generic/regc_color.c:
- * generic/regcomp.c:
- * generic/tclCmdIL.c:
+ * tests/fCmd.test:
+ * tests/winFile.test:
+ * tests/fileSystem.test:
+ * generic/tclTest.c:
* generic/tclCmdAH.c:
- * generic/tclIOCmd.c:
- * generic/tclParse.c:
- * generic/tclStringObj.c:
- * unix/tclUnixNotfy.c: Cleaned up various compiler warnings,
- eliminated UCHAR bugs.
-
- * unix/tclUnixNotfy.c:
- * unix/tclUnixThrd.c:
- * generic/tclThreadTest.c:
- * mac/tclMacThrd.c: Changed TclpCondition*() to Tcl_Condition*().
+ * generic/tclIOUtil.c:
+ * doc/FileSystem.3:
+ * mac/tclMacFile.c:
+ * unix/tclUnixFile.c:
+ * win/tclWinFile.c: fixed up further so both compiles and
+ actually works with VC++ 5 or 6.
+ * win/tclWinInt.h:
+ * win/tclWin32Dll.c: cleaned up code and vfs tests and
+ added tests for the internal changes of 2002-06-12, to see
+ whether WinTcl on NTFS can coexist peacefully with links
+ in the filesystem. Added new test command 'testfilelink'
+ to enable the newer code to be tested.
+ * tests/fCmd.test: (made certain tests of 'testfilelink' not
+ run on unix).
+
+2002-06-12 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tclBasic.c (Tcl_DeleteTrace): fixed [Bug 568123] (thanks to
+ Hemang Lavana)
- * INTEGRATED PATCHES FROM 8.0.6:
-
- * generic/tcl.decls:
- * generic/tcl.h:
- * generic/tclBasic.c:
- * generic/tclDecls.h:
- * generic/tclInt.decls:
- * generic/tclInt.h:
- * generic/tclIntDecls.h:
- * generic/tclIntPlatDecls.h:
- * generic/tclIntPlatStubs.c:
- * generic/tclIntStubs.c:
- * generic/tclPlatDecls.h:
- * generic/tclPlatStubs.c:
- * generic/tclStubInit.c:
- * generic/tclStubLib.c:
- * generic/tclStubs.c:
- * tools/genStubs.tcl:
- * unix/configure.in:
- * unix/Makefile.in:
- * unix/tclConfig.sh.in:
- * win/makefile.vc:
- * win/tclWinPort.h: Added Tcl stubs implementation. There are
- now two new macros USE_TCL_STUBS and USE_TCL_STUB_PROCS that
- enable use of stubs and disable stub macros respectively. All of
- the public and private function declarations from tcl.h and
- tclInt.h have moved into the *.decls files and the *Stubs.c and
- *Decls.h files are generated using the genStubs.tcl script.
+2002-06-12 Jeff Hobbs <jeffh@ActiveState.com>
- * unix/Makefile.in:
- * unix/configure.in:
- * unix/ldAix: Enhanced AIX shared library support.
+ * win/tclWinFile.c: corrected the symbolic link handling code to
+ allow it to compile. Added real definition of REPARSE_DATA_BUFFER
+ (found in winnt.h). Most of the added definitions appear to have
+ correct, cross-Win-version equivalents in winnt.h and should be
+ removed, but just making things "work" for now.
- * win/tclWinSock.c: Removed a bunch of extraneous PASCAL FAR
- attributes from internal functions.
+2002-06-12 Vince Darley <vincentdarley@users.sourceforge.net>
- * win/tclWinReg.c: Changed registry package to use stubs mechanism
- so it no longer depends on the specific version of Tcl.
+ * generic/tclIOUtil.c:
+ * generic/tcl.decls:
+ * generic/tclDecls.h: made code for Tcl_FSNewNativePath
+ agree with man pages.
+
+ * doc/FileSystem.3: clarified the circumstances under which
+ certain functions are called in the presence of symlinks.
+
+ * win/tclWinFile.c:
+ * win/tclWinPort.h:
+ * win/tclWinInt.h:
+ * win/tclWinFCmd.c: Fix for Windows to allow 'file lstat',
+ 'file type', 'glob -type l', 'file copy', 'file delete',
+ 'file normalize', and all VFS code to work correctly in the
+ presence of symlinks (previously Tcl's behaviour was not very
+ well defined). This also fixes possible serious problems in
+ all versions of WinTcl where 'file delete' on a NTFS symlink
+ could delete the original, not the symlink.
+ Note: symlinks cannot yet be created in pure Tcl.
+
+2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
- * doc/AddErrInfo.3:
- * doc/Eval.3:
- * doc/PkgRequire.3:
- * doc/SetResult.3:
- * doc/StringObj.3:
- * generic/tcl.h:
* generic/tclBasic.c:
- * generic/tclPanic.c:
- * generic/tclStringObj.c:
- * generic/tclUtil.c:
- * unix/mkLinks: Added va_list versions of all VARARGS
- functions so they can be invoked from the stub functions.
-
- * doc/package.n:
- * doc/PkgRequire.3:
- * generic/tclPkg.c: Added Tcl_PkgProvideEx, Tcl_RequireEx,
- Tcl_PresentEx, and Tcl_PkgPresent. Added "package present"
- command.
-
- * generic/tclFileName.c:
- * mac/tclMacFile.c:
- * mac/tclMacShLib.exp:
- * unix/tclUnixFile.c:
- * win/tclWinFile.c: Changed so TclGetUserHome is defined on
- all platforms, even though it is currently a noop on mac and
- windows, and renamed it to TclpGetUserHome.
-
- * generic/tclPanic.c:
- * generic/panic.c: Renamed panic to Tcl_Panic.
+ * generic/tclCompCmds.c:
+ * generic/tclInt.h: reverted the new compilation functions;
+ replaced by a more general approach described below.
+
+ * generic/tclCompCmds.c:
+ * generic/tclCompile.c: made *all* compiled variable access
+ attempts create an indexed variable - even get or incr without
+ previous set. This allows indexed access to local variables that
+ are created and set at runtime, for example by [global], [upvar],
+ [variable], [regexp], [regsub].
+
+2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * doc/global.n:
+ * doc/info.n:
+ * test/info.test:
+ * generic/tclCmdIL.c: fix for [Bug 567386], [info locals] was
+ reporting some linked variables.
-1999-02-25 <redman@scriptics.com>
+ * generic/tclBasic.c:
+ * generic/tclCompCmds.c:
+ * generic/tclInt.h: added compile functions for [global],
+ [variable] and [upvar]. They just declare the new local variables,
+ the commands themselves are not compiled-in. This gives a notably
+ faster read access to these linked variables.
- * win/makefile.vc: Added tclWinConsole.c and tclWinSerial.c
-
- * win/tclWinConsole.c: New code to properly deal with fileevents
- and nonblocking mode on consoles.
-
- * win/tclWinSerial.c: New code to properly deal with fileevents
- and nonblocking mode on serial ports.
+2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
- * win/tclWinPipe.c:
- * win/tclWinPort.h: Exported functions to allow creation of pipe
- channels from tclWinChan.c
+ * generic/tclExecute.c: optimised algorithm for exception range
+ lookup; part of [Patch 453709].
- * win/tclWinChan.c: Check the type of a channel, including for the
- standard (stdin/stdout/stderr), and use the correct channel type
- to create the channel (file, serial, console, or pipe).
+2002-06-10 Vince Darley <vincentdarley@users.sourceforge.net>
-1999-02-11 <stanton@GASPODE>
+ * unix/tclUnixFCmd.c: fixed [Bug #566669]
+ * generic/tclIOUtil.c: improved and sped up handling of
+ native paths (duplication and conversion to normalized paths),
+ particularly on Windows.
+ * modified part of above commit, due to problems on Linux.
+ Will re-examine bug report and evaluate more closely.
- * README:
- * generic/tcl.h:
- * win/README.binary:
- * win/README:
- * unix/configure.in:
- * mac/README: Updated version numbers to 8.1b2.
+2002-06-07 Don Porter <dgp@users.sourceforge.net>
-1999-02-10 <stanton@GASPODE>
+ * tests/tcltest.test: More corrections to test suite so that tests
+ of failing [test]s don't show up themselves as failing tests.
- * library/auto.tcl: Fixed auto_mkindex so it handles .tbc files.
- Did some general cleanup to handle bad eval statements that didn't
- use "list".
+2002-06-07 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * unix/mkLinks:
- * doc/SetVar.3:
- * generic/tcl.h:
- * generic/tclVar.c: Restored Tcl_ObjGetVar2 and Tcl_ObjSetVar2
- from 8.0. Renamed Tcl_Get/SetObjVar2 to Tcl_GetVar2Ex and
- Tcl_SetVar2Ex.
->>>>>>> 1.1.1.5
+ * generic/tclExecute.c: Tidied up headers in relation to float.h
+ to cut the cruft and ensure DBL_MAX is defined since doubles seem
+ to be the same size everywhere; if the assumption isn't true, the
+ variant platforms had better have run configure...
-1999-02-10 <stanton@GASPODE>
+ * unix/tclUnixPort.h (EOVERFLOW): Added code to define it if it
+ wasn't previously defined. Also some other general tidying and
+ adding of comments. [Tcl bugs 563122, 564595]
+ * compat/tclErrno.h: Added definition for EOVERFLOW copied from
+ Solaris headers; I've been unable to find any uses of EFTYPE,
+ which was the error code previously occupying the slot, in Tcl, or
+ any definition of it in the Solaris headers.
- INTEGRATED PATCHES FROM 8.0.5b2:
+2002-06-06 Mo DeJong <mdejong@users.sourceforge.net>
- * test/winPipe.test: Changed to remove echoArgs.tcl temporary file
- when done.
-
- * tests/cmdAH.test:
- * generic/tclFileName.c (TclGetExtension): Changed behavior so the
- split happens at the last period in the name instead of the first
- period of the last run of periods. So, "foo..o" is split into
- "foo." and ".o" now. [Bug: 1126]
-
- * win/makefile.vc: Added better support for paths with spaces in
- the name. Added .lib and support .dlls to the install-binaries
- target. Added generate of a pkgIndex.tcl script to the
- install-libraries target.
-
- * win/tclAppInit.c:
- * unix/tclAppInit.c:
- * mac/tclMacAppInit.c:
- * generic/tclTest.c: Changed some EXTERN declarations to extern
- since they are not defining exported interfaces. This avoids
- generating useless declspec() attributes and makes the windows
- makefile simpler.
-
- * generic/tcl.h: Moved Tcl_AppInit declaration to end and cleared
- out TCL_STORAGE_CLASS so it is not declared with a declspec().
+ * unix/dltest/Makefile.in: Remove hard coded CFLAGS=-g
+ and add CFLAGS_DEBUG, CFLAGS_OPTIMIZE, and
+ CFLAGS_DEFAULT varaibles. [Tcl bug 565488]
- * tests/interp.test:
- * generic/tclInterp.c (DeleteAlias): Changed to use
- Tcl_DeleteCommandFromToken so we handle renames properly. This
- avoids senseless panic. [Bug: 736]
+2002-06-06 Don Porter <dgp@users.sourceforge.net>
- * unix/tclUnixChan.c:
- * win/tclWinSock.c:
- * doc/socket.n: Applied Gordon Chaffee's patch to handle failures
- during asynchronous socket connection operations. This adds a new
- "-error" fconfgure option to socket channels. [Bug: 893]
+ * tests/tcltest.test: Corrections to test suite so that tests
+ of failing [test]s don't show up themselves as failing tests.
- * generic/tclProc.c:
- * generic/tclNamesp.c:
- * generic/tclInt.h:
- * generic/tclCmdIL.c:
- * generic/tclBasic.c:
- * generic/tclVar.c: Applied patch from Viktor Dukhovni to
- rationalize TCL_LEAVE_ERR_MSG behavior when creating variables.
-
- * generic/tclVar.c: Fixed bug in namespace tail computation.
- Fixed bug where upvar could resurrect a namespace variable whose
- namespace had been deleted.
+ * tests/io.test: Fixed up namespace variable resolution issues
+ revealed by running test suite with "-singleproc 1".
- * generic/tclCompile.c (TclCompileExprCmd): Eliminated yet another
- bogus optimization in expression compilation.
+ * doc/tcltest.n:
+ * library/tcltest/tcltest.tcl:
+ * tests/tcltest.test: Several updates to tcltest.
+ 1) changed to lazy initialization of test constraints
+ 2) deprecated [initConstraintsHook]
+ 3) repaired badly broken [limitConstraints].
+ 4) deprecated [threadReap] and [mainThread]
+ [Patch 512214, Bug 558742, Bug 461000, Bug 534903]
+
+2002-06-06 Daniel Steffen <das@users.sourceforge.net>
+
+ * unix/tclUnixThrd.c (TclpReaddir, TclpLocaltime, TclpGmtime):
+ added mutex wrapped calls to readdir, localtime & gmtime in
+ case their thread-safe *_r counterparts are not available.
+ * unix/tcl.m4: added configure check for readdir_r
+ * unix/tcl.m4 (Darwin): set TCL_DEFAULT_ENCODING to utf-8 on
+ MacOSX (where posix file apis expect utf-8, not iso8859-1).
+ * unix/configure: regen
+ * unix/Makefile.in: set DYLD_LIBRARY_PATH in parallel
+ to LD_LIBRARY_PATH for MacOSX dynamic linker.
+ * generic/tclEnv.c (TclSetEnv): fix env var setting on
+ MacOSX (adapted from patch #524352 by jkbonfield).
+
+2002-06-05 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/Tcl_Main.3: Documented $tcl_rcFileName and added more
+ clarifications about the intended use of Tcl_Main(). [Bug 505651]
+
+2002-06-05 Daniel Steffen <das@users.sourceforge.net>
+
+ * generic/tclFileName.c (TclGlob): mac specific fix to
+ recent changes in 'glob -tails' handling.
+ * mac/tclMacPort.h:
+ * mac/tclMacChan.c: fixed TIP#91 bustage.
+ * mac/tclMacResource.c (Tcl_MacConvertTextResource): added utf
+ conversion of text resource contents.
+ * tests/macFCmd.test (macFCmd-1.2): allow CWIE creator.
+
+2002-06-04 Don Porter <dgp@users.sourceforge.net>
+
+ * library/tcltest/tcltest.tcl:
+ * tests/init.test:
+ * tests/tcltest.test: Added more TIP 85 tests from Arjen Markus.
+ Converted tcltest.test to use a private namespace. Fixed bugs in
+ [tcltest::Eval] revealed by calling [tcltest::test] from a non-global
+ namespace, and namespace errors in init.test.
+
+2002-06-04 Mo DeJong <mdejong@users.sourceforge.net>
+
+ * win/README: Update msys+mingw URL.
+
+2002-06-03 Don Porter <dgp@users.sourceforge.net>
- * unix/configure.in: Added branch for BSD/OS-4* to shared library
- case statement. [Bug: 975]
- Fixed to correctly handle IRIX 6.5 n32 library support. [Bug: 1117]
-
- * win/winDumpExts.c: Patched to be pickier about stripping
- @'s. [Bug: 920]
-
- * library/http2.0/http.tcl: Added catch around eof test in
- CopyDone since the user may have already called http::reset.
- [Bug: 1108]
-
- * unix/configure.in: Changed Linux and IRIX to set SHLIB_LIBS to
- LIBS so shared libraries are linked with the system
- libraries. [Bug: 1018]
-
- * generic/tclCompile.c (CompileExprWord): Fixed exception stack
- overflow bug caused by missing statement. [Bug: 928]
-
- * generic/tclIOCmd.c:
- * generic/tclBasic.c: Objectified the "open" command. [Bug: 1113]
-
- * generic/tclPosixStr.c (Tcl_ErrnoId, Tcl_ErrnoMsg): When using
- egcs, ENOTSUP and EOPNOTSUPP are the same, so now we handle that
- case. [Bug: 1137]
-
- * library/init.tcl: Various small changes requested by Jan Nijtmans.
- - If the variable $tcl_library contains the empty string, this
- empty string will be put in $auto_path. This is not useful at all,
- it only slows down later package processing.
- - If the variable tcl_pkgPath is not set, the "unset __dir"
- fails. Thich makes init.tcl totally unusable. Better put a "catch"
- around it.
- - In the function tcl_findLibraries, the "string match" function
- only works correctly if $tcl_patchLevel is in one of the forms
- "?.?a?", "?.?b?" or "?.?.?". Could a "regexp" be used instead,
- then it allows anything to be appended to the patchLevel
- string. And it is more efficient.
- - The tclPkgSetup function assumes that if $type != "load" then
- the type must be "source". This needn't be true. Some users want
- to add their own setup types.
- [RFE: 1138] [Bug: 978]
-
- * win/tclWinReg.c:
- * doc/registry.n: Added support for HKEY_PERFORMANCE_DATA and
- HKEY_DYN_DATA keys. [Bug: 1109]
-
- * win/tclWinInit.c (TclPlatformInit): Added code to ensure
- tcl_pkgPath is set to "" when no registry entry is found. [Bug: 978]
-
-1999-02-01 <stanton@GASPODE>
+ * doc/tcltest.n:
+ * library/tcltest/tcltest.tcl:
+ * library/tcltest/pkgIndex.tcl:
+ * tests/tcltest.test: Implementation of TIP 85. Allows tcltest
+ users to add new legal values of the -match option to [test],
+ associating each with a Tcl command that does the matching of
+ expected results with actual results of tests. Thanks to
+ Arjen Markus. => tcltest 2.1 [Patch 521362]
- * generic/tclBasic.c:
- * generic/tclCmdAH.c:
- * generic/tclCmdIL.c:
- * generic/tclCmdMZ.c:
- * generic/tclExecute.c:
- * generic/tclHistory.c:
- * generic/tclIO.c:
- * generic/tclIOUtil.c:
- * generic/tclInterp.c:
- * generic/tclMain.c:
- * generic/tclNamesp.c:
- * generic/tclParse.c:
- * generic/tclProc.c:
- * generic/tclTest.c:
- * generic/tclTimer.c:
- * generic/tcl.h: Made eval interfaces compatible with 8.0 by
- renaming Tcl_EvalObj to Tcl_EvalObjEx, renaming Tcl_Eval2 to
- Tcl_EvalEx and restoring Tcl_EvalObj and Tcl_GlobalEvalObj
- interfaces so they match Tcl 8.0.
+2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
-1999-01-28 <stanton@GASPODE>
+ * doc/namespace.n: added description of [namepace forget]
+ behaviour for unqualified patterns [Bug 559268]
- * Merged Tcl 8.0.5b1 changes.
-
- * generic/tclUtil.c (Tcl_DStringSetLength): Changed so the buffer
- overallocates in a manner similar to Tcl_DStringAppend. This
- should improve performance for TclUniCharToUtfDString.
+2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
-1998-12-11 === Tcl 8.1b1 Release ===
+ * generic/tclExecute.c: reverting an accidental modification in
+ the last commit.
-1998-12-10 <stanton@GASPODE>
+2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
-2000-03-21 Syd Polk <spolk@cygnus.com>
+ * doc/Tcl.n: clarify the empty variable name issue ([Bug 549285]
+ reported by Tom Krehbiel, patch by Don Porter).
- * configure.in: Check for cygwin, not cygwin32.
- * configure: Regenerate.
+2002-05-31 Don Porter <dgp@users.sourceforge.net>
- * generic/tclInitScript.h: Added newline at end of file to make
- current gcc happy.
+ * library/package.tcl: Fixed leak of slave interp in [pkg_mkIndex].
+ Thanks to Helmut for report. [Bug 550534]
-1999-12-06 Mo DeJong <mdejong@cygnus.com>
+ * tests/io.test:
+ * tests/main.test: Use the "stdio" constraint to control whether
+ an [open "|[interpreter]"] is attempted.
+
+ * generic/tclExecute.c (TclMathInProgress,TclExecuteByteCode
+ ExprCallMathFunc):
+ * generic/tclInt.h (TclMathInProgress):
+ * unix/Makefile.in (tclMtherr.*):
+ * unix/configure.in (NEED_MATHERR):
+ * unix/tclAppInit.c (matherr):
+ * unix/tclMtherr.c (removed file):
+ * win/tclWinMtherr.c (_matherr): Removed internal routine
+ TclMathInProgress and Unix implementation of matherr(). These
+ are now obsolete, dealing with very old versions of the C math
+ library. Windows version is retained in case Borland compilers
+ require it, but it is inactive. Thanks to Joe English.
+ [Bug 474335, Patch 555635].
+ * unix/configure: regen
+
+2002-05-30 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclCompExpr.c:
+ * generic/tclCompile.c:
+ * generic/tclCompile.h: removed exprIsJustVarRef and
+ exprIsComparison from the ExprInfo and CompileEnv structs. These
+ were set, but not used since dec 1999 [Bug 562383].
+
+2002-05-30 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * generic/tclFileName.c (TclGlob): fix to longstanding
+ 'knownBug' in fileName tests 15.2-15.4, and fix to a new
+ Tcl 8.4 bug in certain uses of 'glob -tails'.
+ * tests/fileName.test: removed 'knownBug' flag from some tests,
+ added some new tests for above bugs.
+
+2002-05-29 Jeff Hobbs <jeffh@ActiveState.com>
- * win/Makefile.in: added cl flags needed for VC++ 6.0
+ * unix/configure: regen'ed
+ * unix/configure.in: replaced bigendian check with autoconf
+ standard AC_C_BIG_ENDIAN, which defined WORDS_BIGENDIAN on
+ bigendian systems.
+ * generic/tclUtf.c (Tcl_UniCharNcmp):
+ * generic/tclInt.h (TclUniCharNcmp): use WORDS_BIGENDIAN instead of
+ TCL_OPTIMIZE_UNICODE_COMPARE to enable memcmp alternative.
-1999-06-21 Syd Polk <spolk@cygnus.com>
+ * generic/tclExecute.c (TclExecuteByteCode INST_STR_CMP):
+ * generic/tclCmdMZ.c (Tcl_StringObjCmd): changed the case for
+ choosing the Tcl_UniCharNcmp compare to when both objs are of
+ StringType, as benchmarks show that is the optimal check (both
+ bigendian and littleendian systems).
- * generic/tclIO.c: Bug fixes from Scriptics to get exit status
- correct on pipe channels.
+2002-05-29 Don Porter <dgp@users.sourceforge.net>
-1999-04-22 Syd Polk <spolk@cygnus.com>
+ * generic/tclMain.c: Removed "dummy" reference to Tcl_LinkVar.
+ It is no longer needed since Tcl_Main() now actually calls
+ Tcl_LinkVar(). Thanks to Joe English for pointing that out.
- * unix/Makefile.in: Don't install tcl.h for install-libaries.
+2002-05-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1999-02-16 Syd Polk <spolk@cygnus.com>
-
- * win/configure.in: TCL_SRC_DIR needs to have forward slashes
- for the MS build.
- * win/configure: Regenerate.
- * win/tclWinInit.c: Stupid Visual C++ compiler has limit on
- number of characters in string constant.
+ * generic/tclExecute.c (TclExecuteByteCode):
+ * generic/tclCmdMZ.c (Tcl_StringObjCmd): Use the macro version.
+ * generic/tclInt.h (TclUniCharNcmp): Optimised still further with
+ a macro for use in sensitive places like tclExecute.c
-1999-02-11 Syd Polk <spolk@cygnus.com>
+ * generic/tclUtf.c (Tcl_UniCharNcmp): Use new flag to figure out
+ when we can use an optimal comparison scheme, and default to the
+ old scheme in other cases which is at least safe.
+ * unix/configure.in (TCL_OPTIMIZE_UNICODE_COMPARE): New optional
+ flag that indicates when we can use memcmp() to compare Unicode
+ strings (i.e. when the high-byte of a Tcl_UniChar precedes the
+ low-byte.)
- * generic/tclInitScript.h: The tclInit proc that Jim Ingham wrote
- blew MS's string buffer away, so I hacked the original in for the
- Microsoft build, which only SN is using anyway. Yuck.
+2002-05-29 Jeff Hobbs <jeffh@ActiveState.com>
-1999-02-08 Syd Polk <spolk@cygnus.com>
+ * generic/tclInt.decls:
+ * generic/tclIntDecls.h:
+ * generic/tclStubInit.c:
+ * generic/tclUtf.c: added TclpUtfNcmp2 private command that
+ mirrors Tcl_UtfNcmp, but takes n in bytes, not utf-8 chars. This
+ provides a faster alternative for comparing utf strings internally.
+ (Tcl_UniCharNcmp, Tcl_UniCharNcasecmp): removed the explicit end
+ of string check as it wasn't correct for the function (by doc and
+ logic).
+
+ * generic/tclCmdMZ.c (Tcl_StringObjCmd): reworked the string equal
+ comparison code to use TclpUtfNcmp2 as well as short-circuit for
+ equal objects or unequal length strings in the equal case.
+ Removed the use of goto and streamlined the other parts.
+
+ * generic/tclExecute.c (TclExecuteByteCode): added check for
+ object equality in the comparison instructions. Added
+ short-circuit for != length strings in INST_EQ, INST_NEQ and
+ INST_STR_CMP. Reworked INST_STR_CMP to use TclpUtfNcmp2 where
+ appropriate, and only use Tcl_UniCharNcmp when at least one of the
+ objects is a Unicode obj with no utf bytes.
+
+ * generic/tclCompCmds.c (TclCompileStringCmd): removed error
+ creation in code that no longer throws an error.
-<<<<<<< ChangeLog
- * unix/configure.in unix/tclConfig.sh.in: Export TCL_LIB_FULL_PATH
- for dependencies.
-=======
- * unix/configure.in: Fixed problem with test in --enable-symbols.
->>>>>>> 1.1.1.5
- * unix/configure: Regenerated.
- * library/auto.tcl: Fixed a problem with the regsub inside of
- auto_mkindex since the regsub semantics changed.
+ * tests/string.test:
+ * tests/stringComp.test: added more string comparison checks.
-1999-02-04 James Ingham <jingham@cygnus.com>
+ * tests/clock.test: better qualified 9.1 constraint check for %s.
- * generic/tclInitScript.h: Change the tclInit proc to find the Tcl
- library in both build & install trees.
- * library/auto.tcl (tcl_findLibrary): Change tcl_findLibrary to
- search around the executible for the tclConfig.sh, and then use
- this to find the source tree. This works in many more cases than
- the Scriptics version.
+2002-05-28 Jeff Hobbs <jeffh@ActiveState.com>
- * configure.in: If no value is given for --enable-symbols, use the
- value from AC_PROG_CC, this adds -g for gcc.
+ * generic/tclThreadAlloc.c (TclpRealloc, TclpFree): protect
+ against the case when NULL is based.
-<<<<<<< ChangeLog
- * library/init.tcl (auto_mkindex_parser::mkindex): Clean out the parser
- interpreter completely between each file, rather than
- trying to remove imports by hand. The latter method loses with
- IncrTcl, since that imports the class command by hand, and if you
- ever do "namespace import itcl::*" in your code, this will get
- undone.
-=======
-1999-01-19 Ben Elliston <bje@cygnus.com>
->>>>>>> 1.1.1.5
+ * tests/clock.test: added clock-9.1
+ * compat/strftime.c:
+ * generic/tclClock.c:
+ * generic/tclInt.decls:
+ * generic/tclIntDecls.h:
+ * unix/tclUnixTime.c: fix for Windows msvcrt mem leak caused by
+ using an env(TZ) setting trick for in clock format -gmt 1. This
+ also makes %s seem to work correctly with -gmt 1 as well as
+ making it a lot faster by avoid the env(TZ) hack. TclpStrftime
+ now takes useGMT as an arg. [Bug #559376]
- * tools/encoding/shiftjis.txt: Map tilde in ShiftJIS to tilde in
- Unicode.
+2002-05-28 Vince Darley <vincentdarley@users.sourceforge.net>
- * library/encoding/shiftjis.enc: Regenerate.
+ * generic/tclIOUtil.c: fixes to Tcl_FSLoadFile when called on
+ a file inside a vfs. This should avoid leaving temporary
+ files sitting around on exit. [Bug #545579]
+
+2002-05-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ * win/tclWinError.c: Added comment on conversion of
+ ERROR_NEGATIVE_SEEK because that is a mapping that really belongs,
+ and not a catch-all case.
+ * win/tclWinPort.h (EOVERFLOW): Should be either EFBIG or EINVAL
+ * generic/tclPosixStr.c (Tcl_ErrnoId, Tcl_ErrnoMsg): EOVERFLOW can
+ potentially be a synonym for EINVAL.
+
+2002-05-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ === Changes due to TIP#91 ===
+
+ * win/tclWinPort.h: Added declaration of EOVERFLOW.
+ * doc/CrtChannel.3: Added documentation of wideSeekProc.
+ * generic/tclIOGT.c (TransformSeekProc, TransformWideSeekProc):
+ Adapted to use the new channel mechanism.
+ * unix/tclUnixChan.c (FileSeekProc, FileWideSeekProc): Renamed
+ FileSeekProc to FileWideSeekProc and created new FileSeekProc
+ which has the old-style interface and which errors out with
+ EOVERFLOW when the returned file position can't fit into the
+ return type (int for historical reasons.)
+ * win/tclWinChan.c (FileSeekProc, FileWideSeekProc): Renamed
+ FileSeekProc to FileWideSeekProc and created new FileSeekProc
+ which has the old-style interface and which errors out with
+ EOVERFLOW when the returned file position can't fit into the
+ return type (int for historical reasons.)
+ * mac/tclMacChan.c (FileSeek): Reverted to old interface; Macs
+ lack large-file support because I can't see how to add it.
+ * generic/tclIO.c (Tcl_Seek, Tcl_Tell): Given these functions
+ knowledge of the new arrangement of channel types.
+ (Tcl_ChannelVersion): Added recognition of new version code.
+ (HaveVersion): New function to do version checking.
+ (Tcl_ChannelBlockModeProc, Tcl_ChannelFlushProc)
+ (Tcl_ChannelHandlerProc): Made these functions use HaveVersion for
+ ease of future maintainability.
+ (Tcl_ChannelBlockModeProc): Obvious lookup function.
+ * generic/tcl.h (Tcl_ChannelType): New wideSeekProc field, and
+ seekProc type restored to old interpretation.
+ (TCL_CHANNEL_VERSION_3): New channel version.
+
+2002-05-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tests/winPipe.test: Applied patch for SF Tcl Bug #549617. Patch
+ and bug report by Kevin Kenny <kennykb@users.sourceforge.net>.
-1998-12-21 Syd Polk <spolk@cygnus.com>
+ * win/tclWinSock.c (TcpWatchProc): Fixed SF Tcl Bug #557878. We
+ are not allowed to mess with the watch mask if the socket is a
+ server socket. I believe that the original reporter is George
+ Peter Staplin.
- * generic/tclCompExpr.c: Remove another instance of string
- blasting.
+2002-05-21 Mo DeJong <mdejong@users.sourceforge.net>
- * generic/tclLiteral.c (TclDeleteLiteralTable): Make code
- that detects infinite loops exit gracefully in production
- build and panic in development build.
+ * unix/configure: Regen.
+ * unix/configure.in: Invoke SC_ENABLE_SHARED before
+ calling SC_CONFIG_CFLAGS so that the SHARED_BUILD
+ variable can be checked inside SC_CONFIG_CFLAGS.
+ * unix/tcl.m4 (SC_CONFIG_CFLAGS): Pass -non_shared
+ instead of -shared to ld when configured with
+ --disable-shared under OSF. [Tcl bug 540390]
-1998-12-21 Khamis Abuelkomboz <khamis@cygnus.com>
+2002-05-20 Daniel Steffen <das@users.sourceforge.net>
- * generic/tclLiteral.c (TclDeleteLiteralTable): added a daemon to catch
- a hanging bug by deleteing a literal.
+ * generic/tclInt.h: added prototype for TclpFilesystemPathType().
+ * mac/tclMacChan.c: use MSL provided creator type if available
+ instead of the default 'MPW '.
-1998-12-19 Syd Polk <spolk@cygnus.com>
+2002-05-16 Joe English <jenglish@users.sf.net>
- * generic/tclCompile.c (tclCompileScript): Localize modifying
- the compiled string to the call which needs it. This prevents
- the string getting hashed incorrectly later.
+ * doc/CrtObjCmd.3:
+ Added Tcl_GetCommandFromObj, Tcl_GetCommandFullName
+ (Tcl Bug #547987, #414921)
- * generic/tclAlloc.c: Latest patch from Scriptics.
+2002-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1998-12-16 Syd Polk <spolk@cygnus.com>
+ * unix/tclUnixChan.c (TtyOutputProc): #if/#endif-ed this function
+ out to stop compiler warnings. Also much general tidying of
+ comments in this file and removal of whitespace from blank lines.
- * tools/encoding/shiftjis.txt: Unicode character 0xFF5E
- was missing from the shiftjis table.
- * library/encoding/shiftjis.enc: Regnerated.
+2002-05-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1998-12-16 Ben Elliston <bje@sanguine.cygnus.com>
+ * unix/tclUnixChan.c (SETBREAK): Solaris thinks ioctl() takes a
+ signed second argument, and Linux thinks ioctl() takes an unsigned
+ second argument. So need a longer definition of this macro to get
+ neither to spew warnings...
- * generic/tclBasic.c (builtInCmds): Add `encoding'. Patch from
- Scriptics.
+2002-05-13 Vince Darley <vincentdarley@users.sourceforge.net>
- * generic/tclCmdAH.c (Tcl_EncodingObjCmd): New function. Patch
- from Scriptics.
+ * generic/tclEvent.c:
+ * generic/tclIOUtil.c:
+ * generic/tclInt.h: clean up all memory allocated by the
+ filesystem, via introduction of 'TclFinalizeFilesystem'.
+ Move TclFinalizeLoad into TclFinalizeFilesystem so we can
+ be sure it is called at just the right time.
+ Fix bad comment also. [Bug #555078 and 'fs' part of #543549]
+ * win/tclWinChan.c: fix comment referring to wrong function.
+
+2002-05-10 Don Porter <dgp@users.sourceforge.net>
- * generic/tclEncoding.c: Changed at the same time as the rest of
- these files, so it might be important. Patch from Scriptics.
+ * tests/load.test:
+ * tests/safe.test:
+ * tests/tcltest.test: Corrected some list-quoting issues and
+ other matters that cause tests to fail when the patch includes
+ special characters. Report from Vince Darley. [Bug 554068].
- * doc/encoding.n: New file. From Scriptics.
+2002-05-08 David Gravereaux <davygrvy@pobox.com>
-1998-12-03 Syd Polk <spolk@cygnus.com>
+ * doc/file.n:
+ * tools/man2tcl.c:
+ * tools/man2help2.tcl: Thanks to Peter Spjuth
+ <peter.spjuth@space.se>, again. My prior fix for
+ single-quote macro mis-understanding was wrong. Reverted to
+ reimpliment the 'macro2' proc which handles single-quote macros
+ and restored file.n text arrangement to avoid single-quotes on
+ the first line. Sorry for all the confusion.
- * generic/tclIO.c: Integrated more complete fix to
- channel problem from Scott Stanton at Scriptics.
+2002-05-08 David Gravereaux <davygrvy@pobox.com>
-1998-12-02 Syd Polk <spolk@cygnus.com>
+ * tools/man2tcl.c:
+ * tools/man2help2.tcl: Proper source of macro error mis-
+ understanding single-quote as the leading macro command found
+ and repaired.
- * generic/tclIO.c: Fixed problem when writing out to a
- channel set to -crlf translations.
+ * doc/file.n: Reverted to prior state before I messed with
+ it.
-1998-12-02 Ian Roxborough <irox@cygnus.com>
+2002-05-08 Don Porter <dgp@users.sourceforge.net>
- * win/tclWinChan.c: Merged in WishCon0.1 Changes to
- support pipe IO at console level of a WishShell.
+ * library/tcltest/tcltest.tcl: Corrected [uplevel] quoting when
+ [source]-ing test script in subdirectories.
+ * tests/fileName.test:
+ * tests/load.test:
+ * tests/main.test:
+ * tests/tcltest.test:
+ * tests/unixInit.test: Fixes to test suite when there's a space
+ in the working path. Thanks to Kevin Kenny.
-1998-11-24 Syd Polk <spolk@cygnus.com>
+2002-05-07 David Gravereaux <davygrvy@pobox.com>
- * win/Makefile.in: Under MSVC, use the Tcl dumpexts method
- to generate exports.
- * win/tclWinPort.h tclWinSock.c: Do not #define PASCAL away.
- It is needed in calls to DLLs.
+ -- Changes from Peter Spjuth <peter.spjuth@space.se>
+ * tools/man2tcl.c: Increased line buffer size and a bail-out if
+ that should ever be over-run.
+ * tools/man2help.tcl: Include Courier New font in rtf header.
+ * tools/man2help2.tcl: Improved handling of CS/CE fields. Use
+ Courier New for code samples and indent better.
-1998-11-18 Syd Polk <spolk@cygnus.com>
+ * doc/file.n:
+ * doc/TraceCmd.3: winhelp conversion tools where understanding
+ a ' as the first character on a line to be an unknown macro.
+ Not knowing how to repair tools/man2tcl.c, I decided to rearrange
+ the text in the docs instead.
- * generic/tclAlloc.c: Made sure that blocks are allocated on
- eight-byte boundaries.
- * unix/tclUnixPort.h: Added a CYGNUS LOCAL comment.
+2002-05-07 Vince Darley <vincentdarley@users.sourceforge.net>
-1998-11-09 Ben Elliston <bje@cygnus.com>
+ * generic/tclFileName.c: fix to similar segfault when using
+ 'glob -types nonsense -dir dirname -join * *'. [Bug 553320]
+
+ * doc/FileSystem.3: further documentation on vfs.
+ * tests/cmdAH.test:
+ * tests/fileSystem.test:
+ * tests/pkgMkindex.test: Fix to testsuite bugs when running out
+ of directory whose name contains '{' or '['.
+
+2002-05-07 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * tests/basic.test: Fix for [Bug 549607]
+ * tests/encoding.test: Fix for [Bug 549610]
+ These are testsuite bugs that caused failures when the filename
+ contained spaces. Report & fix by Kevin Kenny.
+
+2002-05-02 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * generic/tclFileName.c: fix to freeing a bad object
+ (i.e. segfault) when using 'glob -types nonsense -dir dirname'.
+ * generic/tclWinFile.c: fix to [Bug 551306], also wrapped some
+ long lines.
+ * tests/fileName.test: added several tests for the above bugs.
+ * doc/FileSystem.3: clarified documentation on refCount
+ requirements of the object returned by the path type function.
+ * generic/tclIOUtil.c:
+ * win/tclWinFile.c:
+ * unix/tclUnixFile.c:
+ * mac/tclMacFile.c: moved TclpFilesystemPathType to the
+ platform specific directories, so we can add missing platform-
+ specific implementations. On Windows, 'file system' now returns
+ useful results like "native NTFS", "native FAT" for that system.
+ Unix and MacOS still only return "native".
+ * doc/file.n: clarified documentation.
+ * tests/winFile.test: test for 'file system' returning correct
+ values.
+ * tests/fileSystem.test: test for 'file system' returning correct
+ values. Clean up after failed previous test run.
+
+2002-04-26 Jeff Hobbs <jeffh@ActiveState.com>
- * generic/tclVar.c (TclGetIndexedScalar): Fix a general problem
- with compiled local variables that are upvar'ed. Contributed by
- Scott Stanton <stanton@scriptics.com>.
+ * unix/configure:
+ * unix/tcl.m4: change HP-11 SHLIB_LD_LIBS from "" to ${LIBS} so
+ that the .sl knows its dependent libs.
-1998-11-04 Ian Roxborough <irox@cygnus.com>
-
- * win/tclWinPort.h: #endif in the wrong place and missing ')'.
+2002-04-26 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1998-11-06 Syd Polk <spolk@cygnus.com>
+ * tests/obj.test (obj-11.[56]): Test conversion to boolean more
+ thoroughly.
+ * generic/tclObj.c (SetBooleanFromAny): Was not calling an integer
+ parsing function on native 64-bit platforms! [Bug 548686]
- * win/tclWinPort.h: Updated from Scriptics. Tcl_Realloc no longer
- fails with blocks that are more than 64K.
+2002-04-24 Jeff Hobbs <jeffh@ActiveState.com>
-1998-11-04 Ian Roxborough <irox@cygnus.com>
+ * generic/tclInt.h: corrected TclRememberJoinableThread decl to
+ use VOID instead of void.
+ * generic/tclThreadJoin.c: noted that this code isn't needed on Unix.
- * generic/panic.c (panic): Removed a #define _DEBUG,
- under MSVC if you want an exception Breakpoint instead
- of a panic dialog, CFLAGS must contain -D_DEBUG.
+2002-04-23 Jeff Hobbs <jeffh@ActiveState.com>
-1998-11-03 Ian Roxborough <irox@cygnus.com>
+ * doc/exec.n:
+ * doc/tclvars.n: doc updates [Patch #509426] (gravereaux)
- * generic/panic.c (panic): If compiling with Microsoft, have this
- generate an exception Breakpoint.
+2002-04-24 Daniel Steffen <das@users.sourceforge.net>
-1998-11-03 Syd Polk <spolk@cygnus.com>
+ * mac/tclMacResource.r: added check of
+ TCLTK_NO_LIBRARY_TEXT_RESOURCES #define to allow disabling the
+ inclusion of the tcl library code in the resource fork of Tcl
+ executables and shared libraries.
- * generic/panic.c: If compiling with Microsoft, have this generate
- a core dump so that we can actually see where it is happening when
- we have co stdout/stderr.
+2002-04-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1998-10-29 Syd Polk <spolk@cygnus.com>
+ * doc/TraceCmd.3: New file that documents Tcl_CommandTraceInfo,
+ Tcl_TraceCommand and Tcl_UntraceCommand [Bug 414927]
- * win/configure.in: Removed check for caddr_t. This configure.in
- is not really ready for autoheader and the other garbage.
- * win/configure: Regenerated.
- * generic/tclAlloc.c: Put declaration of caddr_t inside of
- #ifdef _MSC_VER. It appears that this is the only compiler that
- is missing this typedef.
+2002-04-22 Jeff Hobbs <jeffh@ActiveState.com>
-1998-10-29 Syd Polk <spolk@cygnus.com>
+ * generic/tclAlloc.c:
+ * generic/tclInt.h:
+ * generic/tclThreadAlloc.c (new):
+ * unix/Makefile.in:
+ * unix/tclUnixThrd.c:
+ * win/Makefile.in:
+ * win/tclWinInt.h:
+ * win/tclWinThrd.c: added new threaded allocator contributed by
+ AOL that significantly reduces lock contention when multiple
+ threads are in use. Only Windows and Unix implementations are
+ ready, and the Windows one may need work. It is only used by
+ default on Unix for now, and requires that USE_THREAD_ALLOC be
+ defined (--enable-threads on Unix will define this).
- * win/Makefile.in: The directory for encodings is called 'encoding',
- not 'encodings'.
+ * generic/tclIOUtil.c (Tcl_FSRegister, Tcl_FSUnregister):
+ corrected calling of Tcl_ConditionWait to ensure that there would
+ be a condition to wait upon.
-1998-10-29 Syd Polk <spolk@cygnus.com>
+ * generic/tclCmdAH.c (Tcl_FileObjCmd): added cast in FILE_SIZE.
- * unix/configure.in: Fix merge problem with socket libraries. Run
- autoconf test for caddr_t.
- * unix/configure: Regenerate.
- * win/configure.in Run autoconf test for caddr_t.
- * win/configure: Regnerate.
- * generic/tclAlloc.c: Remove declaration of caddr_t. Should be
- provided by configure now.
+ * win/tclWinFCmd.c (DoDeleteFile): check return of setattr API
+ calls in file deletion for correct Win32 API handling.
-1998-10-28 Syd Polk <spolk@cygnus.com>
+ * win/Makefile.in: correct dependencies for shell, gdb, runtest
+ targets.
- * unix/Makefile.in: Install encodings from make install.
- * win/Makefile.in: Install encodings from make install.
+ * doc/clock.n:
+ * compat/strftime.c (_fmt): change strftime to correctly handle
+ localized %c, %x and %X on Windows. Added some notes about how
+ the other values could be further localized.
-1998-10-28 Ben Elliston <bje@cygnus.com>
+2002-04-19 Don Porter <dgp@users.sourceforge.net>
- * win/configure.in (TCL_BUILD_INCLUDES): Remove. Do not subst.
- * win/configure: Regenerate.
+ * generic/tclMain.c (Tcl_Main): Free the memory allocated for the
+ startup script path. [Bug 543549]
-1998-10-26 Syd Polk <spolk@cygnus.com>
+ * library/msgcat/msgcat.tcl: [mcmax] wasn't using the caller's
+ namespace when determining the max translated length. Also
+ made revisions for better use of namespace variables and more
+ efficient [uplevel]s.
- * win/Makefile.in: Fix references to old opt0.1 library.
+ * doc/msgcat.n:
+ * library/msgcat/msgcat.tcl:
+ * library/msgcat/pkgIndex.tcl: Added [mcload] to the export list
+ of msgcat; bumped to 1.2.3. [Bug 544727]
-1998-10-20 Syd Polk <spolk@cygnus.com>
+2002-04-20 Daniel Steffen <das@users.sourceforge.net>
- * unix/Makefile.in: Fix references to old opt0.1 library.
+ * generic/tclInt.decls:
+ * generic/tclIntPlatDecls.h:
+ * generic/tclStubInit.c:
+ * mac/tclMacFCmd.c:
+ * mac/tclMacFile.c:
+ * mac/tclMacUtil.c: Modified TclpObjNormalizePath to be alias
+ file aware, and replaced various calls to FSpLocationFrom*Path
+ by calls to new alias file aware versions FSpLLocationFrom*Path.
+ The alias file aware routines don't resolve the last component of
+ a path if it is an alias. This allows [file copy/delete] etc. to
+ act correctly on alias files. (c.f. discussion in Bug #511666)
-1998-10-19 Ben Elliston <bje@cygnus.com>
+2002-04-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * unix/configure.in: Compute a value for @TCL_BUILD_INCLUDES@.
+ * tests/lindex.test (lindex-3.7):
+ * generic/tclUtil.c (TclGetIntForIndex): Stopped indexes from
+ hitting wide ints. [Bug #526717]
- * unix/configure: Regenerate.
+2002-04-18 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/tclConfig.sh.in (TCL_BUILD_INCLUDES): Set.
-
- * win/configure.in: Compute a value for @TCL_BUILD_INCLUDES@.
+ * generic/tclNamesp.c:
+ * tests/info.test: [Bug 545325] info level didn't report
+ namespace eval, bug report by Richard Suchenwirth.
- * win/configure: Regenerate.
+2002-04-18 Don Porter <dgp@users.sourceforge.net>
-1998-10-14 Syd Polk <spolk@cygnus.com>
+ * doc/subst.n: Clarified documentation on handling unusual return
+ codes during substitution, and on variable substitutions implied
+ by command substitution, and vice versa. [Bug 536838]
- * win/configure.in Makefile.in: More fixes for the tcl8.l build
- * win/configure: Regenerated
+2002-04-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-1998-10-14 Syd Polk <spolk@cygnus.com>
+ * generic/tclCmdIL.c (InfoBodyCmd):
+ * tests/info.test (info-2.6): Proc bodies without string reps
+ would report as empty [Bug #545644]
- * generic/tclCmdIL.c (SortCompare}: Support as much of the old
- comparison semantics as possible. It is now possible to do
- lsort -command {foo bar} {1 3 45}.
- * tests/cmdIL.test (cmdIL-3.16}: Restore test.
+ * generic/tclCmdMZ.c (Tcl_SubstObj): More clarification for
+ comment on behaviour when substitutions are not well-formed,
+ prompted by [Bug #536831]; alas, removing the ill-defined
+ behaviour is a lot of work.
-1998-10-08 Syd Polk <spolk@cygnus.com>
+2002-04-18 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclCmdIL.c (SortCompare): Make the comparison callback
- object based for performance.
- * tests/cmdIL.test (cmdIL-3.16): Test relied on incorrect behavior
- of old string based comparison callback, which was a bug. Corrected
- test.
- * unix/configure.in: Minor fixes for gcc
- * unix/configure: Regenerated
- * unix/dltest/configure.in: GCC needs -f writeable-strings
- * unix/dltest/Makefile.in: Fixed invalid TCL_CFLAGS reference
- * unix/dltest/configure: Regenerated.
+ * generic/tclExecute.c:
+ * tests/expr-old.test: fix for [Bug #542588] (Phil Ehrens), where
+ "too large integers" were reported as "floating-point value" in
+ [expr] error messages.
-1998-10-01 Ben Elliston <bje@cygnus.com>
+2002-04-17 Jeff Hobbs <jeffh@ActiveState.com>
- * generic/tclCmdIL.c (InfoEncodingsCmd): New function. Implement a
- Tcl ``info encodings'' command.
- (Tcl_InfoObjCmd): Detect ``encodings'' subcommand.
+ * generic/tclEncoding.c (EscapeFromUtfProc):
+ * generic/tclIO.c (WriteChars, Tcl_Close): corrected the handling
+ of outputting end escapes for escape-based encodings.
+ [Bug #526524] (yamamoto)
- * doc/info.n: Update documentation.
-
-1998-09-29 Syd Polk <spolk@cygnus.com>
+2002-04-17 Don Porter <dgp@users.sourceforge.net>
- * win/Makefile.in: Still some hard-coded references to 8.0.
- Fix problems with try and except
- * win/configure.in: Likewise
- * win/configure: Regenerated
- * win/tclWin32Dll.c: try and except not supported under gcc.
+ * doc/tcltest.n: Removed [saveState] and [restoreState] from
+ tcltest 2 documentation, effectively deprecating them. [Bug 495660]
+ * library/tcltest/tcltest.tcl: Made separate export for commands
+ kept only for tcltest 1 compatibility.
-1998-09-28 Syd Polk <spolk@cygnus.com>
-
- * generic/tclClock.c: timezone needs to be declared somewhere
- * win/Makefile.in: Fixed OBJEXT problems
- * win/tclWinFile.c win/tclWinInit.c: Fixed merge problems
- * win/tclWinPipe.c: Removed Cygnus thread stuff to use the tcl 8.1
- thread stuff instead.
+ * tests/iogt.test: Revised to run tests in a namespace, rather than
+ use the useless and buggy [saveState] and [restoreState] commands
+ of tcltest. Updated to use tcltest 2 as well. [Patch 544911]
-1998-09-28 Syd Polk <spolk@cygnus.com>
+2002-04-16 Don Porter <dgp@users.sourceforge.net>
- * win/configure.in: Merged from 4.2 branch
- * win/configure: Regenerated
- * win/Makefile.in: Updated for tcl8.1.
+ * tests/io.test: Revised to run tests in a namespace, rather than
+ use the useless and buggy [saveState] and [restoreState] commands
+ of tcltest. Updated to use tcltest 2 as well. [Patch 544546]
-Wed Aut 19 17:48:00 PDT 1998 Syd Polk <spolk@cygnus.com>
+2002-04-15 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclProc.c:
+ * tests/proc-old.test: Improved stack trace for TCL_BREAK and
+ TCL_CONTINUE returns from procs. Patch by Don Porter
+ [Bug 536955].
- * 8.1 integration continues.
+ * generic/tclExecute.c:
+ * tests/compile.test: made bytecodes check for a catch before
+ returning; the compiled [return] is otherwise non-catchable.
+ [Bug 542142] reported by Andreas Kupries.
+
+2002-04-15 Don Porter <dgp@users.sourceforge.net>
-Thu Apr 30 18:10:15 1998 Geoffrey Noer <noer@cygnus.com>
+ * tests/socket.test: Increased timeout values so that tests have
+ time to successfully complete even on slow/busy machines. [Bug 523470]
- * win/Makefile.in: invoke gcc instead of ld when producing
- dlls. Pass the linker options down via args to -Wl options.
+ * doc/tcltest.n:
+ * library/tcltest/tcltest.tcl:
+ * tests/tcltest.test: Revised [tcltest::test] to return errors
+ when called with invalid syntax and to accept exactly two arguments
+ as documented. Improved error messages. [Bug 497446, Patch 513983]
+ ***POTENTIAL INCOMPATIBILITY***: Incompatible with previous
+ tcltest 2.* releases, found only in alpha releases of Tcl 8.4.
+
+2002-04-11 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * generic/tclNotify.c (TclFinalizeNotifier): remove remaining
+ unserviced events on finalization.
+
+ * win/tcl.m4: Enabled COFF as well as CV style debug info with
+ --enable-symbols to allow Dr. Watson users to see function info.
+ More info on debugging levels can be obtained at:
+ http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp
+
+ * tests/ioCmd.test: fixed iocmd-8.15 to have mac and unixPc variants.
+
+ * generic/tclParse.c (Tcl_ParseVar): conditionally incr obj
+ refcount to prevent possible mem leak.
+
+2002-04-08 Daniel Steffen <das@users.sourceforge.net>
+
+ * generic/tcl.h: no <sys/types.h> on mac.
+ * mac/tclMacFile.c: minor fixes to Vince's changes from 03-24.
+ * mac/tclMacOSA.c:
+ * mac/tclMacResource.c: added missing Tcl_UtfToExternalDString
+ conversions of resource file names.
+ * mac/tclMacSock.c (TcpGetOptionProc): fixed bug introduced
+ by Andreas on 02-25; changed strcmp's to strncmp's so that
+ option comparison behaves like on other platforms.
+ * mac/tcltkMacBuildSupport.sea.hqx (CW Pro6 changes): added
+ support to allow Tk to hookup C library stderr/stdout to TkConsole.
+ * tests/basic.test:
+ * tests/cmdAH.test:
+ * tests/encoding.test:
+ * tests/fileSystem.test:
+ * tests/ioCmd.test: fixed tests failing on mac: check for
+ existence of [exec], changed some result strings.
-Mon Apr 20 11:40:23 MEST 1998 Khamis Abuelkomboz <khamis@cygnus.com>
- *tcl/win tclWinPipe.c
- (PipeWatchProc): Mask PipeThread using (LPTHREAD_START_ROUTINE) to
- remind bogus messages.
+2002-04-06 Jeff Hobbs <jeffh@ActiveState.com>
-Tue Apr 7 16:36:49 1998 Ian Lance Taylor <ian@cygnus.com>
+ * unix/tclUnixFCmd.c (Realpath): added a little extra code to
+ initialize a realpath arg when compiling in PURIFY mode in order
+ to prevent spurious purify warnings. We should really create our
+ own realpath implementation, but this will at least quiet purify
+ for now.
- * win/tclWinFile.c: If __CYGWIN32__, call chdir rather than
- SetCurrentDirectory, so that the cygwin32 DLL knows the current
- directory when doing path munging.
+2002-04-05 Don Porter <dgp@users.sourceforge.net>
-Sat Mar 21 21:18:06 1998 Elena Zannoni <ezannoni@kwikemart.cygnus.com>
-
- Merged changes from Foundry (list follows in reverse chronological
- order)
+ * generic/tclCmdMZ.c (Tcl_SubstObj):
+ * tests/subst.test: Corrected [subst] so that return codes
+ TCL_BREAK and TCL_CONTINUE returned by variable substitution
+ have the same effect as when those codes are returned by command
+ substitution. [Bug 536879]
- - Tom Tromey <tromey@cygnus.com>
- * library/init.tcl (auto_execok): If ide_cygwin_path command is
- defined, the convert PATH environment variable to Win32 path list
- before use.
- * win/stub16.c: Include <string.h>.
- * win/tclWinInit.c (TclPlatformInit): Don't look in registry to
- find default tcl_library setting.
+2002-04-03 Jeff Hobbs <jeffh@ActiveState.com>
- - Ian Lance Taylor <ian@cygnus.com>
- * win/Makefile.in ($(TCLDLL)): Don't generate relocs for debugging
- information.
- ($(TCLPLUGINDLL), $(TCLREGDLL)): Likewise.
- * generic/tclIOUtil.c (Tcl_EvalFile): Put the newly allocated
- buffer into an object and use Tcl_EvalObj, rather than having
- Tcl_Eval copy the buffer.
- * generic/tclEnv.c (TclSetEnv): Don't set the env array if the
- value is the same as the one we are trying to set.
-
-Sat Feb 21 08:59:00 1998 Chris Provenzano <proven@cygnus.com>
+ * library/tcltest/tcltest.tcl: added getMatchingFiles back (alias
+ to GetMatchingFiles), which was a public function in tcltest 1.0.
- * Makefile.in, unix/Makefile.in
- Don't set shell to /bin/sh. Set it to @SHELL@
+2002-04-01 Vince Darley <vincentdarley@users.sourceforge.net>
- * configure: Regenerated with support for @SHELL@ substitution
+ * generic/tclEnv.c:
+ * generic/tclIOUtil.c: invalidate filesystem cache when the
+ user changes env(HOME). Fixes [Bug #535621]. Also cleaned up
+ some of the documentation.
+ * tests/fileSystem.test: added test for bug just fixed.
+
+2002-04-01 Kevin Kenny <kennykb@acm.org>
-Mon Feb 9 16:02:47 1998 Ian Lance Taylor <ian@cygnus.com>
+ * win/tclWinTime.c (Tcl_GetTime): made the checks of clock
+ frequency more permissive to cope with the fact that Win98SE
+ is observed to return 1.19318 in place of 1.193182 for the
+ performance counter frequency.
+
+2002-03-29 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * generic/tclCmdMZ.c (Tcl_TraceObjCmd, TraceVarProc)
+ (TraceCommandProc, TclTraceCommandObjCmd): corrected
+ potential double-free of traces on variables by flagging in
+ Trace*Proc that it will free the var in case the eval wants to
+ delete the var trace as well. [Bug #536937]
+ Also converted Tcl_UntraceVar -> Tcl_UntraceVar2 and Tcl_Eval to
+ Tcl_EvalEx in Trace*Proc for slight efficiency improvement.
+
+2002-03-29 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/AllowExc.3:
+ * generic/tclBasic.c (Tcl_EvalObjv,Tcl_EvalEx,Tcl_EvalObjEx):
+ * generic/tclCompile.h (TclCompEvalObj):
+ * generic/tclExecute.c (TclCompEvalObj,TclExecuteByteCode):
+ * tests/basic.test: Corrected problems with Tcl_AllowExceptions
+ having influence over the wrong scope of Tcl_*Eval* calls. Patch
+ from Miguel Sofer. Report from Jean-Claude Wippler. [Bug 219181]
+
+2002-03-28 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclVar.c: Refactored CallTraces to collect repeated
+ handling of its returned value into CallTraces itself.
+
+2002-03-28 David Gravereaux <davygrvy@pobox.com>
+
+ * tools/feather.bmp:
+ * tools/man2help.tcl:
+ * tools/man2help2.tcl:
+ * win/makefile.vc: More winhelp target fixups. Added a feather
+ bitmap to the non-scrollable area and changed the color to be
+ yellow from a plain white. The colors can be whatever we want
+ them to be, but thought I would start with something bold.
+ [Bug 527941]
- * win/configure.in: Call AC_PROG_RANLIB so that TCL_RANLIB gets
- set correctly in tclConfig.sh.
- * win/configure: Rebuild.
+ * doc/SetVar.3:
+ * doc/TraceVar.3:
+ * doc/UpVar.3: .AP macro syntax repair.
-Tue Jan 20 19:24:22 1998 Ian Lance Taylor <ian@cygnus.com>
+2002-03-27 David Gravereaux <davygrvy@pobox.com>
- * win/tclWinChan.c (TclGetDefaultStdChannel): Check for error
- return from Tcl_MakeFileChannel.
+ * tools/man2help.tcl:
+ * win/makefile.vc: winhelp target now copies all needed files
+ from tools/ to a workarea under $(OUT_DIR) and builds it from
+ there. No build cruft is left in tools/ anymore. All paths
+ used in man2help.tcl are now relative to where the script is.
+ [Bug 527941]
-Tue Dec 23 16:25:02 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-27 David Gravereaux <davygrvy@pobox.com>
- * win/Makefile.in ($(TCLDLL)): Don't generate relocs for debugging
- information.
- ($(TCLPLUGINDLL), $(TCLREGDLL)): Likewise.
+ * win/.cvsignore:
+ * win/buildall.vc.bat:
+ * win/coffbase.txt:
+ * win/makefile.vc:
+ * win/nmakehlp.c (new):
+ * win/rules.vc: First draft fix for [Bug 527941]. More changes
+ need to done to the makehelp target to get to stop leaving build
+ files in the tools/ directory. This does not address the syntax
+ errors in the man files. Having the contents of tcl.hpj(.in)
+ inside makefile.vc allows for version numbers to be replaced with
+ macros.
+
+ The new nmakehlp.c is built by rules.vc in preprocessing and removes
+ the need to use tricky shell syntax that wasn't compatible on Win9x
+ systems. Clean targets made Win9x complient. This is a first draft
+ repair for [Bug 533862].
-Wed Nov 5 00:50:32 1997 Martin M. Hunt <hunt@cygnus.com>
+2002-03-28 Miguel Sofer <msofer@users.sourceforge.net>
- * library/word.tcl: Always use Motif-style selections.
+ * generic/tclBasic.c (Tcl_EvalEx): passing the correct commandSize
+ to TclEvalObjvInternal. [Bug 219362], fix by David Knoll.
-Tue Oct 28 17:44:15 1997 Martin M. Hunt <hunt@cygnus.com>
+2002-03-28 Miguel Sofer <msofer@users.sourceforge.net>
- * win/tclWinChan.c (Tcl_OpenFileChannel): Patch "winchan.txt"
- from net. Fixes problems with PC-NFS access.
+ * generic/tclBasic.c (Tcl_EvalEx):
+ * tests/basic.test: avoid exceptional returns at level 0
+ [Bug 219181]
- * win/tclWinSock.c (Tcl_GetHostName): Fix problem where
- [info hostname] crashes on NT 4.0 machines that do not have
- networking installed. Patch from Darrel Schneider
- <darrel@gemstone.com>
+2002-03-27 Don Porter <dgp@users.sourceforge.net>
-Tue Oct 28 16:31:46 1997 Ian Lance Taylor <ian@cygnus.com>
+ * doc/tcltest.n ([mainThread]):
+ * library/tcltest/tcltest.tcl:
+ * tests/tcltest.test: Major code cleanup to deal with whitespace,
+ coding conventions, and namespace issues, with several minor bugs
+ fixed in the process.
- * Makefile.in (install-minimal): New target.
- * win/Makefile.in (install-minimal): New target.
+ * tests/main.test: Added missing [after cancel]s.
-Wed Oct 15 18:58:32 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-25 Don Porter <dgp@users.sourceforge.net>
- * win/tclWinPort.h: If __CYGWIN32__, define TclpAlloc, TclpFree,
- and TclpRealloc rather than TclpSysAlloc, TclpSysFree, and
- TclpSysRealloc.
- * win/Makefile.in (TCLOBJS): Remove tclAlloc.o.
+ * tests/main.test: Removed workarounds for Bug 495977.
-Thu Sep 25 02:57:00 1997 Martin M. Hunt <hunt@cygnus.com>
+ * library/tcltest/tcltest.tcl: Keep the value of $::auto_path
+ unchanged, so that the tcltest package can test code that depends
+ on auto-loading. If a testing application needs $::auto_path pruned,
+ it should do that itself. [Bug 495726]
+ Improve the processing of the -constraints option to [test] so that
+ constraint lists can have arbitrary whitespace, and non-lists don't
+ blow things up. [Bug 495977]
+ Corrected faulty variable initialization. [Bug 534845]
- * generic/tclCmdAH.c (Tcl_FormatObjCmd): This fixes an
- off-by-one error in the format command that can lead to memory
- corruption on some systems, most notable little endian systems,
- such as Intel. Patch "format.txt" from patches archive.
+2002-03-25 Miguel Sofer <msofer@users.sourceforge.net>
- * unix/tclUnixChan.c (TcpGetOptionProc): Applied patch
- "unixchan.txt" from patches archive.
+ * doc/CrtTrace.3: small doc correction
+ * generic/tclBasic.c (Tcl_DeleteTrace): Allow NULL callback on
+ trace deletions [Bug 534728] (Hemang Lavana).
-Tue Sep 23 14:31:01 1997 Tom Tromey <tromey@cygnus.com>
+2002-03-24 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclStringObj.c (Tcl_DbNewStringObj): Don't die if
- bytes==NULL. From schoenw@gaertner.de (Juergen Schoenwaelder).
+ * generic/tclBasic.c (Tcl_EvalObjv): replaced obscure, incorrect
+ code as described in [Bug 533907] (Don Porter).
- * generic/tclIO.c (Tcl_SetChannelOption): Allow output translation
- mode to be "auto". From Dave Dykstra <dwd@bell-labs.com>.
+2002-03-24 Don Porter <dgp@users.sourceforge.net>
-Thu Sep 4 11:29:14 1997 Martin M. Hunt <hunt@cygnus.com>
+ * library/tcltest/tcltest.tcl: Use [interpreter] to set/query the
+ executable currently running the tcltest package. [Bug 454050]
- * generic/tclIO.c: Applied patch "io.txt" from the
- patches archive.
+ * library/tcltest/tcltest.tcl: Allow non-proc commands to be used
+ as the customization hooks. [Bug 495662]
-Tue Sep 2 16:49:16 PDT 1997 Khamis Abuelkomboz <khamis@cygnus.com>
- * library/menu.tcl
- In this file I have found two bugs:
- One in focus policy (wrong function call)
- and the main error was by the tkMenuUnpost procedure (toplevel problem).
- Generaly this script doesn't work correctly at all and I don't
- know if we have the latest version of this file.
+2002-03-24 Vince Darley <vincentdarley@users.sourceforge.net>
-Thu Aug 28 17:20:57 1997 Ian Lance Taylor <ian@cygnus.com>
+ * generic/tclFilename.c:
+ * generic/tclFCmd.c:
+ * generic/tclTest.c:
+ * generic/tcl.h:
+ * generic/tclIOUtil.c:
+ * win/tclWinFile.c:
+ * win/tclWinFCmd.c:
+ * win/tclWinPipe.c:
+ * unix/tclUnixFile.c:
+ * unix/tclUnixFCmd.c:
+ * mac/tclMacFile.c:
+ * doc/FileSystem.3:
+ * doc/file.n:
+ * tests/cmdAH.test:
+ * tests/fileName.test:
+ * tests/fileSystem.test: (new file)
+ * tests/winFCmd.test: fix [Bug 511666] and [Bug 511658],
+ and improved documentation of some aspects of the filesystem,
+ particularly 'Tcl_FSMatchInDirectory' which now might match
+ a single file/directory only, and 'file normalize' which
+ wasn't very clear before. Removed inconsistency betweens
+ docs and the Tcl_Filesystem structure. Also fixed
+ [Bug 523217] and corrected file normalization on Unix so that
+ it expands symbolic links. Added some new tests of the
+ filesystem code (in the new file 'fileSystem.test'), and
+ some extra tests for correct handling of symbolic links.
+ Fix to [Bug 530960] which shows up on Win98. Made comparison
+ with ".com" case insensitive in tclWinPipe.c
+
+ ***POTENTIAL INCOMPATIBILITY***: But only between alpha
+ releases (users of the new Tcl_Filesystem lookup table in Tcl
+ 8.4a4 need to handle the new way in which Tcl may call
+ Tcl_FSMatchInDirectory, and 'file normalize' on unix now
+ behaves correctly). Only known impact is with the 'tclvfs'
+ extension.
- * win/Makefile.in (install-libraries): Install http2.0 and
- opt0.1.
+2002-03-22 Miguel Sofer <msofer@users.sourceforge.net>
- * generic/tclEnv.c (TclCygwin32Putenv): Call unsetenv rather than
- putenv to remove the variable.
+ * tests/basic.test (basic-46.1): adding test for [Bug 533758],
+ fixed earlier today.
+
+2002-03-22 Jeff Hobbs <jeffh@ActiveState.com>
- * generic/tclAlloc.c: Don't define caddr_t if __CYGWIN32__.
+ * win/tclWinInt.h: moved undef of TCL_STORAGE_CLASS. [Bug #478579]
-Thu Aug 28 15:31:05 MET DST 1997 Zsolt Koppany <zkoppany@multix.de>
- * generic/tclCompile.c generic/tclEnv.c generic/tclTestObj.c
- unix/tclUnixFCmd.c
+2002-03-22 Miguel Sofer <msofer@users.sourceforge.net>
- * Memory bug fixes.
-Sun Aug 24 21:35:19 1997 Ian Lance Taylor <ian@cygnus.com>
+ * generic/tclBasic.c (Tcl_EvalObjEx):
+ * generic/tclExecute.c (TclCompEvalObj): fixed the errorInfo for
+ return codes other than (TCL_OK, TCL_ERROR) to runLevel 0
+ [Bug 533758]. Removed the static RecordTracebackInfo(), as its
+ functionality is easily replicated by Tcl_LogCommandInfo. Bug
+ and redundancy noted by Don Porter.
- * win/Makefile.in ($(TCLDLL)): Set base address to 0x66000000.
- ($(TCLREGDLL)): Set base address to 0x66200000.
+2002-03-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-Thu Aug 21 12:49:47 1997 Ian Lance Taylor <ian@cygnus.com>
+ * doc/expr.n: Improved documentation for ceil and floor [Bug 530535]
- * win/tclWinPipe.c (Tcl_WaitPid): If __CYGWIN32__, handle a
- cygwin32 signal exit status correctly.
+2002-03-20 Don Porter <dgp@users.sourceforge.net>
- * win/tclWinPipe.c (PipeThread): Only set PIPE_READAHEAD if we
- really did read a byte. Set PIPE_READABLE if ReadFile completes.
- (PipeProc): Don't bother to set PIPE_READABLE either.
- (PipeSetupProc): Handle a read from a pipe without a thread.
- (PipeCheckProc): Likewise.
+ * doc/SetVar.3:
+ * doc/TraceVar.3:
+ * doc/UpVar.3:
+ * generic/tcl.h (Tcl_VarTraceProc):
+ * generic/tcl.decls (Tcl_GetVar2, Tcl_SetVar2, Tcl_TraceVar2,
+ Tcl_UnsetVar2, Tcl_UntraceVar2, Tcl_UpVar2, Tcl_VarTraceInfo2,
+ Tcl_GetVar2Ex, TclSetVar2Ex):
+ * generic/tclCmdMZ.c (TraceVarProc):
+ * generic/tclEnv.c (EnvTraceProc):
+ * generic/tclEvent.c (VwaitVarProc):
+ * generic/tclInt.decls (TclLookupVar,TclPrecTraceProc):
+ * generic/tclLink.c (LinkTraceProc):
+ * generic/tclUtil.c (TclPrecTraceProc):
+ * generic/tclVar.c (CallTraces, MakeUpvar, VarErrMsg, TclLookupVar,
+ Tcl_GetVar2, Tcl_SetVar2, Tcl_TraceVar2, Tcl_UnsetVar2,
+ Tcl_UntraceVar2, Tcl_UpVar2, Tcl_VarTraceInfo2, Tcl_GetVar2Ex,
+ TclSetVar2Ex): Updated interfaces of generic/tclVar.c according
+ to TIP 27. In particular, the "part2" arguments were CONSTified.
+ [Patch 532642]
+ * generic/tclDecls.h:
+ * generic/tclIntDecls.h: make genstubs
-Wed Aug 20 23:17:23 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * win/tclWinPipe.c (PIPE_READABLE, PIPE_CLOSED): Define.
- (PIPE_HAS_THREAD, PIPE_READAHEAD): Define.
- (PipeInfo): Add fields: flagsMutex, mutex, tryReadEvent,
- readAhead.
- (pipeHwnd): New static variable.
- (PipeGetFlags, PipeSetFlag, PipeResetFlag): New static functions.
- Use them for all access to the flags field of a pipe.
- (PipeThread): New static function.
- (PipeProc): New static function.
- (PipeInit): Set up pipe window class and window.
- (PipeExitHandler): Unregister the class and destroy the window.
- (PipeSetupProc): Only set the block time to 0 for a readable pipe
- if we know that it is readable. If we want read events, tell the
- thread to try a read.
- (PipeCheckProc): Only post an event for a readable pipe if we know
- that it is readable.
- (TclpCreateCommandChannel): Create the flags mutex.
- (PipeCloseProc): If the pipe has a thread, tell the thread the
- pipe is closed, and let it free everything. Otherwise, close the
- flags mutex.
- (PipeInputProc): Lock the pipe during the function. Use the
- readahead byte if it is available. Reset PIPE_READABLE.
- (PipeEventProc): Check PIPE_READABLE if we have a thread.
- (PipeWatchProc): Create a thread if we want read events.
+ * tests/compile.test (compile-12.3): Test to detect bug 530320.
+ * generic/tclCompile.c (TclCompileTokens): Fixed buffer overrun
+ reported in bug 530320.
-Tue Aug 19 16:34:54 MET DST 1997 Zsolt Koppany <zkoppany@multix.de>
- * generic/tclEnv.c
- Removed patch from EnvExitProc()
+2002-03-14 Mo DeJong <mdejong@users.sourceforge.net>
-Mon Aug 18 20:15:23 1997 Ian Lance Taylor <ian@cygnus.com>
+ * win/configure: Regen.
+ * win/configure.in: Add configure time test for SEH
+ support in the compiler.
+ * win/tclWin32Dll.c (ESP, EBP, TclpCheckStackSpace,
+ _except_checkstackspace_handler):
+ * win/tclWinChan.c (ESP, EBP, Tcl_MakeFileChannel,
+ _except_makefilechannel_handler):
+ * win/tclWinFCmd.c (ESP, EBP, DoRenameFile,
+ _except_dorenamefile_handler,
+ DoCopyFile, _except_docopyfile_handler):
+ Implement SEH support under gcc using inline asm.
+ Tcl and Tk should now compile with Mingw 1.1. [Patch 525746]
- * win/tclWinPipe.c (TclpCreateProcess): Make sure the pipe stuff
- is initialized.
+2002-03-14 Mo DeJong <mdejong@users.sourceforge.net>
- * win/tclWin32Dll.c (TclSetSystemEnv): If we set Path, clear
- PATH. If we set PATH, clear Path.
+ * win/tclWinFCmd.c (DoRenameFile, DoCopyFile): Handle
+ an SEH exception with EXCEPTION_EXECUTE_HANDLER instead
+ of restarting the faulting instruction with
+ EXCEPTION_CONTINUE_EXECUTION. Bug 466102 provides an
+ example of how restarting could send Tcl into an
+ infinite loop. [Patch 525746]
-Fri Aug 15 19:20:44 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
- * win/tclWinInit.c (initScript): Look up one more level, to allow
- for exec-prefix being a subdirectory of prefix.
+ * win/tclWinFCmd.c (DoRenameFile, DoCopyFile, DoDeleteFile,
+ DoRemoveJustDirectory): Make sure we don't pass NULL or ""
+ as a path name to Win32 API functions since this was
+ crashing under Windows 98.
-Wed Aug 13 13:22:15 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-11 Don Porter <dgp@users.sourceforge.net>
- * generic/tclPipe.c (TclCreatePipeline): Check explicitly for
- redirecting stderr to stdout, and handle it by making the stderr
- file a copy of the stdout file.
+ * library/tcltest/tcltest.tcl:
+ * library/tcltest/pkgIndex.tcl: Bumped tcltest package to 2.0.2.
- * generic/tclEnv.c (TclSetEnv): Call TclSetSystemEnv before
- calling Tcl_SetVar2.
+2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
-Mon Aug 11 19:39:45 1997 Ian Lance Taylor <ian@cygnus.com>
+ * library/tcltest/tcltest.tcl (getMatchingFiles): Pass
+ a proper list to foreach to avoid munging a Windows
+ patch like D:\Foo\Bar into D:FooBar before the glob.
- * configure.in: Call AC_CANONICAL_HOST. Check host, not target,
- for cygwin32.
- * configure: Rebuild.
+2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
-Sat Aug 9 20:27:48 1997 Ian Lance Taylor <ian@cygnus.com>
+ * generic/tclEncoding.c: Fix typo in comment.
+ * generic/tclIO.c (DoReadChars, ReadBytes, ReadChars):
+ Use NULL value instead of pointer set to NULL to make
+ things more clear. Reorder arguments so that they
+ match the function signatures. Cleanup little typos
+ and add more descriptive comment.
- * win/tclWinSock.c (SocketEventProc): Handle an FD_CONNECT event
- for a client channel. On FD_CLOSE for a client channel, set
- TCL_WRITABLE.
- (Tcl_MakeTcpClientChannel): Select for FD_CONNECT.
- (TcpWatchProc): Watch for FD_CLOSE on a client channel when
- looking for writable. Watch for FD_CONNECT on a client channel in
- all cases.
+2002-03-08 Mo DeJong <mdejong@users.sourceforge.net>
-Thu Aug 7 12:44:49 1997 Ian Lance Taylor <ian@cygnus.com>
+ * win/README: Update to indicate that Mingw 1.1 is
+ required to build Tcl. Add section describing new
+ msys based build process. Update Cygwin build
+ instructions so users know where to find Mingw 1.1.
- * win/tclWinSock.c: Add clientChannel field.
- (SocketEventProc): Handle FD_ACCEPT on a client channel by setting
- TCL_READABLE.
- (NewSocketInfo): Initialize clientChannel field to 0.
- (Tcl_MakeTcpClientChannel): Set clientChannel field to 1. Select
- for FD_ACCEPT.
+2002-03-08 Jeff Hobbs <jeffh@ActiveState.com>
- * win/tclWinInit.c (initScript): Use share rather than lib.
-
-Wed Aug 6 20:49:13 1997 Ian Lance Taylor <ian@cygnus.com>
+ * win/tclWinFCmd.c (DoCopyFile): correctly set retval to TCL_OK.
- * win/Makefile.in: Update for Tcl 8.0.
- * win/configure.in: Likewise.
- * win/configure: Rebuild.
- * win/tclWin32Dll.c (TclSetSystemEnv): Handle a NULL value.
- * win/tclWinChan.c (Tcl_OpenFileChannel): Move conv_to_win32_path
- call after Tcl_TranslateFileName call.
- * win/tclWinFile.c: Don't include <shlobj.h> if __CYGWIN32__.
- (TclWinStat): Don't adjust stat times if __CYGWIN32__.
+2002-03-07 Mo DeJong <mdejong@users.sourceforge.net>
-Tue Aug 5 13:25:43 1997 Tom Tromey <tromey@cygnus.com>
+ * win/tclWin32Dll.c (TclpCheckStackSpace):
+ * win/tclWinFCmd.c (DoRenameFile, DoCopyFile): Replace
+ hard coded constants with Win32 symbolic names.
+ Move control flow statements out of __try blocks
+ since the documentation indicates it is frowned upon.
- * win/tclWinPipe.c: Preserved local changes.
- * win/tclWinSock.c: Preserved local changes.
- * win/tclWinChan.c: Preserved local changes.
+2002-03-07 Don Porter <dgp@users.sourceforge.net>
-Mon Aug 4 16:23:53 1997 Tom Tromey <tromey@cygnus.com>
+ * doc/interp.n:
+ * generic/tclInterp.c(Tcl_InterpObjCmd,SlaveObjCmd,SlaveRecursionLimit):
+ * generic/tclTest.c:
+ * tests/interp.test: Added the [interp recursionlimit] command to
+ set/query the recursion limit of an interpreter. Proposal and
+ implementation from Stephen Trier. [TIP 87, Patch 522849]
- * tests/fCmd.test: fCmd-8.1 test marked nonportable; removed local
- changes.
+2002-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * tests/defs: Preserved local changes.
+ * generic/tcl.h, tools/tcl.wse.in, unix/configure.in,
+ * unix/tcl.spec, win/README.binary, win/configure.in, README:
+ Bumped patchlevel; this might need to change in the future, but it
+ will help us distinguish between the CVS version and the most
+ recent released version.
-Fri Aug 1 16:51:03 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-06 Miguel Sofer <msofer@users.sourceforge.net>
- * win/tclWinChan.c (Tcl_OpenFileChannel): If __CYGWIN32__, convert
- the path name to a win32 path name.
+ * generic/tclInt.h: for unshared objects, TclDecrRefCount now
+ frees the internal rep before the string rep - just like the
+ non-macro Tcl_DecrRefCount/TclFreeObj [Bug 524802].
-Wed Jul 23 20:03:07 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * win/tclWinSock.c (TclWinWatchSocket): Only set the maximum block
- time to zero if we have an event that matches something in the
- desired mask.
+ * doc/lsearch.n: Documentation of new features, plus examples.
+ * tests/lsearch.test: Tests of new features.
+ * generic/tclCmdIL.c (Tcl_LsearchObjCmd): TIP#80 support. See
+ http://purl.org/tcl/tip/80 for details.
-Mon Jun 30 13:38:43 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-05 Jeff Hobbs <jeffh@ActiveState.com>
- * win/tclWinPipe.c (TclpCreateProcess): Our DLL is named
- cygtclpip, not tclpip.
+ *** 8.4a4 TAGGED FOR RELEASE ***
- * generic/tclEnv.c: If __CYGWIN32__, define environ as a static
- variable.
- (EnvInit): If __CYGWIN32__, initialize environ from
- __imp___cygwin_environ.
- * win/tclWinPort.h (__imp___cygwin_environ): Don't declare.
- (environ): Don't define.
- (TclSetSystemEnv): If __CYGWIN32__, declare as function, don't
- define as macro.
- * win/tclWin32Dll.c (TclSetSystemEnv): New function.
+ * unix/tclUnixChan.c: initial remedy for [Bug #525783] flush
+ problem introduced by TIP #35. This may not satisfy true serial
+ channels, but it restores the correct flushing of std* channels on
+ exit.
-Thu Jun 26 13:56:01 1997 Ian Lance Taylor <ian@cygnus.com>
+ * unix/README: added --enable-langinfo doc.
- * win/Makefile.in (WINDRES): New variable.
- (install-binaries): Don't install DLLs here...
- (install-libraries): ...install them here instead.
- ($(TCLDLL)): Depend upon and link with tclres.o.
- ($(TCLSH)): Depend upon and link with tclshres.o.
- ($(TCLTEST)): Likewise.
- (tclres.o, tclshres.o): New targets.
- * win/configure.in: Define and substitute WINDRES.
- * win/configure: Rebuild.
+ * unix/tcl.spec:
+ * tools/tcl.wse.in: fixed URL refs to use www.tcl.tk or SF.
-Mon Jun 23 10:15:10 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-04 Jeff Hobbs <jeffh@ActiveState.com>
- * Makefile.in (install-binaries, install-libraries): New targets.
+ * README:
+ * mac/README:
+ * unix/Makefile.in:
+ * unix/README:
+ * win/README:
+ * win/README.binary: updated to use www.tcl.tk URL.
-Wed Jun 18 12:12:36 1997 Ian Lance Taylor <ian@cygnus.com>
+ * unix/Makefile.in: added older ChangeLogs to dist target.
- * win/Makefile.in: Copy install, install-binaries, and
- install-libraries rules, and associated variables from
- unix/Makefile.in, with appropriate adjustments.
+ * tests/io.test:
+ * tests/encoding.test: corrected iso2022 encoding results.
+ added encoding-24.*
+ * generic/tclEncoding.c (EscapeFromUtfProc): corrected output of
+ escape codes as per RFC 1468. [Patch #474358] (taguchi)
+ (TclFinalizeEncodingSubsystem): corrected potential double-free
+ when encodings were finalized on exit. [Bug #219314, #524674]
-Thu Jun 12 19:12:20 1997 Ian Lance Taylor <ian@cygnus.com>
+2002-03-01 Jeff Hobbs <jeffh@ActiveState.com>
- * win/Makefile.in ($(TMPDIR)/tclcyg.def): Don't export
- impure_ptr.
+ * library/encoding/iso2022-jp.enc:
+ * library/encoding/iso2022.enc:
+ * tools/encoding/iso2022-jp.esc:
+ * tools/encoding/iso2022.esc: gave <ESC>$B precedence over <ESC>$@,
+ based on comments (point 1) in [Bug #219283] (rfc 1468)
-Fri Jun 6 15:52:50 1997 Ian Lance Taylor <ian@cygnus.com>
+ * tests/encoding.test: added encoding-23.* tests
+ * generic/tclIO.c (FilterInputBytes): reset the TCL_ENCODING_START
+ flags in the ChannelState when using 'gets'. [Bug #523988]
+ Also reduced the value of ENCODING_LINESIZE from 30 to 20 as this
+ seems to improve the performance of 'gets' according to tclbench.
- Add support for building with cygwin32:
- * win/Makefile.in: Rewrite completely based on makefile.vc.
- * win/configure.in: Rewrite completely.
- * win/configure: Rebuild.
- * win/tclWinPort.h (__imp___cygwin_environ): Declare if
- __CYGWIN32__.
- (environ): Define if __CYGWIN32__.
- * win/tclWin32Dll.c (_impure_ptr): Define if __CYGWIN32__.
- (__imp_reent_data): Declare if __CYGWIN32__.
- (DllMain): Initialize _impure_ptr if __CYGWIN32__.
- * win/tclWinFCmd.c (TclpRenameFile): Don't use try and except if
- __GNUC__.
- (TclpCopyFile): Likewise.
- * win/tclWinPipe.c: Don't include dos.h if __CYGWIN32__.
- * win/tclWinSock.c (InitSockets): Don't cast to PASCAL FAR if
- __GNUC__.
+2002-02-28 Jeff Hobbs <jeffh@ActiveState.com>
-Thu Jun 5 18:17:53 1997 Ian Lance Taylor <ian@cygnus.com>
+ * generic/tclCmdMZ.c (TraceCommandProc): ensure that TraceCommandInfo
+ structure was also deleted when a command was deleted to prevent a
+ mem leak.
- * generic/tcl.h (USE_TCLALLOC): Don't define USE_TCLALLOC if it is
- already defined (this modifies a CYGNUS LOCAL patch).
+ * generic/tclBasic.c (Tcl_CreateObjTrace): set tracePtr->flags
+ correctly.
-Fri May 9 09:36:00 1997 Tom Tromey <tromey@cygnus.com>
+ * generic/tclTimer.c (TimerExitProc): remove remaining events in
+ tls on thread exit.
- * patchlevel.h: Removed.
+2002-02-28 Miguel Sofer <msofer@users.sourceforge.net>
-Wed Apr 9 17:31:41 1997 Bob Manson <manson@charmed.cygnus.com>
+ * generic/tclNamesp.c: allow cached fully-qualified namespace
+ names to be usable from different namespaces within the same
+ interpreter without forcing a new lookup [Patch 458872].
- * generic/regexp.c (regmatch): Speed up .* matching
- significantly. Treat a single bracketed character the same as a
- string.
+2002-02-28 Miguel Sofer <msofer@users.sourceforge.net>
-Thu Mar 20 14:27:45 1997 Geoffrey Noer <noer@cygnus.com>
+ * generic/tclExecute.c: Replaced a few direct stack accesses
+ with the POP_OBJECT() macro [Bug 507181] (Don Porter).
- * compat/strncasecmp.c: fix args in prototype for strcasecmp
+2002-02-27 Don Porter <dgp@users.sourceforge.net>
-Fri Mar 14 10:36:30 1997 Tom Tromey <tromey@cygnus.com>
+ * doc/GetIndex.3:
+ * generic/tcl.decls (Tcl_GetIndexFromObjStruct):
+ * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Revised the
+ prototype of the Tcl_GetIndexFromObjStruct to take its struct
+ table as a (CONST VOID *) argument, better describing what it is,
+ maintaining source compatibility, and adding CONST correctness
+ according to TIP 27. Thanks to Joe English for an elegant
+ solution. [Bug 520304]
- * tests/fCmd.test: Commented out fcmd-8.1 test.
+ * generic/tclDecls.h: make genstubs
-Fri Mar 7 10:46:04 1997 Tom Tromey <tromey@cygnus.com>
+ * generic/tclMain.c (Tcl_Main,StdinProc): Corrected some reference
+ count management errors on the interactive command Tcl_Obj found by
+ Purify. Thanks to Jeff Hobbs for the report and assistance.
- * Updated to Tcl 7.6p2 and preserved Cygnus changes.
+2002-02-27 Jeff Hobbs <jeffh@ActiveState.com>
-Wed Mar 5 12:00:44 1997 Martin <hunt@cyber>
+ * generic/tclBasic.c (Tcl_EvalTokensStandard): corrected mem leak
+ in error case.
- * Makefile.in, configure.in: Added support for building
- the windows directory.
- * configure: Rebuilt.
+ * generic/tclTest.c (TestStatProc[123]): correct harmless UMRs.
-Fri Dec 13 15:47:07 1996 Tom Tromey <tromey@cygnus.com>
+ * generic/tclLink.c (Tcl_LinkVar): correct mem leak in error case.
- * compat/strtod.c: Include ../compat/stdlib.h, not
- compat/stdlib.h. From Donald Koch <koch@cognex.com>.
+2002-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-Wed Nov 20 14:07:06 1996 Tom Tromey <tromey@cygnus.com>
+ * tests/socket.test (2.7): Accepted and applied patch for Tcl SF
+ bug #523470 provided by Don Porter <dgp@users.sourceforge.net>
+ to avoid timing problems in that test.
- * generic/tclAlloc.c: Removed; functionality has been integrated
- into Tcl core.
+ * unix/tclUnixChan.c (TclpOpenFileChannel): Added code to regonize
+ "/dev/tty" (by name) and to not handle it as tty / serial
+ line. This is the controlling terminal and is special. Setting
+ it into raw mode as is done for other tty's is a bad idea. This
+ is a hackish fix for expect SGF Bug #520624. The fix has
+ limitation: Tcl_MakeFileChannel handles tty's specially too, but
+ is unable to recognize /dev/tty as it only gets a file
+ descriptor, and no name for it.
-Tue Nov 19 09:30:41 1996 Tom Tromey <tromey@cygnus.com>
+2002-02-26 Jeff Hobbs <jeffh@ActiveState.com>
- * generic/tcl.h: Remove redundant decls of Tcl_Alloc and friends.
+ * generic/tclCmdAH.c (StoreStatData): corrected mem leak.
-Mon Nov 18 14:59:47 1996 Tom Tromey <tromey@cygnus.com>
+ * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): prevent obj leak in
+ remedial regsub case.
- * generic/tclAlloc.c (Tcl_Alloc): Renamed.
- * generic/tcl.h: Always define USE_TCLALLOC.
+ * generic/tclFileName.c (Tcl_TranslateFileName): decr refcount for
+ error case to prevent mem leak.
- * Imported Tcl 7.6 and preserved local changes.
+ * generic/tclVar.c (Tcl_ArrayObjCmd): removed extra obj allocation.
-Mon Aug 5 10:41:11 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * unix/tclUnixSock.c (Tcl_GetHostName): added an extra
+ gethostbyname check to guard against failure with truncated
+ names returned by uname.
- * Makefile.in (configure): Don't depend on configure.in.
- (config.status): Depend on configure.
+ * unix/configure:
+ * unix/tcl.m4 (SC_SERIAL_PORT): added sys/modem.h check and defined
+ _XOPEN_SOURCE_EXTENDED for HP-11 to get updated header decls.
-Wed Jul 31 14:41:34 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * unix/tclUnixChan.c: added Unix implementation of TIP #35, serial
+ port support. [Patch #438509] (schroedter)
- * tests/socket.test: Commented out test socket-8.1; it can fail on
- Solaris 2.4.
+2002-02-26 Miguel Sofer <msofer@users.sourceforge.net>
-Tue Jul 30 14:53:59 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * generic/tclCmpCmds.c: (bugfix to the bugfix, hopefully the last)
+ Bugfix to the new [for] compiling code: was setting a
+ exceptArray parameter using another param which wasn't yet
+ initialised, thus filling it with noise.
- * tests/socket.test: Find remote.tcl in srcdir.
- * tests/io.test: Find io.test in srcdir.
- * tests/defs: Find "defs" in directory $srcdir.
+2002-02-25 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-Wed Jun 26 12:36:57 1996 Jason Molenda (crash@godzilla.cygnus.co.jp)
+ * mac/tclMacSock.c (TcpGetOptionProc): Changed to recognize the
+ option "-error". Essentially ignores the option, always
+ returning an empty string.
- * configure.in (AC_PREREQ): autoconf 2.5 or higher.
- * configure: Rebuilt.
+2002-02-25 Jeff Hobbs <jeffh@ActiveState.com>
-Thu Jun 6 15:04:44 1996 Gordon Irlam <gordoni@snuffle.cygnus.com>
+ * doc/Alloc.3:
+ * doc/LinkVar.3:
+ * doc/ObjectType.3:
+ * doc/PkgRequire.3:
+ * doc/Preserve.3:
+ * doc/TCL_MEM_DEBUG.3: Updated documentation to describe the ckalloc,
+ ckfree, ckrealloc, attemptckalloc, and attemptckrealloc macros, and
+ to accurately describe when and how they are used. [Bug #497459] (dgp)
+
+ * generic/tclHash.c (AllocArrayEntry, AllocStringEntry):
+ Before invoking ckalloc when creating a Tcl_HashEntry,
+ check that the amount of memory being allocated is
+ at least as large as sizeof(Tcl_HashEntry). The previous
+ code was allocating memory regions that were one
+ or two bytes short. [Bug #521950] (dejong)
+
+2002-02-25 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclBasic.c (Tcl_EvalEx): avoiding a buffer overrun
+ reported by Joe English, and restoring tcl7.6 behaviour for
+ [subst]: badly terminated nested scripts will raise an error
+ and not be evaluated. [Bug #495207]
+
+2002-02-25 Don Porter <dgp@users.sourceforge.net>
+
+ * unix/tclUnixPort.h: corrected strtoll prototype mismatch on Tru64.
+ * compat/strtod.c (strtod): simplified #includes
+ * compat/strtol.c (strtol): gather result in a long before returning
+ as a long: necessary on platforms where sizeof(int) != sizeof(long).
+
+2002-02-25 Daniel Steffen <das@users.sourceforge.net>
+
+ * unix/tclLoadDyld.c: updated to use Mac OS X 10.1 dyld APIs that
+ have more libdl-like semantics. (bug #514392)
+
+2002-02-25 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclCompCmds: fixing a bug in patch dated 2002-02-22, in
+ the code for [for] and [while]. Under certain conditions, for long
+ bodies, the exception range parameters were badly computed. Tests
+ forthcoming: I still can't reproduce the conditions in the
+ testsuite (!), although the bug (with assorted segfault or panic!)
+ can be triggered from the console or with the new parse.bench in
+ tclbench.
+
+2002-02-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * doc/usenix.ps, doc/usenix.text: Removed because copyright status
- unclear.
+ * compat/strtoul.c, compat/strtol.c, compat/strtod.c: Added UCHAR,
+ CONST and #includes to clean up GCC output.
-Mon May 20 16:11:55 1996 Tom Tromey <tromey@creche.cygnus.com>
+2002-02-23 Don Porter <dgp@users.sourceforge.net>
- * tcltk-man-html.tcl: Moved to devo/inet.
+ * compat/strtoull.c (strtoull):
+ * compat/strtoll.c (strtoll):
+ * compat/strtoul.c (strtoul): Fixed failure to handle leading
+ sign symbols '+' and '-' and '0X' and raise overflow errors.
+ [Bug 440916] Also corrects prototype and errno problems.
-Mon May 6 15:21:14 1996 Tom Tromey <tromey@lisa.cygnus.com>
+2002-02-23 Mo DeJong <mdejong@users.sourceforge.net>
- * tcltk-man-html.tcl: Search Tk section 3 man pages if possible.
+ * configure: Regen.
+ * unix/tcl.m4 (SC_CONFIG_CFLAGS): Link with -n32
+ instead of -32 when building on IRIX64-6.* system.
+ [Tcl bug 521707]
-Wed May 1 15:17:14 1996 Tom Tromey <tromey@lisa.cygnus.com>
+2002-02-22 Don Porter <dgp@users.sourceforge.net>
- * tcltk-man-html.tcl: New file.
+ * generic/tclInt.h:
+ * generic/tclObj.c: renamed global variable emptyString ->
+ tclEmptyString because it is no longer static.
+ * generic/tclPkg.c: Fix for panic when library is loaded on a
+ platform without backlinking without proper use of stubs. [Bug 476537]
-Thu Mar 7 10:01:05 1996 Tom Tromey <tromey@creche.cygnus.com>
+2002-02-22 Jeff Hobbs <jeffh@ActiveState.com>
- * Makefile.in (config.status): Don't depend on configure.
+ * tests/regexpComp.test: updated regexp-11.[1-4] to match changes
+ in regexp.test for new regsub syntax
-Wed Mar 6 10:48:56 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * unix/configure:
+ * unix/tcl.m4: added --enable-64bit support for AIX-4 (using -q64
+ flag) when using IBM's xlc compiler.
+
+ * tests/safe.test: updated safe-8.5 and safe-8.7
+ * library/safe.tcl (CheckFileName): removed the limit on
+ sourceable file names (was only *.tcl or tclIndex files with no
+ more than one dot and 14 chars). There is enough internal
+ protection in a safe interpreter already. Fixes [Tk Bug #521560].
+
+2002-02-22 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tclCompCmds: [FR 465811]. Optimising [if], [for] and
+ [while] for constant conditions; in addition, [for] and [while]
+ are now compiled with the "loop rotation" optimisation (thanks to
+ Kevin Kenny).
+
+2002-02-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ --- TIP#76 CHANGES ---
+ * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): Final-argument-less
+ [regsub] returns the modified string.
+ * doc/regsub.n: Updated docs.
+ * tests/regexp.test: Updated and added tests.
+
+ * compat/strtoll.c (strtoll):
+ * compat/strtoull.c (strtoull):
+ * unix/tclUnixPort.h:
+ * win/tclWinPort.h: Const-ing 64-bit compatability declarations.
+ Note that the return pointer is non-const because it is entirely
+ legal for the functions to be called from somewhere that owns the
+ string being passed. Fixes problem reported by Larry Virden.
+
+2002-02-21 David Gravereaux <davygrvy@pobox.com>
+
+ * win/mkd.bat (removed):
+ * win/coffbase.txt (new):
+ * win/makefile.bc:
+ * win/makefile.vc: Changed the 'setup' target to stop using
+ the mkd.bat file and just make the directory right in the rule.
+ Same change to makefile.bc. configure.in nor Makefile.in use
+ it.
+
+ coffbase.txt will be the master list for our "prefered base
+ addresses" set by the linker. This should improve load-time
+ (NT only) by avoiding relocations. Submissions to the list
+ by extension authors are encouraged.
+
+ Added a 'tidy' target to compliment 'clean' and 'hose' to remove
+ just the outputs. Also removed the $(winlibs) macro as it wasn't
+ being used.
+
+ Stuff left to do:
+ 1) get the winhelp target to stop building in the tools/
+ directory.
+ 2) stop using rmd.bat
+ 3) add more dependacy rules.
+
+ * win/tclAppInit.c: Reverted back to -r1.6, as the header file
+ change to tclPort.h won't allow for easy embedded support
+ outside of the source dist. Thanks to Don Porter for pointing
+ this out to me.
+
+2002-02-21 David Gravereaux <davygrvy@pobox.com>
- * Makefile.in (Makefile): Removed redundant rule.
+ * win/makefile.vc:
+ * win/rules.vc: Added a new "loimpact" option that sets the
+ -ws:aggressive linker option. Off by default. It's said to
+ keep the heap use low at the expense of alloc speed.
-Thu Feb 29 21:27:38 1996 Fred Fish <fnf@ninemoons.com>
+ * win/tclAppInit.c: Changed #include "tcl.h" to be tclPort.h to
+ remove the raw windows.h include. tclPort.h brings in windows.h
+ already and lessens the pre-compiled-header mush and the randomly
+ useless #pragma comment (lib,...) references throughout the big
+ windows.h tree (as observed at high linker warning levels).
- * Makefile.in (configure): Run autoconf in source dir,
- not build dir.
+2002-02-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-Thu Feb 29 09:08:52 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * generic/tcl.h: Better guessing of LP64/ILP32 architecture, but
+ now sensitive to presence of (suitable) <limits.h>
- * Makefile.in (Makefile): New rule.
- (config.status): New rule.
+2002-02-20 Don Porter <dgp@users.sourceforge.net>
- * tests/all: Use $srcdir to find tests.
- Source `defs' here.
- Only print filename, not entire path.
+ * generic/tcl.decls (Tcl_RegExpRange,Tcl_GetIndexFromObjStruct):
+ Overlooked a few source incompatibilities. Now using CONST84.
+ * generic/tclDecls.h: make genstubs
+ * generic/tcl.h (Tcl_CmdObjTraceProc): silence warning from Sun
+ Workshop compiler.
-Tue Feb 27 20:40:56 1996 Rob Savoye <rob@chinadoll.cygnus.com>
+2002-02-20 David Gravereaux <davygrvy@pobox.com>
- * unix/configure.in: Use -fpic for dltests, as gcc now support
- shared libraries on HPUX.
- * configure: Rebuild.
+ * win/buildall.vc.bat:
+ * win/makefile.vc:
+ * win/rules.vc: General clean-ups. Added compiler and linker tests
+ for a) the pentium 0x0F errata, b) optimizing (not all have this),
+ and c) linker v6 section alignment confusion. All these are tested
+ first to make sure any D4002 or LNK1117 warnings aren't displayed.
+ The pentium 0x0F errata is a recommended switch. The v5 linker's
+ section alignment default is 512, but the v6 linker was changed
+ to 4096 in an attempt to speed loading on Win98. I changed the
+ default to always be 512 across both linkers, unless linking
+ statically, then 4096 is used for the claimed speed effect. Using
+ a 512 alignment saves 12k bytes of dead space in the DLL.
-Mon Feb 12 14:55:34 1996 Rob Savoye <rob@chinadoll.cygnus.com>
+ Added IA64 B-stepping errata switch when the compiler supports it.
- * unix/configure.in: Set the shared lib flags so the dynamic
- loading tests work for SunOS and Solaris when using GCC.
+ Added profiling to $(lflags) when requested and also removed the
+ explict -entry option as the default works fine as is.
-Wed Jan 24 09:41:00 1996 Tom Tromey <tromey@creche.cygnus.com>
+ Removed win/tclWinInit.c from the special case section to let it
+ use the common implicit rule as the $(EXTFLAGS) macro it had was
+ never referenced anywhere.
- * Makefile.in: Replaced realclean with maintainer-clean.
+2002-02-20 Donal K. Fellows <fellowsd@cs.man.ac.uk>
-Mon Jan 22 14:42:47 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * generic/tcl.h: Added code to guess the correct settings for
+ TCL_WIDE_INT_IS_LONG and TCL_WIDE_INT_TYPE when configure doesn't
+ tell us them, as can happen with extensions.
- * tests/all: Print message when tests finished.
+2002-02-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * Makefile.in (check): Use absolute directory when finding
- TCL_LIBRARY.
+ * doc/format.n: Updated docs to list the specification.
+ * generic/tclCmdAH.c (Tcl_FormatObjCmd): Made behaviour on 64-bit
+ platforms correctly meet the specification, that %d works with the
+ native word-sized integer, instead of trying to guess (wrongly)
+ from the value being passed.
-Fri Jan 19 10:35:16 1996 Tom Tromey <tromey@creche.cygnus.com>
+2002-02-19 Don Porter <dgp@users.sourceforge.net>
- * Makefile.in (check installcheck): Moved from unix/Makefile.in.
+ * changes: First draft of updated changes for 8.4a4 release.
-Thu Jan 11 14:41:35 1996 Tom Tromey <tromey@creche.cygnus.com>
+2002-02-15 Jeff Hobbs <jeffh@ActiveState.com>
- * Makefile.in (test): New target.
+ * unix/tclUnixPort.h: add strtoll/strtoull declarations for
+ platforms that do not define them.
-Wed Jan 10 11:21:38 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * generic/tclIndexObj.c (STRING_AT): removed ptrdiff_t cast and
+ use of VOID* in default case (GNU-ism).
- * Makefile.in (mostlyclean-recursive clean-recursive
- distclean-recursive realclean-recursive): Separated out recursive
- rules.
+2002-02-15 Kevin Kenny <kennykb@acm.org>
-Tue Jan 9 17:34:56 1996 Tom Tromey <tromey@creche.cygnus.com>
+ * compat/strtoll.c:
+ * compat/strtoul.c:
+ * compat/strtoull.c:
+ * generic/tclIOUtil.c:
+ * generic/tclPosixStr.c:
+ * generic/tclTest.c:
+ * generic/tclTestObj.c:
+ * tests/get.test:
+ * win/Makefile.vc: Further tweaks to the TIP 72 patch to make it
+ compile under VC++.
+
+2002-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * tclExecute.c:
+ * tclIOGT.c:
+ * tclIndexObj.c: Touchups to the TIP 72 patch to make it
+ compileable under Windows again. The changes are not complete,
+ there is one nasty regarding _stati64
+
+2002-02-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
+
+ +----------------------+
+ | TIP #72 IMPLEMENTED. |
+ +----------------------+
+
+ There are a lot of changes from this TIP, so please see
+ http://purl.org/tcl/tip/72.html for discussion of
+ backward-compatability issues, but the main ones modifications are
+ in:
+
+ * generic/tcl.h: New types.
+ * generic/tcl.decls: New public functions.
+ * generic/tclExecute.c: 64-bit aware bytecode engine.
+ * generic/tclBinary.c: 64-bit handling in [binary] command.
+ * generic/tclScan.c: 64-bit handling in [scan] command.
+ * generic/tclCmdAH.c: 64-bit handling in [file] and [format]
+ commands.
+ * generic/tclBasic.c: New "wordSize" entry in ::tcl_platform.
+ * generic/tclFCmd.c: Large-file support (with many consequences.)
+ * generic/tclIO.c: Large-file support (with many consequences.)
+ * compat/strtoll.c, compat/strtoull.c: New support functions.
+ * unix/tcl.m4, unix/configure: 64-bit support and greatly enhanced
+ cacheing.
+
+ Most other changes, including all those in doc/* and test/* as
+ well as the majority in the platform directories, follow on from
+ these.
+
+ Also coming out of the woodwork:
+ * generic/tclIndex.c: Better support for Cray PVP.
+ * win/tclWinMtherr.c: Better Borland support.
+
+ Note that, in a number of places through the Unix part of the
+ platform support, there are Tcl_Platform* references. These are
+ expanded into the correct way to call that particular underlying
+ function, i.e. with or without a '64' suffix, and should be used
+ by people working on the core in preference to the API functions
+ they overlay so that the code remains portable depending on the
+ presence or absence of 64-bit support on the underlying platform.
+
+ ***POTENTIAL INCOMPATIBILITY***: Extracted from the TIP
+
+ SUMMARY OF INCOMPATIBILITIES AND FIXES
+ ======================================
+
+ The behaviour of expressions containing constants that appear
+ positive but which have a negative internal representation will
+ change, as these will now usually be interpreted as wide
+ integers. This is always fixable by replacing the constant with
+ int(constant).
+
+ Extensions creating new channel types will need to be altered as
+ different types are now in use in those areas. The change to the
+ declaration of Tcl_FSStat and Tcl_FSLstat (which are the new
+ preferred API in any case) are less serious as no non-alpha
+ releases have been made yet with those API functions.
+
+ Scripts that are lax about the use of the l modifier in format and
+ scan will probably need to be rewritten. This should be very
+ uncommon though as previously it had absolutely no effect.
+
+ Extensions that create new math functions that take more than one
+ argument will need to be recompiled (the size of Tcl_Value
+ changes), and functions that accept arguments of any type
+ (TCL_EITHER) will need to be rewritten to handle wide integer
+ values. (I do not expect this to affect many extensions at all.)
+
+2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * generic/tclIOCmd.c (Tcl_GetsObjCmd): Trivial fix for bug
+ #517503, a memory leak reported by Miguel Sofer
+ <msofer@users.sourceforge.net>. The leak happens if an error
+ occurs for "set var [gets $chan]" and leak one empty object.
+
+2002-02-12 David Gravereaux <davygrvy@pobox.com>
+
+ * djgpp/ (new directory)
+ * djgpp/Makefile (new):
+ * unix/tclAppInit.c:
+ * unix/tclMtherr.c:
+ * unix/tclUnixFCmd.c:
+ * unix/tclUnixFile.c:
+ * unix/tclUnixInit.c:
+ * unix/tclUnixPort.h: Early stage of DJGPP support for building
+ Tcl on DOS. Dynamic loading isn't working, yet. Requires watt32
+ for the TCP/IP stack. No autoconf, yet. Barely tested, but
+ makes a working exe that runs Tcl in protected-mode, flat memory.
+ [exec] and pipes will need the most work as multi-tasking on DOS
+ has to be carefully.
- * Makefile.in: New file.
- * configure.in: New file.
+2002-02-10 Kevin Kenny <kennykb@acm.org>
- * Updated to the tcl7.5a2 release, plus preserved our patches.
- Entries past this point mostly likely refer to files in various
- subdirectories.
+ * doc/CrtObjCmd.3:
+ * doc/CrtTrace.3:
+ * generic/tcl.decls:
+ * generic/tcl.h:
+ * generic/tclBasic.c:
+ * generic/tclInt.h:
+ * generic/tclTest.c:
+ * tests/basic.test: Added Tcl_CreateObjTrace,
+ Tcl_GetCommandInfoFromToken and Tcl_SetCommandInfoFromToken.
+ (TIPs #32 and #79.)
-Fri Dec 1 10:18:01 1995 Rob Savoye <rob@chinadoll.cygnus.com>
+ * generic/tclDecls.h:
+ * generic/tclStubInit.c: Regenerated Stubs tables.
+
+2002-02-08 Jeff Hobbs <jeffh@ActiveState.com>
- * Makefile.in, changes, configure, patchlevel.h, tcl.h,
- tclBasic.c, tclCkalloc.c, tclCmdAH.c, tclCmdMZ.c, tclInt.h,
- tclMain.c, tclPort.h, tclRegexp.h, tclUnixAZ.c, tclUnixStr.c,
- tclUnixUtil.c, tclVar.c, README, compat/fixstrtod.c,
- tests/lsort.test, testsuite/config/default.exp,
- testsuite/tcl.tests/tcl-test.exp: Upgrade to Tcl7.4p3 to fix a few
- bugs.
+ * unix/configure:
+ * unix/tcl.m4: added -pthread for FreeBSD to EXTRA_CFLAGS and
+ LDFLAGS. Also triggered nodots only for FreeBSD-3.
+ Added AC_DEFINE(_POSIX_PTHREAD_SEMANTICS) for Solaris.
-Thu Nov 16 10:01:20 1995 Rob Savoye <rob@chinadoll.cygnus.com>
+ * unix/tclUnixPort.h:
+ * unix/tclUnixThrd.c: added thread-safe versions of readdir,
+ localtime, gmtime and inet_ntoa for threaded build. (jgdavidson)
- * configure.in: Use AC_PROG_CC again since Cygnus configure now
- does the sames thing.
+ * generic/tclScan.c (Tcl_ScanObjCmd): prevented ckfree being
+ called on a pointer to NULL.
-Sat Oct 7 20:51:29 1995 Michael Meissner <meissner@cygnus.com>
+2002-02-07 Don Porter <dgp@users.sourceforge.net>
- * tcl.h (ckrealloc): Cast pointer argument to char * to silence
- warnings.
+ * doc/DString.3:
+ * doc/Encoding.3:
+ * doc/GetCwd.3:
+ * doc/SplitPath.3:
+ * doc/Translate.3:
+ * doc/Utf.3:
+ * generic/tcl.decls:
+ * generic/tcl.h:
+ * generic/tclEncoding.c:
+ * generic/tclEnv.c:
+ * generic/tclFileName.c:
+ * generic/tclIOUtil.c:
+ * generic/tclUtf.c:
+ * generic/tclUtil.c:
+ * mac/tclMacInit.c:
+ * unix/tclUnixFile.c:
+ * unix/tclUnixInit.c:
+ * unix/tclUnixPipe.c:
+ * win/tclWin32Dll.c:
+ * win/tclWinFCmd.c:
+ * win/tclWinFile.c:
+ * win/tclWinInit.c: Partial TIP 27 rollback. Following routines
+ restored to return (char *): Tcl_DStringAppend,
+ Tcl_DStringAppendElement, Tcl_JoinPath, Tcl_TranslateFileName,
+ Tcl_ExternalToUtfDString, Tcl_UtfToExternalDString,
+ Tcl_UniCharToUtfDString, Tcl_GetCwd, Tcl_WinTCharToUtf. Also
+ restored Tcl_WinUtfToTChar to return (TCHAR *) and
+ Tcl_UtfToUniCharDString to return (Tcl_UniChar *). Modified
+ some callers. This change recognizes that Tcl_DStrings are
+ de-facto white-box objects.
-Sun Aug 20 00:43:51 1995 Jason Molenda (crash@phydeaux.cygnus.com)
+ * generic/tclDecls.h:
+ * generic/tclPlatDecls.h: make genstubs
- * configure.in: If the system has a functional strtod(), *don't*
- provide one.
+ * generic/tclCmdMZ.c: corrected use of C++-style comment.
-Thu Aug 17 16:04:39 1995 Rob Savoye <rob@darkstar.cygnus.com>
+2002-02-06 Jeff Hobbs <jeffh@ActiveState.com>
- * tcl: Updated to the official tcl7.4 release, plus preserved
- our patches.
+ * tests/scan.test:
+ * generic/tclScan.c (Tcl_ScanObjCmd): corrected scan 0x... %x
+ handling that didn't accept the 0x as a prelude to a base 16
+ number. [Bug #495213]
-Sun Aug 6 11:45:19 1995 Fred Fish <fnf@cygnus.com>
+ * generic/tclCompCmds.c (TclCompileRegexpCmd): made early check
+ for bad RE to stop checking further.
- * Makefile.in (distclean): Remove config.cache & config.log
+ * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): added special case to
+ search for simple 'string map' style regsub calls.
+ Delayed creation of resultPtr object until an initial match is
+ made, as the input string object can then be reused for no matches.
+ (Tcl_StringObjCmd): optimization improvements to the STR_MAP
+ algorithm for zero-length and nocase cases.
-Mon Jun 12 15:46:48 1995 J.T. Conklin <jtc@rtl.cygnus.com>
+ * tests/regexp.test:
+ * tests/regexpComp.test: extra code coverage tests.
- * tclAlloc.c: New file.
- * tcl.h (Tcl_Malloc, Tcl_Realloc, Tcl_Free): New functions.
- (ckalloc, ckrealloc, ckfree): Defined to Tcl_Malloc, Tcl_Free
- respectively when compiling without TCL_MEM_DEBUG.
- * Makefile.in (GENERIC_OBJS): Added tclAlloc.o
- (SRCS): Added tclAlloc.c.
+ * tests/string.test: added 10.18 and 10.19 extra tests.
-Thu Apr 6 19:32:43 1995 Doug Evans <dje@chestnut.cygnus.com>
+ * generic/regc_locale.c (casecmp): slight performance improvement.
- * tclPort.h (gettimeofday): Comment out prototype.
+2002-02-05 Don Porter <dgp@users.sourceforge.net>
-Thu Mar 23 17:58:38 1995 Rob Savoye <rob@thepub.cygnus.com>
+ * library/http/http.tcl:
+ * library/http/pkgIndex.tcl: Corrected use of http::error when
+ ::error was intended. Bump to http 2.4.2.
- * tcl: Upgrade to 7.4.b2. Update configure.in to autoconf 2.2,
- merge in our LynxOS patches.
+2002-02-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-Wed Dec 21 15:12:14 1994 J.T. Conklin (jtc@phishhead.cygnus.com)
+ * unix/tclUnixChan.c (FileOutputProc): Fixed [bug 465765] reported
+ by Dale Talcott <daletalcott@users.sourceforge.net>. Avoid
+ writing nothing into a file as STREAM based implementations will
+ consider this a EOF (if the file is a pipe). Not done in the
+ generic layer as this type of writing is actually useful to
+ check the state of a socket.
- * tclUnixUtil.c: Use __Lynx__ in the conditional which selects
- LynxOS-specific waitpid() prototype.
+ * doc/open.n: Fixed [Bug 511540], added cross-reference to 'pid'
+ as the command to use to retrieve the pid of a command pipeline
+ created via 'open'.
-Mon Dec 19 04:38:49 1994 Angela Marie Thomas <angela@cygnus.com>
+2002-02-01 Jeff Hobbs <jeffh@ActiveState.com>
- * Makefile.in (all): use ${AR_FLAGS}, not ${ARFLAGS} because the
- "make" default for ${ARFLAGS} includes an option, f, which I can't
- find in any man page and breaks builds.
+ * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): handle quirky about case
+ earlier to avoid shimmering problem.
-Tue Jun 7 07:44:31 1994 D. V. Henkel-Wallace (gumby@cygnus.com)
+2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
- * compat/tmpnam.c: handle losing LynxOS mktemp.
+ * tests/io.test: io-39.22 split into two tests, one platform
+ dependent, the other not. -eofchar is not empty on the windows
+ platform.
-Thu May 26 20:15:55 1994 David J. Mackenzie (djm@poseidon.cygnus.com)
+2002-02-01 Vince Darley <vincentdarley@users.sourceforge.net>
- * aclocal.m4 (TCL_LYNX_POSIX): Renamed from AC_LYNX_POSIX.
- Check __GNUC__ value to get POSIX flag right.
- * configure.in: Use new name.
- * configure: Regenerate.
+ * generic/tclTest.c: fix to picky windows compiler problem
+ with the 'MainLoop' function declaration.
-Wed May 4 20:17:46 1994 D. V. Henkel-Wallace (gumby@cygnus.com)
+2002-01-31 Andreas Kupries <andreas_kupries@users.sourceforge.net>
- * compat/tmpnam.c: if you're going to redefine P_tmpdir,
- undefine it first.
+ * win/tclWinFCmd.c: TIP 27: Applied patch fixing CONST warnings on
+ behalf of Don Porter <dgp@users.sourceforge.net>.
- * compat/strerror.c: undefine various error codes which are
- defined in terms of others, where that causes duplicated case
- labels on r/s6000 lynxos 2.2.2.
+2002-01-30 Don Porter <dgp@users.sourceforge.net>
-Sat Apr 23 17:10:13 1994 Bill Cox (bill@rtl.cygnus.com)
+ * generic/tcl.decls:
+ * generic/tcl.h:
+ * generic/tclInt.h: For each interface identified in the TIP 27
+ changes below as a POTENTIAL INCOMPATIBILITY, the source of the
+ incompatibility has been parameterized so that it can be
+ removed. When compiling extension code against the Tcl header
+ files, use the compiler flag -DUSE_NON_CONST to remove the
+ irresolvable source incompatibilities introduced by the TIP 27
+ changes. Resolvable changes are left for extension authors to
+ resolve.
+ * generic/tclDecls.h: make genstubs
+
+2002-01-30 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * doc/FileSystem.3: added documentation for 3 public
+ functions which had been overlooked. Fixes [Bug 507701].
+ * unix/mkLinks: make mklinks
+
+2002-01-29 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * tests/regexpComp.test:
+ * generic/tclCompCmds.c (TclCompileRegexpCmd): enhanced to support
+ -nocase and -- options.
+
+2002-01-28 Mo DeJong <mdejong@users.sourceforge.net>
+
+ * unix/tcl.m4 (SC_LOAD_TCLCONFIG):
+ * win/tcl.m4 (SC_LOAD_TCLCONFIG): Set TCL_LIB_SPEC,
+ TCL_STUB_LIB_SPEC, and TCL_STUB_LIB_PATH to the
+ values of TCL_BUILD_LIB_SPEC, TCL_BUILD_STUB_LIB_SPEC,
+ and TCL_BUILD_STUB_LIB_PATH when tclConfig.sh is loaded
+ from the build directory. A Tcl extension should
+ make use of the non-build versions of these variables
+ since they will work in both cases. This modification
+ was described in TIP 34.
+
+2002-01-28 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * win/tclWinReg.c (regConnectRegistryProc,RecursiveDeleteKey)
+ (DeleteKey,GetKeyNames,GetType,GetValue,OpenSubKey,SetValue):
+ redid the CONSTification as previous changes caused failing tests.
+
+ * tests/regexpComp.test (new):
+ * generic/tclInt.h:
+ * generic/tclBasic.c: added TclCompileRegexpCmd entry
+ * generic/tclCompCmds.c (TclCompileStringCmd): corrected to return
+ TCL_OUT_LINE_COMPILE instead of TCL_ERROR for parsing errors, so
+ it only throws the error for runtime compile, in case the user
+ modifies 'string'.
+ (TclCompileRegexpCmd): first try at a byte-compiled regexp
+ command. It handles static strings and ^$ bounded static strings.
+ (TclCompileAppendCmd): made TclPushVarName call always use
+ TCL_CREATE_VAR as numWords is always > 2 at that point.
- * compat/getcwd.c: The contents of this file was the UCB
- float.h file. Restored the correct contents from devo.
+ * generic/tclExecute.c (TclExecuteByteCode:INST_LIST): correct
+ possibly dangerous decr in macro call.
-Fri Apr 22 11:28:35 1994 Bill Cox (bill@cygnus.com)
+ * win/tclWinInit.c (TclpFindVariable): CONSTification touch-up
- * tclUnixUtil.c: Make a new prototype for waitpid if
- we're compiling under the Lynx version of gcc.
+ * win/tclWinReg.c (OpenSubKey): corrected bug introduced in
+ CONSTification that dropped pointer reference.
-Thu Mar 31 19:36:44 1994 Ken Raeburn (raeburn@cujo.cygnus.com)
+ * ChangeLog.2000 (new file):
+ * ChangeLog: broke changes from 2000 into ChangeLog.2000 to reduce
+ size of the main ChangeLog.
- * install.sh: Since "set -e" is in effect, don't use a test that
- can fail in a while condition; it confuses some shells. Use break
- instead. Use "case" rather than "if [" for efficiency with some
- shells.
+2002-01-28 David Gravereaux <davygrvy@pobox.com>
-Tue Jan 4 17:03:31 1994 Rob Savoye (rob@rtl.cygnus.com)
+ * generic/tclPlatDecls.h: Added preprocessor logic to force a
+ typedef of TCHAR when __STDC__ is defined when using the uncommon
+ -Za compiler switch with the microsoft compiler.
- * All files: Upgraded to Tcl7.3. This version has incompatablities
- with the old versions before 7.0.
+2002-01-27 Don Porter <dgp@users.sourceforge.net>
-Tue Nov 23 13:01:22 1993 Rob Savoye (rob@darkstar.cygnus.com)
+ * doc/package.n: Documented global namespace context for script
+ evaluation by [package require].
- * configure.in: Use AC_HEADER_CHECK for unistd.h.
+2002-01-27 Daniel Steffen <das@users.sourceforge.net>
-Tue Nov 9 19:07:39 1993 Rob Savoye (rob@cygnus.com)
+ * generic/tclInt.decls:
+ * generic/tclIntPlatDecls.h:
+ * mac/tclMacChan.c:
+ * mac/tclMacFCmd.c:
+ * mac/tclMacFile.c:
+ * mac/tclMacInit.c:
+ * mac/tclMacLoad.c:
+ * mac/tclMacResource.c:
+ * mac/tclMacSock.c: TIP 27 CONSTification induced changes
- * tclUnixStr.c (Tcl_ErrnoId): Added cpp tests for duplicate
- defines that choked LynxOS.
+ * tests/event.test:
+ * tests/main.test: added catches/constraints to test that
+ use features that don't exist on the mac.
-Fri Oct 1 17:30:06 1993 Doug Evans (dje@canuck.cygnus.com)
+2002-01-25 Mo DeJong <mdejong@users.sourceforge.net>
- * Makefile.in (tclTest.o): Sun VPATH lossage.
+ Make -eofchar and -translation options read only for
+ server sockets. [Bug 496733]
+
+ * generic/tclIO.c (Tcl_GetChannelOption, Tcl_SetChannelOption):
+ Instead of returning nothing for the -translation option
+ on a server socket, always return "auto". Return the empty
+ string enclosed in quotes for the -eofchar option on
+ a server socket. Fixup -eofchar usage message so that
+ it matches the implementation.
+ * tests/io.test: Add -eofchar tests and -translation tests
+ to ensure options are read only on server sockets.
+ * tests/socket.test: Update tests to account for -eofchar
+ and -translation option changes.
+
+2002-01-25 Don Porter <dgp@users.sourceforge.net>
+
+ * compat/strstr.c (strstr):
+ * generic/tclCmdAH.c (Tcl_FormatObjCmd):
+ * generic/tclCmdIL.c (InfoNameOfExecutableCmd):
+ * generic/tclEnv.c (ReplaceString):
+ * generic/tclFileName.c (ExtractWinRoot):
+ * generic/tclIO.c (FlushChannel,Tcl_BadChannelOption):
+ * generic/tclStringObj.c (AppendUnicodeToUtfRep):
+ * generic/tclThreadTest.c (TclCreateThread):
+ * generic/tclUtf.c (Tcl_UtfPrev):
+ * mac/tclMacFCmd.c (TclpObjListVolumes):
+ * mac/tclMacResource.c (TclMacRegisterResourceFork,
+ BuildResourceForkList):
+ * win/tclWinInit.c (AppendEnvironment): Sought out and eliminated
+ instances of CONST-casting that are no longer needed after the
+ TIP 27 effort.
+
+ * Following is [Patch 501006]
+ * generic/tclInt.decls (Tcl_AddInterpResolvers, Tcl_Export,
+ Tcl_FindNamespace, Tcl_GetInterpResolvers, Tcl_ForgetImport,
+ Tcl_Import, Tcl_RemoveInterpResolvers):
+ * generic/tclNamesp.c (Tcl_Export, Tcl_Import, Tcl_ForgetImport,
+ Tcl_FindNamespace):
+ * generic/tclResolve.c (Tcl_AddInterpResolvers,Tcl_GetInterpResolvers,
+ Tcl_RemoveInterpResolvers): Updated APIs in generic/tclResolve.c
+ and generic/tclNamesp.c according to the guidelines of TIP 27.
+ * generic/tclIntDecls.h: make genstubs
+
+ * Following is [Patch 505630]
+ * doc/AddErrorInfo.3:
+ * generic/tcl.decls (Tcl_LogCommandInfo):
+ * generic/tclBasic.c (Tcl_LogCommandInfo): Updated interfaces
+ of generic/tclBasic.cc according to TIP 27.
+ * generic/tclDecls.h: make genstubs
+
+ * Following is [Patch 506818]
+ * doc/Hash.3:
+ * generic/tcl.decls (Tcl_HashStats):
+ * generic/tclHash.c (Tcl_HashStats): Updated APIs of generic/tclHash.c
+ according to guidelines of TIP 27.
+ * generic/tclDecls.h: make genstubs
+ * generic/tclVar.c (Tcl_ArrayObjCmd): Updated callers.
+
+ * Following is [Patch 506807]
+ * doc/ObjectType.3:
+ * generic/tcl.decls (Tcl_GetObjType):
+ * generic/tclObj.c (Tcl_GetObjType): Updated APIs of generic/tclObj.c
+ according to guidelines of TIP 27.
+ * generic/tclDecls.h: make genstubs
+
+ * Following is [Patch 507304]
+ * doc/Encoding.3:
+ * generic/tcl.decls (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf):
+ * win/tclWin32Dll.c (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf):
+ Updated interfaces in win/tclWin32Dll.c according to TIP 27.
+ * generic/tclPlatDecls.h: make genstubs
+ * generic/tclIOUtil.c (TclpNativeToNormalized):
+ * win/tclWinFCmd.c (TclpObjNormalizePath):
+ * win/tclWinFile.c (TclpFindExecutable,TclpMatchInDirectory,
+ NativeIsExec,NativeStat):
+ * win/tclWinLoad.c (TclpLoadFile):
+ * win/tclWinPipe.c (TclpOpenFile,ApplicationType):
+ * win/tclWinReg.c (regConnectRegistryProc,RecursiveDeleteKey,DeleteKey,
+ GetKeyNames,GetType,GetValue,OpenSubKey,SetValue):
+ * win/tclWinSerial.c (SerialSetOptionProc): Update callers.
+
+ * Following is [Patch 505072]
+ * doc/Concat.3:
+ * doc/Encoding.3:
+ * doc/Filesystem.3:
+ * doc/Macintosh.3:
+ * doc/OpenFileChnl.3
+ * doc/SetResult.3:
+ * doc/SetVar.3:
+ * doc/SplitList.3:
+ * doc/SplitPath.3:
+ * doc/Translate.3:
+ * generic/tcl.h (Tcl_FSMatchInDirectoryProc):
+ * generic/tclInt.h (TclpMatchInDirectory):
+ * generic/tcl.decls (Tcl_Concat,Tcl_GetStringResult,Tcl_GetVar,
+ Tcl_GetVar2,Tcl_JoinPath,Tcl_Merge,Tcl_OpenCommandChannel,Tcl_SetVar,
+ Tcl_SetVar2,Tcl_SplitList,Tcl_SplitPath,Tcl_TranslateFileName,
+ Tcl_ExternalToUtfDString,Tcl_GetEncodingName,Tcl_UtfToExternalDString,
+ Tcl_GetDefaultEncodingDir,Tcl_SetDefaultEncodingDir,
+ Tcl_FSMatchInDirectory,Tcl_MacEvalResource,Tcl_MacFindResource):
+ * generic/tclInt.decls (TclCreatePipeline,TclGetEnv,TclpGetCwd,
+ TclpCreateProcess):
+ * mac/tclMacFile.c (TclpGetCwd):
+ * generic/tclEncoding.c (Tcl_GetDefaultEncodingDir,
+ Tcl_SetDefaultEncodingDir,Tcl_GetEncodingName,
+ Tcl_ExternalToUtfDString,Tcl_UtfToExternalDString, OpenEncodingFile,
+ LoadEscapeEncoding):
+ * generic/tclFileName.c (DoTildeSubst,Tcl_JoinPath,Tcl_SplitPath,
+ Tcl_TranslateFileName):
+ * generic/tclIOUtil.c (Tcl_FSMatchInDirectory):
+ * generic/tclPipe.c (FileForRedirect,TclCreatePipeline,
+ Tcl_OpenCommandChannel):
+ * generic/tclResult.c (Tcl_GetStringResult):
+ * generic/tclUtil.c (Tcl_Concat,Tcl_SplitList,Tcl_Merge):
+ * generic/tclVar.c (Tcl_GetVar,Tcl_GetVar2,Tcl_SetVar,Tcl_SetVar2):
+ * mac/tclMacResource.c (Tcl_MacEvalResource,Tcl_MacFindResource):
+ Updated interfaces of generic/tclEncoding, generic/tclFilename.c,
+ generic/tclIOUtil.c, generic/tclPipe.c, generic/tclResult.c,
+ generic/tclUtil.c, generic/tclVar.c and mac/tclMacResource.c according
+ to TIP 27. Tcl_TranslateFileName rewritten as wrapper around
+ VFS-aware version.
+ ***POTENTIAL INCOMPATIBILITY***
+ Includes source incompatibilities: argv arguments of Tcl_Concat,
+ Tcl_JoinPath, Tcl_OpenCommandChannel, Tcl_Merge; argvPtr arguments of
+ Tcl_SplitList and Tcl_SplitPath.
+ * generic/tclDecls.h:
+ * generic/tclIntDecls.h: make genstubs
+
+ * generic/tclCkalloc.c (MemoryCmd):
+ * generic/tclClock.c (FormatClock):
+ * generic/tclCmdAH.c (Tcl_CaseObjCmd,Tcl_EncodingObjCmd,Tcl_FileObjCmd):
+ * generic/tclCmdIL.c (InfoLibraryCmd,InfoPatchLevelCmd,
+ InfoTclVersionCmd):
+ * generic/tclCompCmds.c (TclCompileForeachCmd):
+ * generic/tclCompCmds.h (TclCompileForeachCmd):
+ * generic/tclCompile.c (TclFindCompiledLocal):
+ * generic/tclEnv.c (TclSetupEnv,TclSetEnv,Tcl_PutEnv,TclGetEnv,
+ EnvTraceProc):
+ * generic/tclEvent.c (Tcl_BackgroundError):
+ * generic/tclIO.c (Tcl_BadChannelOption,Tcl_SetChannelOption):
+ * generic/tclIOCmd.c (Tcl_ExecObjCmd,Tcl_OpenObjCmd):
+ * generic/tclIOSock.c (TclSockGetPort):
+ * generic/tclIOUtil.c (SetFsPathFromAny):
+ * generic/tclLink.c (LinkTraceProc):
+ * generic/tclMain.c (Tcl_Main):
+ * generic/tclNamesp.c (TclTeardownNamespace):
+ * generic/tclProc.c (TclCreateProc):
+ * generic/tclTest.c (TestregexpObjCmd,TesttranslatefilenameCmd,
+ TestchmodCmd,GetTimesCmd,TestsetCmd,TestOpenFileChannelProc1,
+ TestOpenFileChannelProc2,TestOpenFileChannelProc3,AsyncHandlerProc,
+ TestpanicCmd):
+ * generic/tclThreadTest.c (ThreadErrorProc,ThreadEventProc):
+ * generic/tclUtil.c (TclPrecTraceProc):
+ * mac/tclMacFCmd.c (GetFileSpecs):
+ * mac/tclMacFile.c (TclpMatchInDirectory):
+ * mac/tclMacInit.c (TclpInitLibraryPath,Tcl_SourceRCFile):
+ * mac/tclMacOSA.c (tclOSAStore,tclOSALoad):
+ * mac/tclMacResource.c (Tcl_MacEvalResource):
+ * unix/tclUnixFCmd.c (TclpObjNormalizePath):
+ * unix/tclUnixFile.c (TclpMatchInDirectory,TclpGetUserHome,TclpGetCwd,
+ TclpReadLink):
+ * unix/tclUnixInit.c (TclpInitLibraryPath,TclpSetVariables,
+ Tcl_SourceRCFile):
+ * unix/tclUnixPipe.c (TclpOpenFile,TclpCreateTempFile,
+ TclpCreateProcess):
+ * win/tclWinFile.c (TclpGetCwd,TclpMatchInDirectory):
+ * win/tclWinInit.c (TclpInitLibraryPath,Tcl_SourceRCFile,
+ TclpSetVariables):
+ * win/tclWinPipe.c (TclpCreateProcess): Updated callers.
+
+2002-01-24 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclIOUtil.c (SetFsPathFromAny): Corrected tilde-substitution
+ of pathnames where > 1 separator follows the ~. [Bug 504950]
+
+2002-01-24 Jeff Hobbs <jeffh@ActiveState.com>
+
+ * library/http/pkgIndex.tcl:
+ * library/http/http.tcl: don't add port in default case to handle
+ broken servers. http bumped to 2.4.1 [Bug #504508]
+
+2002-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * unix/mkLinks: Regenerated.
+ * doc/CrtChannel.3:
+ * doc/ChnlStack.3: Moved documentation for 'Tcl_GetTopChannel'
+ from 'CrtChannel' to 'ChnlStack'. Added documentation of
+ 'Tcl_GetStackedChannel'. Bug #506147 reported by Mark Patton
+ <msp@users.sourceforge.net>.
+
+2002-01-23 Don Porter <dgp@users.sourceforge.net>
+
+ * win/tclWinFile.c (NativeAccess,NativeStat,NativeIsExec,
+ TclpGetUserHome):
+ * win/tclWinPort.h (TclWinSerialReopen):
+ * win/tclWinSerial.c (TclWinSerialReopen):
+ * win/tclWinSock.c (Tcl_OpenTcpServer): Corrections to earlier
+ TIP 27 changes. Thanks to Andreas Kupries for the feedback.
+ * generic/tclPlatDecls.h: make genstubs
+
+ * doc/GetHostName.3:
+ * doc/GetOpnFl.3:
+ * doc/OpenTcp.3:
+ * tcl.decls (Tcl_GetHostName,Tcl_GetOpenFile,Tcl_OpenTcpClient,
+ Tcl_OpenTclServer):
+ * mac/tclMacSock.c (CreateSocket,Tcl_OpenTcpClient,Tcl_OpenTcpServer,
+ Tcl_GetHostName,GetHostFromString):
+ * unix/tclUnixChan.c (CreateSocket,CreateSocketAddress,
+ Tcl_OpenTcpClient,Tcl_OpenTcpServer,Tcl_GetOpenFile):
+ * unix/tclUnixSock.c (Tcl_GetHostName):
+ * win/tclWinSock.c (CreateSocket,CreateSocketAddress,
+ Tcl_OpenTcpClient,Tcl_OpenTcpServer,Tcl_GetHostName):
+ Updated socket interfaces according to TIP 27.
+ * generic/tclCmdIL.c (InfoHostnameCmd): Updated callers.
+ * generic/tclDecls.h: make genstubs
+
+2002-01-21 David Gravereaux <davygrvy@pobox.com>
+
+ * generic/tclLoadNone.c: TclpLoadFile() didn't match proto of
+ typedef Tcl_FSLoadFileProc. OK'd by vincentdarley.
+ [Patch #502488]
+
+2002-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * generic/tclIO.c (WriteChars): Fix for SF #506297, reported by
+ Martin Forssen <ruric@users.sourceforge.net>. The encoding
+ chosen in the script exposing the bug writes out three intro
+ characters when TCL_ENCODING_START is set, but does not consume
+ any input as TCL_ENCODING_END is cleared. As some output was
+ generated the enclosing loop calls UtfToExternal again, again
+ with START set. Three more characters in the out and still no
+ use of input ... To break this infinite loop we remove
+ TCL_ENCODING_START from the set of flags after the first call
+ (no condition is required, the later calls remove an unset flag,
+ which is a no-op). This causes the subsequent calls to
+ UtfToExternal to consume and convert the actual input.
+
+2002-01-21 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclTest.c: Converted declarations of TestReport file system
+ to more portable form. [Bug 501417].
+
+ * generic/tcl.decls (Tcl_TraceCommand,Tcl_UntraceCommand,
+ Tcl_CommandTraceInfo):
+ * generic/tclCmdMZ.c (Tcl_TraceCommand,Tcl_UntraceCommand,
+ Tcl_CommandTraceInfo): Updated APIs in generic/tclCmdMZ.c
+ according to the guidelines of TIP 27.
+ * generic/tclDecls.h: make genstubs
+
+2002-01-18 Don Porter <dgp@users.sourceforge.net>
-Tue Aug 17 11:23:27 1993 david d `zoo' zuhn (zoo@rtl.cygnus.com)
+ * win/tclWinChan.c:
+ * win/tclWinFCmd.c:
+ * win/tclWinFile.c: Overlooked callers of Tcl_FSGetNativePath
- * Makefile.in (install): don't install *.tcl all at once
+ * win/tclWinDde.c:
+ * win/tclWinReg.c: Overlooked callers of Tcl_GetIndexFromObj
-Thu Jul 8 09:24:47 1993 Doug Evans (dje@canuck.cygnus.com)
+2002-01-18 Daniel Steffen <das@users.sourceforge.net>
- * Makefile.in: Add stuff needed to make Sun VPATH work.
+ * generic/tclThreadTest.c:
+ * mac/tclMacChan.c:
+ * mac/tclMacFCmd.c:
+ * mac/tclMacFile.c:
+ * mac/tclMacLoad.c:
+ * mac/tclMacResource.c: TIP 27 CONSTification broke the mac
+ build in a number of places.
+
+2002-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * generic/tclIOCmd.c (Tcl_GetsObjCmd): Fixed bug #504642 as
+ reported by Brian Griffin <bgriffin@users.sourceforge.net>,
+ using his patch. Before the patch the generic I/O layer held an
+ unannounced reference to the interp result to store the read
+ line into. This unfortunately has disastrous results if the
+ channel driver executes a tcl script to perform its operation,
+ this freeing the interp result. In that case we are
+ dereferencing essentially a dangling reference. It is not truly
+ dangling because the object is in the free list, but this only
+ causes us to smash the free list and have the error occur later
+ somewhere else. The patch simply creates a new object for the
+ line and later sets it into the interp result when we are done
+ with reading.
+
+2002-01-16 Mo DeJong <mdejong@users.sourceforge.net>
+
+ * unix/tcl.m4 (SC_LOAD_TCLCONFIG):
+ * win/tcl.m4 (SC_LOAD_TCLCONFIG): Subst TCL_DBGX
+ into TCL_STUB_LIB_FILE and TCL_STUB_LIB_FLAG
+ variables so that an extension does not need
+ to subst TCL_DBGX into its makefile. [Tk Bug 504356]
+
+2002-01-16 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/FileSystem.3:
+ * doc/GetCwd.3:
+ * doc/GetIndex.3:
+ * generic/tcl.decls (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
+ Tcl_GetCwd, Tcl_FSFileAttrStrings, Tcl_FSGetNativePath,
+ Tcl_FSGetTranslatedStringPath):
+ * generic/tcl.h (Tcl_FSFileAttrStringsProc):
+ * generic/tclFCmd.c (TclFileAttrsCmd):
+ * generic/tclIOUtil.c (Tcl_GetCwd,NativeFileAttrStrings,
+ Tcl_FSFileAttrStrings,Tcl_FSGetTranslatedStringPath,
+ Tcl_FSGetNativePath):
+ * generic/tclIndexObj.c (Tcl_GetIndexFromObj,Tcl_GetIndexFromObjStruct):
+ More TIP 27 updates in tclIOUtil.c and tclIndexObj.c that were
+ overlooked before. [Patch 504671]
+ ***POTENTIAL INCOMPATIBILITY***
+ Includes a source incompatibility in the tablePtr arguments of
+ the Tcl_GetIndexFromObj* routines.
+ * generic/tclDecls.h: make genstubs
+
+ * generic/tclBinary.c (Tcl_BinaryObjCmd):
+ * generic/tclClock.c (Tcl_ClockObjCmd):
+ * generic/tclCmdAH.c (Tcl_EncodingObjCmd, Tcl_FileObjCmd):
+ * generic/tclCmdIL.c (Tcl_InfoObjCmd,Tcl_LsearchObjCmd,Tcl_LsortObjCmd):
+ * generic/tclCmdMZ.c (Tcl_TraceObjCmd,Tcl_RegexpObjCmd,Tcl_RegsubObjCmd,
+ Tcl_StringObjCmd,Tcl_SubstObjCmd,Tcl_SwitchObjCmd,
+ TclTraceCommandObjCmd,TclTraceVariableObjCmd):
+ * generic/tclCompCmds.c (TclCompileStringCmd):
+ * generic/tclEvent.c (Tcl_UpdateObjCmd):
+ * generic/tclFileName.c (Tcl_GlobObjCmd):
+ * generic/tclIO.c (Tcl_FileEventObjCmd):
+ * generic/tclIOCmd.c (Tcl_SeekObjCmd,Tcl_ExecObjCmd,Tcl_SocketObjCmd,
+ Tcl_FcopyObjCmd):
+ * generic/tclInterp.c (Tcl_InterpObjCmd,SlaveObjCmd):
+ * generic/tclNamesp.c (Tcl_NamespaceObjCmd):
+ * generic/tclPkg.c (Tcl_PackageObjCmd):
+ * generic/tclTest.c (Tcltest_Init,TestencodingObjCmd,TestgetplatformCmd,
+ TestlocaleCmd,TestregexpObjCmd,TestsaveresultCmd,
+ TestGetIndexFromObjStructObjCmd,TestReportFileAttrStrings):
+ * generic/tclTestObj.c (TestindexObjCmd,TeststringObjCmd):
+ * generic/tclTimer.c (Tcl_AfterObjCmd):
+ * generic/tclVar.c (Tcl_ArrayObjCmd):
+ * mac/tclMacFCmd.c (SetFileFinderAttributes):
+ * unix/tclUnixChan.c (TclpOpenFileChannel):
+ * unix/tclUnixFCmd.c (tclpFileAttrStrings):
+ * unix/tclUnixFile.c (TclpObjAccess,TclpObjChdir,TclpObjStat,
+ TclpObjLstat):
+ * win/tclWinFCmd.c (tclpFileAttrStrings): Updated callers.
-Thu May 6 12:04:52 1993 Rob Savoye (rob at darkstar.cygnus.com)
+ * doc/RegExp.3:
+ * doc/Utf.3:
+ * generic/tcl.decls:
+ * generic/tclInt.decls:
+ * generic/tclRegexp.c:
+ * generic/tclUtf.c: Updated APIs in generic/tclUtf.c and
+ generic/tclRegexp.c according to the guidelines of TIP 27.
+ [Patch 471509]
- * Makefile.in: Install the manpages too.
+ * generic/regc_locale.c (element,cclass):
+ * generic/tclCmdMZ.c (Tcl_StringObjCmd):
+ * generic/tclFileName.c (TclpGetNativePathType,SplitMacPath):
+ * generic/tclIO.c (ReadChars):
+ * mac/tclMacLoad.c (TclpLoadFile):
+ * win/tclWinFile.c (TclpGetUserHome): Updated callers.
-Tue May 4 22:01:24 1993 Rob Savoye (rob at darkstar.cygnus.com)
+ * generic/tclDecls.h:
+ * generic/tclIntDecls.h: make genstubs
+
+ * doc/ParseCmd.3 (Tcl_ParseVar):
+ * generic/tcl.decls (Tcl_ParseVar):
+ * generic/tclParse.c (Tcl_ParseVar):
+ * generic/tclTest.c (TestparsevarObjCmd): Updated APIs in
+ generic/tclParse.c according to the guidelines of TIP 27. Updated
+ callers. [Patch 501046]
+ * generic/tclDecls.h: make genstubs
+
+ * generic/tcl.decls (Tcl_RecordAndEval):
+ * generic/tclDecls.h: make genstubs
+ * generic/tclHistory.c (Tcl_RecordAndEval): Updated APIs in
+ generic/tclHistory.c according to the guidelines of TIP 27.
+ [Patch 504091]
+
+ * doc/CrtSlave.3:
+ * generic/tcl.decls (Tcl_CreateAlias, Tcl_CreateAliasObj,
+ Tcl_CreateSlave, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_GetSlave):
+ * generic/tclInterp.c (Tcl_CreateAlias, Tcl_CreateAliasObj,
+ Tcl_CreateSlave, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_GetSlave):
+ Updated APIs in the file generic/tclInterp.c according to the
+ guidelines of TIP 27. [Patch 501371]
+ ***POTENTIAL INCOMPATIBILITY***
+ Includes a source incompatibility in the targetCmdPtr arguments of
+ the Tcl_GetAlias* routines.
+
+ * generic/tclDecls.h: make genstubs
+
+2002-01-15 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/SetErrno.3 (Tcl_ErrnoMsg): Corrected documentation for
+ Tcl_ErrnoMsg; it takes an integer argument. Thanks to Georgios
+ Petasis. [Bug 468183]
+
+ * doc/AddErrInfo.3 (Tcl_PosixError):
+ * doc/Eval.3 (Tcl_EvalFile):
+ * doc/FileSystem.c (Tcl_FSOpenFileChannel,Tcl_FSOpenFileChannelProc):
+ * doc/OpenFileChnl.3 (Tcl_OpenFileChannel):
+ * doc/SetErrno.3 (Tcl_ErrnoId,Tcl_ErrnoMsg):
+ * doc/Signal.3 (Tcl_SignalId,Tcl_SignalMsg):
+ * generic/tcl.decls (Tcl_ErrnoId,TclErrnoMsg,Tcl_EvalFile,
+ Tcl_OpenFileChannel,Tcl_PosixError,Tcl_SignalId,Tcl_SignalMsg,
+ Tcl_FSOpenFileChannel):
+ * generic/tcl.h (Tcl_FSOpenFileChannelProc):
+ * generic/tclIO.c (FlushChannel):
+ * generic/tclIOUtil.c (Tcl_OpenFileChannel,Tcl_EvalFile,TclGetOpenMode,
+ Tcl_PosixError,Tcl_FSOpenFileChannel):
+ * generic/tclInt.decls (TclGetOpenMode):
+ * generic/tclInt.h (TclOpenFileChannelProc_,TclGetOpenMode,
+ TclpOpenFileChannel):
+ * generic/tclPipe.c (TclCleanupChildren):
+ * generic/tclPosixStr.c (Tcl_ErrnoId,Tcl_ErrnoMsg,Tcl_SignalId,
+ Tcl_SignalMsg):
+ * generic.tclTest.c (PretendTclpOpenFileChannel,
+ TestOpenFileChannelProc1,TestOpenFileChannelProc2,
+ TestOpenFileChannelProc3,TestReportOpenFileChannel):
+ * mac/tclMacChan.c (TclpOpenFileChannel):
+ * unix/tclUnixChan.c (TclpOpenFileChannel):
+ * win/tclWinChan.c (TclpOpenFileChannel): Updated APIs in
+ generic/tclIOUtil.c and generic/tclPosixStr.c according to the
+ guidelines of TIP 27. Updated callers. [Patch 499196]
- * tclUnix.h: Don't set TCL_PID_T anymore. FInd the right dirent.h.
- * configure.in: Handle no pid_t in sys/types.h. Also also check
- for dirent.h.
- * Makefile.in: Let INSTALL_PROGRAM and INSTALL_DATA come from
- configure.
+ * generic/tclDecls.h:
+ * generic/tclIntDecls.h: make genstubs
-Fri Apr 16 07:25:07 1993 Fred Fish (fnf@lisa.cygnus.com)
+ * doc/CrtChannel.3:
+ * doc/OpenFileChnl.3:
+ * generic/tcl.decls:
+ * generic/tclIO.h:
+ * generic/tclIO.c (DoWrite, Tcl_RegisterChannel, Tcl_GetChannel,
+ Tcl_CreateChannel, Tcl_GetChannelName, CloseChannel, Tcl_Write,
+ Tcl_WriteRaw, Tcl_Ungets, Tcl_BadChannelOption, Tcl_GetChannelOption,
+ Tcl_SetChannelOption, Tcl_GetChannelNamesEx, Tcl_ChannelName):
+ Updated APIs in the file generic/tclIO.c according to the guidelines
+ of TIP 27. Several minor documentation corrections as well.
+ [Patch 503565]
+ * generic/tclDecls.h: make genstubs
+
+ * generic/tcl.h (Tcl_DriverOutputProc, Tcl_DriverGetOptionProc,
+ Tcl_DriverSetOptionProc):
+ * generic/tclIOGT.c (TransformOutputProc, TransformGetOptionProc,
+ TransformSetOptionProc):
+ * mac/tclMacChan.c (FileOutput, StdIOOutput):
+ * man/tclMacSock.c (TcpGetOptionProc, TcpOutput):
+ * unix/tclUnixChan.c (FileOutputProc, TcpGetOptionProc, TcpOutputProc,
+ TtyGetOptionProc, TtySetOptionProc):
+ * unix/tclUnixPipe.c (PipeOuputProc):
+ * win/tclWinChan.c (FileOutputProc):
+ * win/tclWinConsole.c (ConsleOutputProc):
+ * win/tclWinPipe.c (PipeOuputProc):
+ * win/tclWinSerial.c (SerialOutputProc, SerialGetOptionProc,
+ SerialSetOptionProc):
+ * win/tclWinSock.c (TcpGetOptionProc, TcpOutput): Updated channel
+ driver interface according to the guidelines of TIP 27. See also
+ [Bug 500348].
- * configure (DEFS): When defining "-Dconst=" define "-DCONST="
- as well, for the sake of things in compat/* that use it.
+ * doc/CrtChannel.3:
+ * generic/tcl.h:
+ * generic/tclIO.c:
+ * generic/tclIO.h:
+ * generic/tclInt.h:
+ * tools/checkLibraryDoc.tcl:
+ Moved Tcl_EolTranslation enum declaration from generic/tcl.h to
+ generic/tclInt.h (renamed to TclEolTranslation). It is not used
+ anywhere in Tcl's public interface.
- * Makefile.in (opendir.c): Add missing ../compat/..
+2002-01-14 Don Porter <dgp@users.sourceforge.net>
-Mon Apr 5 10:56:28 1993 Rob Savoye (rob@cygnus.com)
+ * doc/GetIndex.3:
+ * doc/WrongNumArgs.3:
+ * generic/tcl.decls (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
+ Tcl_WrongNumArgs):
+ * generic/tclIndexObj.c (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
+ Tcl_WrongNumArgs): Updated APIs in the file generic/tclIndexObj.c
+ according to the guidelines of TIP 27. [Patch 501491]
+ * generic/tclDecls.h: make genstubs
- * testsuite/config/unix-tcl.exp: Use tcl/tclTest for test code
- driver.
- * Makefile.in, testsuite/*.in, testsuite/tcl.tests/*.in: Don't use
- Cygnus configure anymore.
+2002-01-11 Mo DeJong <mdejong@users.sourceforge.net>
-Wed Mar 24 02:09:33 1993 david d `zoo' zuhn (zoo at poseidon.cygnus.com)
+ * unix/configure: Regen.
+ * unix/configure.in:
+ * win/configure: Regen.
+ * win/configure.in: Use ${libdir} instead of ${exec_prefix}/lib
+ to properly support the --libdir option to configure. [Bug 489370]
- * Makefile.in: add installcheck & dvi targets
+2002-01-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
-Fri Mar 19 21:07:25 1993 david d `zoo' zuhn (zoo at cirdan.cygnus.com)
+ * win/tclWinSerial.c (SerialSetOptionProc): Applied patch for SF
+ bug #500348 supplied by Rolf Schroedter
+ <schroedter@users.sourceforge.net>. The function modified the
+ contents of the the 'value' string and now does not do this
+ anymore. This is a followup to the change made on 2001-12-17.
- * tclEnv.c: disable putenv. no one uses it.
+2002-01-11 David Gravereaux <davygrvy@pobox.com>
-Mon Feb 22 07:54:03 1993 Mike Werner (mtw@poseidon.cygnus.com)
+ * win/makefile.vc: Removed -GD compiler option. It was intended
+ for future use, but MS is again changing the future at their whim.
+ The D4002 warning was harmless though, but someone using VC .NET
+ logged it as a concern. [Bug #501565]
- * tcl/testsuite: made modifications to testcases, etc., to allow
- them to work properly given the reorganization of deja-gnu and the
- relocation of the testcases from deja-gnu to a "tool" subdirectory.
+2002-01-11 Mo DeJong <mdejong@users.sourceforge.net>
-Sun Feb 21 10:55:55 1993 Mike Werner (mtw@poseidon.cygnus.com)
+ * unix/Makefile.in: Burn Tcl build directory
+ into tcltest executable to avoid crashes caused
+ by ld loading a previously installed version
+ of the tcl shared library. [Bug 218110]
- * tcl/testsuite: Initial creation of tcl/testsuite.
- Migrated dejagnu testcases and support files for testing nm to
- tcl/testsuite from deja-gnu. These files were moved "as is"
- with no modifications. This migration is part of a major overhaul
- of dejagnu. The modifications to these testcases, etc., which
- will allow them to work with the new version of dejagnu will be
- made in a future update.
+2002-01-10 Don Porter <dgp@users.sourceforge.net>,
+ Kevin Kenny <kennykb@users.sourceforge.net>
+
+ * unix/tclLoadDld.c (TclpLoadFile): syntax error: unbalanced
+ parens. Kevin notes that it's far from clear that this file is
+ ever included in an actual build; Linux without dlopen appears to
+ be a nonexistent configuration.
+
+2002-01-08 Don Porter <dgp@users.sourceforge.net>,
+ Kevin Kenny <kennykb@users.sourceforge.net>
+
+ * doc/StaticPkg.3 (Tcl_StaticPackage):
+ * generic/tcl.decls (Tcl_StaticPackage):
+ * generic/tclDecls.h (Tcl_StaticPackage):
+ * generic/tclInt.decls (TclGuessPackageName):
+ * generic/tclInt.h (TclGuessPackageName):
+ * generic/tclLoad.c (Tcl_StaticPackage):
+ * generic/tclLoadNone.c (TclGuessPackageName):
+ * mac/tclMacLoad.c (TclGuessPackageName):
+ * unix/tclLoadAout.c (TclGuessPackageName):
+ * unix/tclLoadDl.c (TclGuessPackageName):
+ * unix/tclLoadDld.c (TclGuessPackageName):
+ * unix/tclLoadDyld.c (TclGuessPackageName):
+ * unix/tclLoadNext.c (TclGuessPackageName):
+ * unix/tclLoadOSF.c (TclGuessPackageName):
+ * unix/tclLoadShl.c (TclGuessPackageName):
+ * win/tclWinLoad.c (TclGuessPackageName): Updated APIs in
+ the files */tcl*Load*.c according to the guidelines of TIP 27.
+ [Patch 501096]
+
+2002-01-09 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclTest.c (MainLoop):
+ * tests/main.test (Tcl_Main-1.{3,4,5,6}): Corrected some non-portable
+ tests from the new Tcl_Main changes. Thanks to Kevin Kenny.
+
+2002-01-07 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclEvent.c (TclInExit):
+ * generic/tclIOUtil.c (SetFsPathFromAbsoluteNormalized,
+ SetFsPathFromAny,Tcl_FSNewNativePath,DupFsPathInternalRep):
+ * generic/tclListObj.c (TclLsetList,TclLsetFlat): Added some type
+ casts to satisfy picky compilers.
+
+ * generic/tclMain.c: Bug fix: neglected the NULL case in
+ TclGetStartupScriptFileName(). Broke Tk/wish.
+
+2002-01-05 Don Porter <dgp@users.sourceforge.net>
+
+ * doc/Tcl_Main.3:
+ * generic/tclMain.c: Substantial rewrite and expanded documentation
+ of Tcl_Main to correct a number of bugs and flaws:
+
+ * Interactive Tcl_Main can now enter a main loop, exit
+ that loop and continue interactive operations. The loop
+ may even exit in the midst of interactive command typing
+ without loss of the partial command. [Bugs 486453, 474131]
+ * Tcl_Main now gracefully handles deletion of its master
+ interpreter.
+ * Interactive Tcl_Main can now operate with non-blocking stdin
+ * Interactive Tcl_Main can now detect EOF on stdin even in
+ mid-command. [Bug 491341]
+ * Added VFS-aware internal routines for managing the
+ startup script selection.
+ * Tcl variable 'tcl_interactive' is now linked to C variable
+ 'tty' so that one can disable/enable interactive prompts
+ at the script level when there is no startup script. This
+ is meant for use by the test suite.
+ * Consistent use of the Tcl libraries standard channels as
+ returned by Tcl_GetStdChannel(); as opposed to the channels
+ named 'stdin', 'stdout', and 'stderr' in the master interp,
+ which can be different or unavailable.
+ * Tcl_Main now calls Tcl_Exit() if evaluation of [exit] in the
+ master interpreter returns, assuring Tcl_Main does not return.
+ * Documented Tcl_Main's absence from public stub table
+ * Documented that Tcl_Main does not return.
+ * Documented Tcl variables set by Tcl_Main.
+ * All prompts are done from a single procedure, Prompt.
+ * Use of Tcl_Obj-enabled interfaces everywhere.
+
+ * generic/tclInt.decls (TclGetStartupScriptPath,
+ TclSetStartupScriptPath): New internal VFS-aware routines for
+ managing the startup script of Tcl_Main.
+ * generic/tclIntDecls.h:
+ * generic/tclStubInit.c: make genstubs
-Thu Feb 18 11:31:05 1993 Fred Fish (fnf@cygnus.com)
+ * generic/tclTest.c (TestsetmainloopCmd,TestexitmainloopCmd,
+ Tcltest_Init,TestinterpdeleteCmd):
+ * tests/main.test (new): Added new file to test suite that
+ thoroughly tests generic/tclMain.c; added some new test commands
+ for testing Tcl_SetMainLoop().
- * tclEnv.c (putenv): On at least the Sun and SVR4, and possibly
- most other systems, the argument is just "char *", not
- "const char *".
+2002-01-04 Don Porter <dgp@users.sourceforge.net>
-Sat Dec 26 11:13:40 1992 Fred Fish (fnf@cygnus.com)
+ * doc/Alloc.3:
+ * doc/Concat.3:
+ * doc/CrtMathFnc.3:
+ * doc/Hash.3:
+ * doc/Interp.3:
+ * doc/LinkVar.3:
+ * doc/ObjectType.3:
+ * doc/PkgRequire.3:
+ * doc/Preserve.3:
+ * doc/SetResult.3:
+ * doc/SplitList.3:
+ * doc/SplitPath.3:
+ * doc/TCL_MEM_DEBUG.3: Updated documentation to describe the ckalloc,
+ ckfree, ckrealloc, attemptckalloc, and attemptckrealloc macros, and
+ to accurately describe when and how they are used. [Bug 497459]
- * tclUnix.h (fseek): Returns int, not long. True for both
- ANSI-C and traditional C unix environments.
+ * generic/tclThreadJoin.c (TclRememberJoinableThread,TclJoinThread):
+ Replaced Tcl_Alloc and Tcl_Free calls with ckalloc and ckfree so that
+ memory debugging is supported.
-Wed Dec 16 11:02:29 1992 Ian Lance Taylor (ian@cygnus.com)
+2002-01-04 Daniel Steffen <das@users.sourceforge.net>
- * configure.in: check for gettimeofday, and define TCL_GETTOD
- accordingly.
- * configure: regenerated.
+ * mac/tclMacTime.c (TclpGetTZName): fix for daylight savings TZName bug
-Fri Nov 27 19:09:03 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com)
+2002-01-03 Don Porter <dgp@users.sourceforge.net>
- * Makefile.in: don't make TCL_INCLUDE a subdir of $(includedir)
+ * doc/FileSystem.3:
+ * generic/tclIOUtil.c: Updated some old uses of "fileName" to
+ new VFS terminology, "pathPtr".
-Fri Nov 20 10:15:55 1992 Ian Lance Taylor (ian@cygnus.com)
+2002-01-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * Makefile.in (INSTALL): Default to @INSTALL@, not install -c.
- (test): get tests from $(srcdir).
+ * tests/basic.test (basic-39.4): Greatly simplified test while
+ still leaving it so that it crashes when run without the fix to
+ the [foreach] implementation.
+ * generic/tclCmdAH.c (Tcl_ForeachObjCmd): Stopped Bug #494348 from
+ happening by not trying to be so clever with cacheing; if nothing
+ untoward is happening anyway, the less efficient technique will
+ only add a few instruction cycles (one function call and a few
+ derefs/assigns per list per iteration, with no change in the
+ number of tests) and if something odd *is* going on, the code is
+ now far more robust.
-Sun Nov 8 21:56:26 1992 david d `zoo' zuhn (zoo at cirdan.cygnus.com)
+ * tests/basic.test (basic-39.4): Reproducable script from Bug #494348
- * Makefile.in: install .tcl files from $(srcdir)/library
+2002-01-02 Donal K. Fellows <fellowsd@cs.man.ac.uk>
- * New file for GNU/Cygnus distribution of TCL.
+ * tests/util.test (Wrapper_Tcl_StringMatch,util-5.*): Rewrote so
+ the test is performed with the right internal function since
+ [string match] no longer uses Tcl_StringCaseMatch internally.
+ * tests/string.test (string-11.51):
+ * generic/tclUtf.c (Tcl_UniCharCaseMatch):
+ * generic/tclUtil.c (Tcl_StringCaseMatch): Fault with matching
+ case-insensitive non-ASCII patterns containing upper case
+ characters. [Bug #233257]
+ ******************************************************************
+ *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
+ *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
+ *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
+ ******************************************************************
README: Tcl
- This is the Tcl 8.3.2 source distribution.
- You can get any release of Tcl from:
- http://dev.scriptics.com/registration/<version>.tml
+ This is the Tcl 8.4.1 source distribution.
Tcl/Tk is also available through NetCVS:
- http://dev.scriptics.com/software/tcltk/netcvs.html
+ http://tcl.sourceforge.net/
+ You can get any source release of Tcl from the file distributions
+ link at the above URL.
RCS: @(#) $Id$
1. Introduction
---------------
-Tcl provides a powerful platform for creating integration
-applications that tie together diverse applications, protocols,
-devices, and frameworks. When paired with the Tk toolkit, Tcl
-provides the fastest and most powerful way to create GUI applications
-that run on PCs, Unix, and the Macintosh. Tcl can also be used for a
-variety of web-related tasks and for creating powerful command
-languages for applications.
+Tcl provides a powerful platform for creating integration applications that
+tie together diverse applications, protocols, devices, and frameworks.
+When paired with the Tk toolkit, Tcl provides the fastest and most powerful
+way to create GUI applications that run on PCs, Unix, and the Macintosh.
+Tcl can also be used for a variety of web-related tasks and for creating
+powerful command languages for applications.
-Tcl is maintained, enhanced, and distributed freely as a
-service to the Tcl community by Scriptics Corporation.
-The official home for Tcl/Tk is on the Scriptics Web site:
+Tcl is maintained, enhanced, and distributed freely by the Tcl community.
+The home for Tcl/Tk sources and bug/patch database is on SourceForge:
- http://dev.scriptics.com
+ http://tcl.sourceforge.net/
+
+with the Tcl Developer Xchange hosted at:
+
+ http://www.tcl.tk/
Tcl is a freely available open source package. You can do virtually
anything you like with it, such as modifying it, redistributing it,
"license.terms" for complete information.
2. Documentation
----------------
+----------------
Extensive documentation is available at our website.
The home page for this release, including new features, is
- http://dev.scriptics.com/software/tcltk/8.3.html
+ http://www.tcl.tk/software/tcltk/8.4.html
-Detailed release notes can be found at
- http://dev.scriptics.com/software/tcltk/relnotes/tcl8.3.2.txt
+Detailed release notes can be found at the file distributions page
+by clicking on the relevant version.
+ http://sourceforge.net/project/showfiles.php?group_id=10894
Information about Tcl itself can be found at
- http://dev.scriptics.com/scripting/
+ http://www.tcl.tk/scripting/
-There are many Tcl books on the market. Most are listed at
- http://dev.scriptics.com/resource/doc/books/
+There have been many Tcl books on the market. Most are listed at
+ http://www.tcl.tk/resource/doc/books/
2a. Unix Documentation
----------------------
ditroff -man Tcl.n
-to print Tcl.n. If Tcl has been installed correctly and your "man"
-program supports it, you should be able to access the Tcl manual entries
-using the normal "man" mechanisms, such as
+to print Tcl.n. If Tcl has been installed correctly and your "man" program
+supports it, you should be able to access the Tcl manual entries using the
+normal "man" mechanisms, such as
man Tcl
2b. Windows Documentation
-------------------------
-The "doc" subdirectory in this release contains a complete set of
-Windows help files for Tcl. Once you install this Tcl release, a
-shortcut to the Windows help Tcl documentation will appear in the
-"Start" menu:
+The "doc" subdirectory in this release contains a complete set of Windows
+help files for Tcl. Once you install this Tcl release, a shortcut to the
+Windows help Tcl documentation will appear in the "Start" menu:
Start | Programs | Tcl | Tcl Help
3. Compiling and installing Tcl
-------------------------------
-There are brief notes in the unix/README, win/README, and mac/README
-about compiling on these different platforms. There is additional
-information about building Tcl from sources at
- http://dev.scriptics.com/support/howto/compile.html
+There are brief notes in the unix/README, win/README, and mac/README about
+compiling on these different platforms. There is additional information
+about building Tcl from sources at
+ http://www.tcl.tk/doc/howto/compile.html
4. TclPro Development tools
---------------------
+---------------------------
+
+A high quality set of commercial quality development tools is available to
+accelerate your Tcl application development. The TclPro product provides a
+debugger, static code checker, packaging utility, and bytecode compiler.
+TclPro was open-sourced when Scriptics/Ajuba was acquired by Interwoven.
+Visit its home at SourceForge for more information and source/binaries:
-A high quality set of commercial development tools is now available to
-accelerate your Tcl application development. Scriptics' TclPro
-product provides a debugger, static code checker, packaging utility,
-and bytecode compiler. Visit the Scriptics Web site at:
+ http://tclpro.sourceforge.net/
- http://dev.scriptics.com/tclpro
+ActiveState has picked up support for commercial Tcl development tools.
+More information can be found at
-for more information on TclPro and for a free evaluation download.
+ http://www.ActiveState.com/Tcl
5. Tcl newsgroup
----------------
-There is a network news group "comp.lang.tcl" intended for the
-exchange of information about Tcl, Tk, and related applications. The
-newsgroup is a great place to ask general information questions. For
-bug reports, please see the "Support and bug fixes" section below.
+There is a USENET news group, "comp.lang.tcl", intended for the exchange of
+information about Tcl, Tk, and related applications. The newsgroup is a
+great place to ask general information questions. There is also
+a USENET news group, "comp.lang.tcl.announce", intended to announce new
+releases of software, training, and more. For bug reports, please
+see the "Support and bug fixes" section below.
6. Tcl contributed archive
--------------------------
Many people have created exciting packages and applications based on Tcl
and/or Tk and made them freely available to the Tcl community. An archive
-of these contributions is kept on the machine ftp.neosoft.com. You
-can access the archive using anonymous FTP; the Tcl contributed archive is
-in the directory "/pub/tcl". The archive also contains several FAQ
-("frequently asked questions") documents that provide solutions to problems
-that are commonly encountered by TCL newcomers.
+of these contributions is kept on the machine ftp://archives.tcl.tk/pub/tcl
+(aka ftp://ftp.procplace.com/pub/tcl). You can access the archive using
+anonymous FTP. The archive also contains several FAQ ("frequently asked
+questions") documents that provide solutions to problems that are commonly
+encountered by Tcl newcomers.
7. Tcl Resource Center
----------------------
-Visit http://dev.scriptics.com/resource/ to see an annotated index of
+Visit http://www.tcl.tk/resource/ to see an annotated index of
many Tcl resources available on the World Wide Web. This includes
papers, books, and FAQs, as well as development tools, extensions,
applications, binary releases, and patches. You can also recommend
8. Mailing lists
----------------
-A couple of Mailing List have been set up to discuss Macintosh or
-Windows related Tcl issues. To subscribe send a message to:
-
- wintcl-request@tclconsortium.org
- mactcl-request@tclconsortium.org
-
-In the body of the message (the subject will be ignored) put:
-
- subscribe mactcl Joe Smith
-
-Replace Joe Smith with your real name, of course. (Use wintcl
-instead of mactcl if you're interested in the Windows list.) If you
-would just like to receive more information about the list without
-subscribing put the line:
-
- information mactcl
-
-(or wintcl) in the body instead.
+Several mailing lists are hosted at SourceForge to discuss development or
+use issues (like Macintosh and Windows topics). For more information and
+to subscribe, visit:
+
+ http://sourceforge.net/projects/tcl/
+
+and go to the Mailing Lists page.
9. Support and Training
------------------------
-Scriptics is very interested in receiving bug reports, patches, and
-suggestions for improvements. We prefer that you send this
-information to us via the bug form on the Scriptics Web site, rather
-than emailing us directly. The bug form is at:
+We are very interested in receiving bug reports, patches, and suggestions
+for improvements. We prefer that you send this information to us via the
+bug form at SourceForge, rather than emailing us directly. The bug
+database is at:
- http://dev.scriptics.com/ticket/
+ http://tcl.sourceforge.net/
The bug form was designed to give uniform structure to bug reports as
well as to solicit enough information to minimize followup questions.
-The bug form also includes an option to automatically post your report
-on comp.lang.tcl. We strongly recommend that you select this option
-because someone else who reads comp.lang.tcl may be able to offer a
-solution.
We will log and follow-up on each bug, although we cannot promise a
-specific turn-around time. Enhancements may take longer and may not
-happen at all unless there is widespread support for them (we're
-trying to slow the rate at which Tcl/Tk turns into a kitchen sink).
-It's very difficult to make incompatible changes to Tcl/Tk at this
-point, due to the size of the installed base.
-
-The Tcl community is too large for us to provide much individual
-support for users. If you need help we suggest that you post
-questions to comp.lang.tcl. We read the newsgroup and will attempt to
-answer esoteric questions for which no-one else is likely to know the
-answer. In addition, Tcl/Tk support and training are available
-commercially from Scriptics at:
-
- http://dev.scriptics.com/training
-
-Also see the following Web site for links to other organizations that
-offer Tcl/Tk training:
-
- http://www.scriptics.com/resource/community/commercial/training
+specific turn-around time. Enhancements, reported via the Feature
+Requests form at the same web site, may take longer and may not happen
+at all unless there is widespread support for them (we're trying to
+slow the rate at which Tcl/Tk turns into a kitchen sink). It's very
+difficult to make incompatible changes to Tcl/Tk at this point, due to
+the size of the installed base.
+
+The Tcl community is too large for us to provide much individual support
+for users. If you need help we suggest that you post questions to
+comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric
+questions for which no one else is likely to know the answer. In addition,
+see the following Web site for links to other organizations that offer
+Tcl/Tk training:
+
+ http://www.tcl.tk/resource/community/commercial/training
10. Thank You
-------------
We'd like to express our thanks to the Tcl community for all the
helpful suggestions, bug reports, and patches we have received.
Tcl/Tk has improved vastly and will continue to do so with your help.
-
-
proper handling of async callbacks (new options), version is now at 2.3
(tamhankar, welch)
-2000-03 (speed improvements) speedup in Windows filename handling (newman)
+2000-03 (performance enhancement) speedup in Windows filename handling (newman)
and ==/!= empty string in exprs. (hobbs)
2000-03-27 (bug fix) added uniq'ing test to namespace export list to
--- Released 8.3.1, April 26, 2000 --- See ChangeLog for details ---
+2000-04-26 (doc fix) updated/added documentation for many API's and
+commands (melski)
+
+2000-05-02 (feature enhancement) added support for joinable threads;
+extended API's for channels to allow channels to move between threads
+(kupries)
+
+2000-05-02 (feature enhancement) changed error return for procedures
+with incorrect args to be like the Tcl_WrongNumArgs API, with a "wrong
+# args: ..." message printed, with an args list (hobbs)
+
+2000-05-08 (feature enhancement) added [array statistics] command
+
+2000-05-08 (performance enhancement) rewrote Tcl_StringCaseMatch
+algorithm for better performance; this affects the [string match]
+command; added "eq" and "ne" operands to expr, for testing
+string equality and inequality (hobbs)
+
+2000-05-09 (feature enhancement) extended [lsearch] to support sorted
+list searches and typed list searches (melski)
+
+2000-05-10 (feature enhancement) added [namespace exists] command
+(darley)
+
+2000-05-18 (build enhancement) added support for mingw compile env and
+cross-compiling (dejong)
+
+2000-05-18 (bug fix) corrected clock grammar to properly handle the
+"ago" keyword when it follows multiple relative unit specifiers
+(melski)
+
+2000-05-22 (compile fix) type cast cleanups (dejong)
+
+2000-05-23 (performance enhancement) added byte-compiled
+implementation of [return] command and [string] command (melski)
+
+2000-05-26 (performance enhancement) extended byte-compiled [string]
+command with support for [string compare/index/match] (hobbs)
+
+2000-05-27 (feature enhancement) added ability to set [info script]
+return value ([info script ?newFileName?]) (welch)
+
+2000-05-31 (feature enhancement) added support for regexp and exact
+pattern matching for [array names] (gazetta)
+
+2000-05-31 (feature enhancement) added -nocomplain and -- flags to
+[unset] to allow for silent unset operation (hobbs)
+
+--- Released 8.4a1, June 6, 2000 --- See ChangeLog for details ---
+
2000-05-29 (bug fix) corrected resource cleanup in http error cases.
Improved handling of error cases in http. (tamhankar)
DumpActiveMemory.3. (melski)
--- Released 8.3.2, August 9, 2000 --- See ChangeLog for details ---
+
+2000-06 thru 2000-11 (build improvements) Added support for mingw (gcc on
+Windows), AIX-5 and Win64 builds (dejong, hobbs)
+
+2000-06-23 (feature enhancement) ability to use Tcl_Obj *s as hash keys (duffin)
+
+2000-06-29 (new features) added [mcmax] and [mcmset] and extended [unknown] in
+msgcat package (duperval, krone, nelson)
+=> msgcat 1.1
+
+2000-08 thru 2000-09 added tclPlatDecls.h to default install (melski, hobbs)
+
+2000-08-24 (new feature) Enhanced trace syntax to add:
+ trace {add|remove|list} {variable|command} name ops command
+(darley, melski)
+
+2000-09-06 (cross-platform feature) Set ^Z (\32) as default EOF char. (hobbs)
+
+2000-09-07 partial fix for bug 2460 to prevent exec mem leak on Windows for the
+common case (gravereaux)
+
+2000-09-14 Improved string allocation growth for large strings (hintermayer,
+melski)
+
+2000-09-14 New non-panic'ing mem allocation functions Tcl_AttemptAlloc,
+Tcl_AttemptRealloc, Tcl_AttemptSetObjLength (melski)
+
+2000-09-20 (new features) completely new, enhanced syntax in tcltest package.
+Backwards compatable with tcltest v1. (hom)
+=> tcltest 2.0
+
+2000-09-27 (bug fix) fixed a bug introduced by a partial fix in 8.3.2 that
+didn't set nonBlocking correctly when resetting the flags for the write
+side (mem leak) Correct mem leak in channels when statePtr was released
+(hobbs)
+
+2000-09-29 (bug fix) corrected reporting of space parity on Windows (Eason)
+
+2000-10-06 (bug fix) corrected [file channels] to only return channels in
+the current interpreter (hobbs)
+
+2000-10-20 (performance enhancement) call stat only when necessary in 'glob' to
+speed up command significantly in base cases (hobbs)
+
+2000-10-27 Fixed mem leak in Tcl_CreateChannel. Re-purified core via test
+suites. (hobbs)
+
+2000-10-30 (new feature) add "ja_JP.eucJP" map to "euc-jp" encoding (takahashi)
+
+2000-11-01 (mem leak) Corrected excessive mem use of info exists on a
+non-existent array element (hobbs)
+
+2000-11-02 (bug fix) Corrected sharing of tclLibraryPath in threaded
+environment (gravereaux)
+
+2000-11-03 (new feature) Tcl_SetMainLoop enables defining an event loop for
+tclsh. This enables Tk as a truly loadable package. (hobbs)
+
+--- Released 8.4a2, November 3, 2000 --- See ChangeLog for details ---
+
+2000-09-27 (bug fix) fixed a bug introduced by a partial fix in 8.3.2 that
+didn't set nonBlocking correctly when resetting the flags for the write
+side (mem leak) Correct mem leak in channels when statePtr was released
+(hobbs)
+
+2000-09-29 (bug fix) corrected reporting of space parity on Windows (Eason)
+
+2000-10-06 (bug fix) corrected [file channels] to only return channels in
+the current interpreter (hobbs)
+
+2000-10-20 (performance enhancement) call stat only when necessary in 'glob' to
+speed up command significantly in base cases (hobbs)
+
+2000-11-01 (mem leak) Corrected excessive mem use of info exists on a
+non-existent array element (hobbs)
+
+2000-11-02 (bug fix) Corrected sharing of tclLibraryPath in threaded
+environment (gravereaux)
+
+2000-11-23 (mem leak) fixed potential memory leak in error case of lsort
+(fellows)
+
+2000-12-09 (feature enhancement) changed %o and %x to use strtoul instead
+of strtol to correctly preserve scan<>format conversion of large integers
+(hobbs)
+Fixed handling of {!<boolean>} in expressions (hobbs, fellows)
+
+2000-12-14 (feature enhancement) improved (s)rand for 64-bit platforms
+(porter)
+
+2001-01-04 (bug fix) corrected parsing of $tcl_libPath at startup on
+Windows (porter)
+
+2001-01-30 (bug fix) Fixed possible hangs in fcopy. (porter)
+
+2001-02-15 (performance enhancement) improved efficiency of [string split]
+(fellows)
+
+2001-03-13 (bug fix) Correctly possible memory corruption in string map {}
+$str (fellows)
+
+2001-03-29 (bug fix) prevent potential race condition and security leak in
+tmp filename creation on Unix. (max)
+Fixed handling of timeout for threads (corrects excessive CPU usage issue
+for Tk on Unix in threaded Tcl environment). (ruppert)
+
+2001-03-30 (bug fix) corrected Windows memory error on exit (wu)
+Fixed race condition in readability of socket on Windows.
+
+2001-04-03 (doc fixes) numerous doc corrections and clarifications.
+Update of READMEs.
+
+2001-04-04 (build improvements) redid Mac build structure (steffen)
+Corrected IRIX-5* configure (english). Added support for AIX-5 (hobbs).
+Added support for Win64 (hobbs).
+
+--- Released 8.3.3, April 6, 2001 --- See ChangeLog for details ---
+
+2000-11-23 (new feature)[TIP 7] higher resolution timer on Windows (kenny)
+
+2001-01-18 (new feature) Tcl_InitHashTableEx renamed to Tcl_InitCustomHashTable
+(kupries)
+
+2001-03-30 (new feature)[TIP 10] support for thread-aware/hot channels (kupries)
+
+2001-04-06 (new feature)[219280] auto-loading hidden in ::errorInfo (porter)
+
+2001-04-07 (bug fix)[406709] corrected panic when extra items left on the
+byte compiler execution stack (sofer)
+
+2001-04-09 (bug fix)[219136,232558] improved use of thread-safe functions in
+unix time commands (kenny)
+
+2001-04-24 (new feature)[TIP 27] started CONST-ification of the Tcl APIs (kenny)
+
+2001-05-03 (new feature) [auto_import] now matches patterns like
+[namespace import], not like [string match] (porter)
+ **** POTENTIAL INCOMPATABILITY ****
+
+2001-05-07 (new feature)[416643] distinct srand() seed per interp (sofer)
+
+2001-05-15 (new feature) new Tcl_GetUnicodeFromObj API (hobbs)
+
+2001-05-16 (performance enhancement) byte-compiled versions of [lappend],
+[append] simple cases (hobbs)
+
+2001-05-23 (new feature) added ISO-8859-15 and koi8-u encodings, updated other
+encoding tables based on http://www.unicode.org/Public/MAPPINGS/ (kuhn)
+
+2001-05-27 (new feature) updated to Unicode 3.1.0 data set (still using 16
+bits for Tcl_UniChar though) (hobbs)
+
+2001-05-30 (new feature)[TIP 15] Tcl_GetMathFuncInfo, Tcl_ListMathFuncs,
+Tcl_InfoObjCmd, InfoFunctionsCmd APIs (fellows)
+
+2001-06-08 (bug fix,feature enhancement)[219170,414936] all Tcl_Panic
+definitions brought into agreement (porter)
+
+2001-06-12 (bug fix)[219232] regexp returned non-matching sub-pairs to have
+index pair {-1 -1} (fellows)
+
+2001-06-27 (bug fix)[217987] corrected backslash substitution of non-ASCII
+characters. (hobbs, riefenstahl)
+
+2001-06-28 (bug fix)[231259] failure to re-compile after cmd shadowing (sofer)
+
+2001-07-02 (bug fix)[227512] corrected [concat] treatment of UTF-8 strings
+(hobbs, barras)
+
+2001-07-12 (new feature)[TIP 36] Tcl_SubstObj API (fellows)
+
+2001-07-16 (bug fix) corrected thread-enabled pipe closing on Windows
+(hobbs, jsmith)
+
+2001-07-18 (bug fix)[427196] corrected memory overwrite error when buffer size
+of a channel is changed after channel use has already begun (kupries, porter)
+
+2001-07-31 (new feature)[TIP 17] TclFS* APIs provide new virtual file
+system. This includes the addition of 'file normalize', 'file system',
+'file separator' and 'glob -tails' (darley)
+
+2001-08-06 (bug fix) removed use of tmpnam in TclpCreateTempFile on Unix (lim)
+
+ * improved build support for IRIX, GNU HURD, Mac OS 9 and OS X
+
+ * configure scripts revamped for better support of cygwin and gcc on
+ Windows (mdejong)
+
+ * corrected several minor errors noted by Purify (hobbs)
+
+--- Released 8.4a3, August 6, 2001 --- See ChangeLog for details ---
+
+2001-06-27 (bug fix)[217987] corrected backslash substitution of non-ASCII
+characters. (hobbs, riefenstahl)
+
+2001-06-28 (bug fix)[231259] failure to re-compile after cmd shadowing (sofer)
+
+2001-07-02 (bug fix)[227512] corrected [concat] treatment of UTF-8 strings
+(hobbs, barras)
+
+2001-07-16 (bug fix) corrected thread-enabled pipe closing on Windows
+(hobbs, jsmith)
+
+2001-07-18 (bug fix)[427196] corrected memory overwrite error when buffer size
+of a channel is changed after channel use has already begun (kupries, porter)
+
+2001-08-06 (bug fix)[442665] corrected object reference counting in [gets]
+(jikamens)
+
+2001-08-06 (new feature) added GNU (HURD) configuration target. (brinkmann)
+
+2001-08-07 (bug fix)[406709] corrected panic when extra items left on the
+byte compiler execution stack (see test foreach-5.5) (sofer, tallneil, jstrot)
+
+2001-08-08 (new features) updated packages msgcat 1.1.1, opt 0.4.3,
+tcltest 1.0.1, dependencies checked (porter)
+
+2001-08-20 (new feature)[452217] http 2.3.2: include port number in Host: header
+to comply with HTTP/1.1 spec (RFC 2068) (hobbs, tils)
+
+2001-08-23 (new feature) added QNX-6 build support (loverso)
+
+2001-08-23 (bug fix) corrected handling of spaces in path name passed to
+[exec] on Windows (kenpoole)
+
+2001-08-24 (bug fix) corrected [package forget] stopping on non-existent
+package (porter)
+
+2001-08-24 (bug fix) corrected construction of script library search path
+relative to executable (porter)
+
+2001-08-24 (bug fix) [auto_import] now matches patterns like
+[namespace import], not like [string match] (porter)
+ **** POTENTIAL INCOMPATABILITY ****
+
+2001-08-27 (new feature) added Tcl_SetMainLoop() to enable loading Tk as a
+true package (hobbs)
+
+2001-08-30 (bug fix) build support for Crays (andreasen)
+
+2001-09-01 (bug fix) rewrite of Tcl_Async* APIs to better manage thread
+cleanup (gravereaux)
+
+2001-09-06 (new feature) http 2.4: honor the Content-encoding and charset
+parameters; add -binary switch for forcing the issue (hobbs, saoukhi, orwell)
+=> http 2.4
+
+2001-09-06 (performance enhancement) rewrite of file I/O flush management on
+Windows. Approximately 100x speedup for some operations. (kupries, traum)
+
+2001-09-10 (bug fix) corrected finalization error in TclInExit (darley)
+
+2001-09-10 (bug fix) protect against alias loops (hobbs)
+
+2001-09-12 (bug fix) added missing #include in tclLoadShl.c (techentin)
+
+2001-09-12 (bug fix) script library path construction on Windows no longer
+uses registry, nor adds the current working directory to the path (porter)
+
+2001-09-12 (bug fix) correct bugs in compatibility strtod() (porter)
+
+2001-09-13 (bug fix) Tcl_UtfPrev now returns the proper location when the
+middle of a UTF-8 byte is passed in (hobbs)
+
+2001-09-19 (bug fix) [format] and [scan] corrected for 64-bit machines (rmax)
+
+2001-09-19 (new feature) --enable-64-bit support for HP-11. (hobbs)
+
+2001-09-19 (new feature) native memory allocator now default on Windows
+(hobbs)
+
+2001-09-20 (new feature) WIN64 support and extra processor definitions
+(hobbs, mstacy)
+
+2001-09-26 (bug fix) corrected potential deadlock in channels that do not
+provide a BlockModeProc (kupries, kogorman)
+
+2001-10-03 (new feature) WIN64 build support (hobbs)
+
+2001-10-03 (bug fix) correction in thread finalization (rbrunner)
+
+2001-10-04 (new feature) updated encodings with latest mappings from
+www.unicode.org (hobbs)
+
+2001-10-11 (bug fix) corrected cleanup of self-referential bytecodes at
+interpreter deletion (sofer, rbrunner)
+
+2001-10-16 (new feature) config support for MacOSX / Darwin (steffen)
+
+2001-10-16 (new feature, Mac) change in binary extension format from MachO
+bundles to standard .dylib dynamic libraries like on other unices.
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2001-10-18 (bug fix) corrected off-by-one-day error in clock scan with
+relative months and years during swing hours. (lavana)
+
+--- Released 8.3.4, October 19, 2001 --- See ChangeLog for details ---
+
+2001-08-21 (bug fix)[219184] overagressive compilation of [catch] (sofer)
+
+2001-08-22 (new feature)[227482] [dde request -binary] (hobbs)
+=> dde 1.2
+
+2001-08-30 (performance enhancement)[456668] fully qualified command names use
+cached Command for all namespaces, avoiding repeated lookups (sofer)
+
+2001-08-31 (performance enhancement) bytecompiled [list] (hobbs)
+
+2001-09-02 (bug fix)[403553] Add -Zl to VC++ compile line for tclStubLib to
+avoid any specific C-runtime library dependence. (gravereaux)
+
+2001-09-05 (new feature) restored support for Borland compiler (gravereaux)
+
+2001-09-05 (new feature)[TIP 49] Tcl_OutputBuffered API (schroedter, fellows)
+
+2001-09-07 (new feature) restored VC++ 5.0 compatibility (gravereaux)
+
+2001-09-10 (performance enhancement)[TIP 53,451441] [proc foo args {}] now
+compiles to 0 bytecodes (sofer)
+
+2001-09-13 (new feature)[TIP 56] Tcl_EvalTokensStandard API (sofer)
+
+2001-09-13 (new feature) Old ChangeLog entries => ChangeLog.1999 (hobbs)
+
+2001-09-17 (new feature) compiling with TCL_COMPILE_DEBUG now required to
+enable all compile and execution tracing (sofer)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2001-09-19 (bug fix)[411825] made TclNeedSpace UTF-8 aware (fellows)
+
+2001-09-19 (bug fix)[219166] overagressive compilation of "quoted" bodies of
+[for], [foreach], [if], and [while] (sofer)
+
+2001-09-19 (performance enhancement) bytecompiled [string match] (hobbs)
+
+2001-10-15 (new feature)[TIP 35] serial channel configuration: Win (schroedter)
+
+2001-11-06 (bug fix)[478856] loss of fileevents due to short reads (kupries)
+
+2001-11-06 (new feature) revitalized makefile.vc (gravereaux)
+
+2001-11-07 (new feature) Cygwin gcc support dropped. Use mingw (dejong)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2001-11-07 (new feature) Support --include-dir= and --libdir= options to
+configure. Store in tclConfig.sh as TCL_INCLUDE_SPEC and TCL_LIB_SPEC.
+(dejong)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2001-11-08 (new feature) Enable --enable-threads on FreeBSD (dejong)
+
+2001-11-08 (new feature) New make target 'make gdb' (dejong)
+
+2001-11-09 (bug fix)[480176] [global] mishandled varnames matching :* (porter)
+
+2001-11-12 (new feature)[TIP 22,33,45] new command [lset],
+[lindex] extended to accept multiple indices. (kenny, hobbs)
+
+2001-11-16 (new feature) new configure option --enable-langinfo=no.
+By default, nl_langinfo() is used on Unix to determine system encoding.
+Tcl's built-in system is used only if that fails, or configured with
+--enable-langinfo=no. (hobbs, wagner)
+
+2001-11-19 (new feature)[TIP 62] A Tcl_VarTraceProc can now return Tcl_Obj *
+or a dynamic string as well as a static string to indicate an error (fellows)
+
+2001-11-19 (new feature)[TIP 73] Tcl_GetTime API (kenny)
+
+2001-11-19 (bug fix)[478847] overflows in [time] of >2**31 microseconds (kenny)
+
+2001-11-29 (performance enhancement) caching scheme added to [binary scan]
+(fellows)
+
+2001-12-05 (new feature) new algorithm for [array get] adds safety when read
+traces modify the array. (sofer)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2001-12-10 (bug fix)[490514] doc fixes (porter,english)
+
+2001-12-18 (new feature) removed unix/dltest/configure; unix/configure does
+all (dejong)
+
+2001-12-19 (new feature) New make target 'make shell' (dejong)
+
+2001-12-21 (new feature) MaxOSX / Darwin support (steffen)
+
+2001-12-28 (new feature) new command [memory onexit] replaces [checkmem] when
+compiled with TCL_MEM_DEBUG. Added documentation. (porter)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2001-12-28 (bug fix) proper case in [auto_execok] use of $env(COMPSPEC) (hobbs)
+
+2002-01-05 (feature rewrite) Tcl_Main() rewritten and documentation improved.
+Interactive operation and event loop operation (via Tcl_SetMainLoop) now
+interleave cleanly. Also more robust against strange happenings. (porter)
+
+2002-01-17 (bug fix)[504642] Tcl_Obj refCounts in [gets] (griffen,kupries)
+
+2002-01-21 (bug fix)[506297] infinite loop writing in iso2022-jap encoding
+(forssen,kupries)
+
+2002-01-24 (HTTP server bug workaround)[504508] leave the default port out
+of the Host: header value
+=> http 2.4.1 (hobbs)
+
+2002-01-25 (new feature)[496733] socket options -eofchar and -translation
+return read-only values (dejong)
+
+2002-01-28 (new feature) Old ChangeLog entries => ChangeLog.20900 (hobbs)
+
+2002-01-28 (performance enhancement) bytecompiled [regexp] for trivial cases
+that amount to string matching. Also -nocase and --. (hobbs)
+
+2002-02-05 (bug fix) [http::error] called when [::error] intended
+=> http 2.4.2 (porter)
+
+2002-02-05 (bug fix)[465765] avoid zero-byte writes to STREAMs
+(talcott,kupries)
+
+2002-02-06 (performance enhancement) [regsub] special cases that map to
+[string map] detected. (hobbs)
+
+2002-02-06 (bug fix)[495213] [scan] accept 0x as prefix of base 16 value
+(hobbs)
+
+2002-02-10 (new feature)[TIP 32,79] Tcl_CreateObjTrace API (kenny)
+
+2002-02-12 (new feature) partial support for DJGPP Tcl on DOS (gravereaux)
+
+2002-02-14 (mem leak) Fixed leaking an empty Tcl_Obj when [gets $chan]
+errored out. (kupries, sofer)
+
+2002-02-15 (new feature)[TIP 72] support for 64-bit integer values on
+32-bit platforms and ability to work with >2GiB files. Extends many
+commands. See ChangeLog and TIP for details.
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2002-02-22 (bug fix)[476537] Fix panic when loading shared library without
+proper use of stubs on platform without backlinking (porter)
+
+2002-02-22 (new feature) 64-bit support for xlc compiler on AIX-4 (hobbs)
+
+2002-02-22 (new feature)[521560] Removed limits on filename length and
+format [source]able through the Safe Base (hobbs)
+
+2002-02-22 (performance enhancement) optimized bytecodes for [if], [for],
+[while] and constant conditions (sofer)
+
+2002-02-22 (new feature)[TIP 76] [regsub] can now return result (fellows)
+
+2002-02-25 (bug fix)[495207] buffer overrun when closing ] left out of
+argument to [subst] (sofer, english)
+
+2002-02-25 (bug fix)[514392] [load] updated for Mac OS X 10.1 (steffen)
+
+2002-02-26 (bug fix) [info hostname] choked on names >31 characters (hobbs)
+
+2002-02-26 (new feature)[TIP 35] serial channel configuration: Unix
+(schroedter, hobbs)
+
+2002-02-25 (bug fix)[483575] [fconfigure ... -error] now no-op on Mac (kupries)
+
+2002-02-28 (performance enhancement)[458872] fully qualified command names use
+cached Command for all namespaces, avoiding repeated lookups (sofer)
+
+ * (new feature)[TIP 27] completed CONST-ification of TCL APIs.
+Added compiler macro USE_NON_CONST to keep using those old API prototypes
+that present irreconcilable source incompatibilities with header files
+of prior Tcl releases. Others will need to be reconciled.
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2002-03-04 (bug fix)[474358, 218099, 219314, 524674] fixed several problems
+related to the handling of iso2022 text and finalization of escape-based
+encodings. (taguchi, takahashi, hobbs)
+
+--- Released 8.4a4, March 5, 2002 --- See ChangeLog for details ---
+
+2002-03-06 (new feature)[TIP 80] expanded [lsearch] options (wilkason, fellows)
+
+2002-03-07 (new feature)[TIP 87] [interp recursionlimit] (trier)
+
+2002-03-08 (platform feature) mingw 1.1 build favored (dejong)
+
+2002-03-20 (new feature)[TIP 27] CONST-ified variable access functions (porter)
+
+2002-03-24 (bug fix)[511666,511658,523217,530960] expanded
+Tcl_FSMatchInDirectory to handle assorted [glob] bugs in VFS. (darley)
+ *** POTENTIAL INCOMPATIBILITY with prior 8.4a releases ***
+
+2002-03-25 (bug fix)[495726] stopped tcltest disabling of auto-loading (porter)
+
+2002-03-25 (bug fix)[495977] allow \n in test constraints (porter)
+
+2002-03-27 (platform support)[527941,533862] VC/winhelp/W9X (spjuth,
+gravereaux)
+
+2002-03-28 (bug fix)[219181] exception at level 0 issues (sofer)
+
+2002-03-28 (bug fix)[219362] command termination; Tcl_CreateTrace (knoll,sofer)
+
+2002-04-05 (bug fix)[536879] exceptions during variable subst (porter)
+
+2002-04-15 (bug fix)[497446,513983] tcltest syntax errors now raised (porter)
+ ***POTENTIAL INCOMPATIBILITY with prior tcltest 2.0.* (8.4aX)***
+
+2002-04-17 (bug fix)[495660] [(save|restore)state] deprecated (porter)
+
+2002-04-17 (bug fix)[526524] escape-based encodings corrected (yamamoto, hobbs)
+
+2002-04-18 (bug fix)[542588] [expr] error msgs improved (ehrens, sofer)
+
+2002-04-18 (bug fix)[545325] [info level $level] now returns [namespace eval]
+as documented (suchenwirth,sofer)
+
+2002-04-19 (bug fix)[544727] export [mcload]; ns context of [mcmax] (porter)
+=> msgcat 1.2.3
+
+2002-04-22 (performance enhancement) threaded memory allocator (AOL, hobbs)
+
+2002-04-24 (new feature) TCLTK_NO_LIBRARY_TEXT_RESOURCES #define disables
+inclusion of tcl library code in resource fork on Mac. (steffen)
+
+2002-05-21 (platform support) static libs on OSF (dejong)
+
+2002-05-24 (bug fix)[557878] set encoding on listening socket (staplin,
+kupries)
+
+2002-05-24 (new feature)[TIP 91] Tcl_Seek compatibility (fellows)
+
+2002-05-28 (bug fix)[545579] VFS [load] left temp file (darley)
+
+2002-05-28 (bug fix)[559376] plug timezone env leak on Windows (hobbs)
+
+2002-05-29 (performance enhancement) [string compare] optimized (hobbs,fellows)
+
+2002-05-31 (bug fix)[550534] plug interp leak in [pkg_mkIndex] (helmut)
+
+2002-05-31 (dead code)[474335,555635] removed all use of matherr() (english)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2002-06-04 (new feature)[TIP 85,521362] custom result match in tcltest
+(markus, porter)
+=> tcltest 2.1
+
+2002-06-06 (bug fix)[524352] encoding, threading, and environment issues on
+MacOSX (steffen)
+
+2002-06-06 (bug fix)[512214,558742,512214,461000] lazy initialization of
+tcltest constraints (porter)
+
+2002-06-07 (bug fix)[563122,564595] EOVERFLOW definitions (fellows)
+
+2002-06-11 (bug fix)[567386] [info locals] corrections (sofer)
+
+2002-06-14 (new feature)[TIP 102] [trace list] renamed [trace info] (fellows)
+
+2002-06-17 (new feature)[525522,525525] msgcat support for XPG4 locales;
+examination of LC_ALL, LC_MESSAGES environment variables (haible, porter)
+=> msgcat 1.3
+
+2002-06-17 (new feature)[565088] header files assume modern C compiler by
+default; older compilers may need configuration (english)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2002-06-17 (bug fix)[554068] [exec] argument quoting on Windows (darley)
+
+2002-06-17 (new feature)[TIP 62,462580] command execution traces (lavana)
+
+2002-06-19 (bug fix)[558324] regexp sets a linked variable (watson)
+
+ * (performance enhancment) optimizations of bytecode execution (sofer)
+
+2002-06-21 (new feature)[TIP 99,562970] new [file link] command (darley)
+
+2002-06-24 (new feature)[TIP 101] new [tcltest::configure] command (porter)
+=> tcltest 2.2
+
+2002-06-25 (new feature) --enable-man-symlinks and --enable-man-compression
+options to configure (max)
+
+2002-06-26 (bug fix)[565880] [clock format] now respects locale (max)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2002-07-03 (bug fix)[577015] [catch] catches even compile errors (sofer)
+
+--- Released 8.4b1, July 5, 2002 --- See ChangeLog for details ---
+
+2002-07-08 (bug fix) restored compatibility of [viewFile] in tcltest (porter)
+
+2002-07-11 (bug fix) [file normalize] returns long form on Win 95/98/ME (darley)
+
+2002-07-15 (performance enhancment) variable operations rewritten to store
+ and use cached Var pointers (sofer)
+
+2002-07-22 (bug fix)[218000] Inf and Nan are floating-point values (fellows)
+
+2002-07-23 (platform support)[219220] 64-bit compile on IRIX (dejong)
+
+2002-07-25 (bug fix)[219218] return codes in background errors (english)
+
+2002-07-28 (bug fix)[582522] alias fires exec traces (sofer)
+
+2002-07-29 (bug fix)[578363] regexp (fellows,pvgoran)
+
+2002-07-30 (bug fix)[584603] WriteChars infinite loop non-UTF-8 string (kupries)
+
+2002-08-04 (new feature)[584051,580433,585105,582429][TIP 27] Tcl interfaces
+ are now fully CONST-ified. Use the symbols USE_NON_CONST or
+ USE_COMPAT_CONST to select interfaces with fewer changes.
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2002-08-05 (bug fix)[589859] tcltest setup and cleanup scripts skipped when
+ test body is skipped (porter)
+ => tcltest 2.2
+
+2002-08-07 (bug fix)[587488] mem leak with USE_THREAD_ALLOC (sofer,sass)
+
+2002-08-07 (feature enhancement)[584794,584650,472576] boolean values
+ are no longer always re-parsed from string. (sofer)
+
+Many internal bugs fixed.
+Considerable cleanup of the test suite.
+
+--- Released 8.4b2, August 9, 2002 --- See ChangeLog for details ---
+
+2002-08-20 (new feature) --enable-memdebug configure option (kupries)
+
+2002-08-23 (bug fix)[597936] mem leak with USE_THREAD_ALLOC (sofer,zoran)
+
+2002-08-26 (bug fix)[599788] segfault in compiler (sofer,wilkason)
+
+2002-08-28 (bug fix)[414910] avoid mem leaks accessing environment variables
+ on Windows (welton,gravereaux)
+
+2002-08-31 (platform support)[TIP 108] Mac OS X port (steffen,ingham)
+
+2002-09-02 (platfrom support) 64-bit compile on HP-11 (martin)
+
+--- Released 8.4.0, September 10, 2002 --- See ChangeLog for details ---
+
+2002-09-18 (platform support) Updated support for compiling with Cygwin and
+either mingw or gcc. (khan, howell, dejong)
+
+2002-09-22 (bug fix)[612786, 611922] Corrected [puts -nonewline] within
+test bodies. Also corrected reporting of body return code. Updated tcltest
+to v2.2.1.
+
+2002-09-24 (bug fix)[613117] More robust 64-bit wide integer value
+detection (fellows)
+
+2002-09-26 (bug fix) correct overeager optimization of noop proc to handle
+the precompiled case. (sofer, hobbs)
+
+2002-09-26 (bug fix)[615115] removed extraneous spaces in koi8-u.enc that
+confused encoding reader.
+
+2002-09-29 (bug fix)[219355] Added proper exiting conditions using Win32
+console signals. This handles the existing lack of a Ctrl+C exit to call
+exit handlers when built for thread support. Also, properly handles exits
+from other conditions such as CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT, and
+CTRL_SHUTDOWN_EVENT signals. In all cases, exit handlers will be called.
+(gravereaux)
+
+2002-09-30 (bug fix) improve the checking for bad regular expressions
+during regexp compilation. Resultant compiles were correct, but much
+slower than necessary. (hobbs)
+
+2002-10-01 (bug fix) fix precompiled locals to support 8.3 precompiled
+code. (hobbs)
+
+2002-10-09 (bug fix)[620735] Added code to set an exit handler on Windows
+that terminates the thread that calibrates the performance counter, so that
+the thread won't outlive unloading the Tcl DLL. (kenny)
+
+2002-10-09 (build support) all --enable-symbols to take the enhanced
+options yes|no|mem|compile|all. (hobbs)
+
+2002-10-10 (build support) enable USE_THREAD_ALLOC (new threaded allocator)
+by default on Windows. (hobbs, gravereaux)
+
+2002-10-14 (bug fix)[623269] correct possible mem leak in
+Tcl_PutEnv. (brouwers)
+
+2002-10-15 (bug fix)[615043] fix in execution traces with idle tasks
+firing. (lavana)
+
+2002-10-15 (platform support) Correct AIX-5 ppc and 4/5 64-bit build flags.
+Correct HP 11 64-bit gcc building. (martin, hobbs)
+
+2002-10-17 (bug fix)[624755] Fixed code that check for proper # of args to
+[array names] (porter)
+
+2002-10-18 (feature enhancement)[625453] Added support for broadcasting
+changes to the registry Environment on Windows. Updated registry package
+to v1.1. (hobbs)
+
+2002-10-22 (platform support)[624509] On macosx, add embedded framework
+dirs to tcl_pkgPath: @executable_path/../Frameworks and
+@executable_path/../PrivateFrameworks (if they exist), as well as the dirs
+in DYLD_FRAMEWORK_PATH (if set). (steffen)
+
+--- Released 8.4.1, October 22, 2002 --- See ChangeLog for details ---
compliant this directory should be unnecessary.
RCS: @(#) $Id$
-
+++ /dev/null
-/*
- * getcwd.c --
- *
- * This file provides an implementation of the getcwd procedure
- * that uses getwd, for systems with getwd but without getcwd.
- *
- * Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) getcwd.c 1.5 96/02/15 12:08:20
- */
-
-#include "tclInt.h"
-#include "tclPort.h"
-
-extern char *getwd _ANSI_ARGS_((char *pathname));
-
-char *
-getcwd(buf, size)
- char *buf; /* Where to put path for current directory. */
- size_t size; /* Number of bytes at buf. */
-{
- char realBuffer[MAXPATHLEN+1];
- int length;
-
- if (getwd(realBuffer) == NULL) {
- /*
- * There's not much we can do besides guess at an errno to
- * use for the result (the error message in realBuffer isn't
- * much use...).
- */
-
- errno = EACCES;
- return NULL;
- }
- length = strlen(realBuffer);
- if (length >= size) {
- errno = ERANGE;
- return NULL;
- }
- strcpy(buf, realBuffer);
- return buf;
-}
-
This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation and other parties. The following terms apply to all files
+associated with the software unless explicitly disclaimed in
+individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
* source. See the copyright notice below for details on redistribution
* restrictions. The "license.terms" file does not apply to this file.
*
+ * Changes 2002 Copyright (c) 2002 ActiveState Corporation.
+ *
* RCS: @(#) $Id$
*/
const char *t_fmt;
const char *t_fmt_ampm;
} _TimeLocale;
-
+
+/*
+ * This is the C locale default. On Windows, if we wanted to make this
+ * localized, we would use GetLocaleInfo to get the correct values.
+ * It may be acceptable to do localization of month/day names, as the
+ * numerical values would be considered the locale-independent versions.
+ */
static const _TimeLocale _DefaultTimeLocale =
{
{
static const _TimeLocale *_CurrentTimeLocale = &_DefaultTimeLocale;
+static int isGMT;
static size_t gsize;
static char *pt;
static int _add _ANSI_ARGS_((const char* str));
const struct tm *t));
size_t
-TclpStrftime(s, maxsize, format, t)
+TclpStrftime(s, maxsize, format, t, useGMT)
char *s;
size_t maxsize;
const char *format;
const struct tm *t;
+ int useGMT;
{
if (format[0] == '%' && format[1] == 'Q') {
/* Format as a stardate */
return(strlen(s));
}
+ isGMT = useGMT;
+ /*
+ * We may be able to skip this for useGMT, but it should be harmless.
+ * -- hobbs
+ */
tzset();
pt = s;
const char *format;
const struct tm *t;
{
+#ifdef WIN32
+#define BUF_SIZ 256
+ TCHAR buf[BUF_SIZ];
+ SYSTEMTIME syst = {
+ t->tm_year + 1900,
+ t->tm_mon + 1,
+ t->tm_wday,
+ t->tm_mday,
+ t->tm_hour,
+ t->tm_min,
+ t->tm_sec,
+ 0,
+ };
+#endif
for (; *format; ++format) {
if (*format == '%') {
++format;
2, '0'))
return(0);
continue;
- case 'c':
- if (!_fmt(_CurrentTimeLocale->d_t_fmt, t))
- return(0);
- continue;
case 'D':
if (!_fmt("%m/%d/%y", t))
return(0);
if (!_conv(t->tm_wday, 1, '0'))
return(0);
continue;
+#ifdef WIN32
+ /*
+ * To properly handle the localized time routines on Windows,
+ * we must make use of the special localized calls.
+ */
+ case 'c':
+ if (!GetDateFormat(LOCALE_USER_DEFAULT, DATE_LONGDATE,
+ &syst, NULL, buf, BUF_SIZ) || !_add(buf)
+ || !_add(" ")) {
+ return(0);
+ }
+ /*
+ * %c is created with LONGDATE + " " + TIME on Windows,
+ * so continue to %X case here.
+ */
+ case 'X':
+ if (!GetTimeFormat(LOCALE_USER_DEFAULT, 0,
+ &syst, NULL, buf, BUF_SIZ) || !_add(buf)) {
+ return(0);
+ }
+ continue;
+ case 'x':
+ if (!GetDateFormat(LOCALE_USER_DEFAULT, DATE_SHORTDATE,
+ &syst, NULL, buf, BUF_SIZ) || !_add(buf)) {
+ return(0);
+ }
+ continue;
+#else
+ case 'c':
+ if (!_fmt(_CurrentTimeLocale->d_t_fmt, t))
+ return(0);
+ continue;
case 'x':
if (!_fmt(_CurrentTimeLocale->d_fmt, t))
return(0);
if (!_fmt(_CurrentTimeLocale->t_fmt, t))
return(0);
continue;
+#endif
case 'y':
if (!_conv((t->tm_year + TM_YEAR_BASE) % 100,
2, '0'))
if (!_conv((t->tm_year + TM_YEAR_BASE), 4, '0'))
return(0);
continue;
-#ifndef MAC_TCL
case 'Z': {
- char *name = TclpGetTZName(t->tm_isdst);
+ char *name = (isGMT ? "GMT" : TclpGetTZName(t->tm_isdst));
if (name && !_add(name)) {
return 0;
}
continue;
}
-#endif
case '%':
/*
* X311J/88-090 (4.12.3.5): if conversion char is
size_t nChars));
extern char * strncpy _ANSI_ARGS_((char *dst, CONST char *src,
size_t numChars));
-extern char * strpbrk _ANSI_ARGS_((CONST char *string, char *chars));
+extern char * strpbrk _ANSI_ARGS_((CONST char *string,
+ CONST char *chars));
extern char * strrchr _ANSI_ARGS_((CONST char *string, int c));
extern size_t strspn _ANSI_ARGS_((CONST char *string,
CONST char *chars));
extern char * strstr _ANSI_ARGS_((CONST char *string,
CONST char *substring));
-extern char * strtok _ANSI_ARGS_((CONST char *s, CONST char *delim));
+extern char * strtok _ANSI_ARGS_((char *s, CONST char *delim));
#endif /* _STRING */
}
b = substring;
}
- return (char *) 0;
+ return NULL;
}
* RCS: @(#) $Id$
*/
-#include "tcl.h"
-#ifdef NO_STDLIB_H
-# include "../compat/stdlib.h"
-#else
-# include <stdlib.h>
-#endif
+#include "tclInt.h"
+#include "tclPort.h"
#include <ctype.h>
#ifndef TRUE
*/
p = string;
- while (isspace(*p)) {
+ while (isspace(UCHAR(*p))) {
p += 1;
}
if (*p == '-') {
}
expSign = FALSE;
}
- while (isdigit(*p)) {
+ if (!isdigit(UCHAR(*p))) {
+ p = pExp;
+ goto done;
+ }
+ while (isdigit(UCHAR(*p))) {
exp = exp * 10 + (*p - '0');
p += 1;
}
}
if (exp > maxExponent) {
exp = maxExponent;
+ errno = ERANGE;
}
dblExp = 1.0;
for (d = powersOf10; exp != 0; exp >>= 1, d += 1) {
*/
#include <ctype.h>
+#include "tclInt.h"
+#include "tclPort.h"
\f
/*
long int
strtol(string, endPtr, base)
- char *string; /* String of ASCII digits, possibly
+ CONST char *string; /* String of ASCII digits, possibly
* preceded by white space. For bases
* greater than 10, either lower- or
* upper-case digits may be used.
* else means decimal.
*/
{
- register char *p;
- int result;
+ register CONST char *p;
+ long result;
/*
* Skip any leading blanks.
*/
p = string;
- while (isspace(*p)) {
+ while (isspace(UCHAR(*p))) {
p += 1;
}
result = strtoul(p, endPtr, base);
}
if ((result == 0) && (endPtr != 0) && (*endPtr == p)) {
- *endPtr = string;
+ *endPtr = (char *) string;
}
return result;
}
* RCS: @(#) $Id$
*/
-#include <ctype.h>
+#include "tclInt.h"
+#include "tclPort.h"
/*
* The table below is used to convert from ASCII digits to a
unsigned long int
strtoul(string, endPtr, base)
- char *string; /* String of ASCII digits, possibly
+ CONST char *string; /* String of ASCII digits, possibly
* preceded by white space. For bases
* greater than 10, either lower- or
* upper-case digits may be used.
* else means decimal.
*/
{
- register char *p;
+ register CONST char *p;
register unsigned long int result = 0;
register unsigned digit;
int anyDigits = 0;
+ int negative=0;
+ int overflow=0;
/*
* Skip any leading blanks.
*/
p = string;
- while (isspace(*p)) {
+ while (isspace(UCHAR(*p))) {
p += 1;
}
+ if (*p == '-') {
+ negative = 1;
+ p += 1;
+ } else {
+ if (*p == '+') {
+ p += 1;
+ }
+ }
/*
* If no base was provided, pick one from the leading characters
{
if (*p == '0') {
p += 1;
- if (*p == 'x') {
+ if ((*p == 'x') || (*p == 'X')) {
p += 1;
base = 16;
} else {
* Skip a leading "0x" from hex numbers.
*/
- if ((p[0] == '0') && (p[1] == 'x')) {
+ if ((p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
p += 2;
}
}
*/
if (base == 8) {
+ unsigned long maxres = ULONG_MAX >> 3;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > 7) {
break;
}
- result = (result << 3) + digit;
+ if (result > maxres) { overflow = 1; }
+ result = (result << 3);
+ if (digit > (ULONG_MAX - result)) { overflow = 1; }
+ result += digit;
anyDigits = 1;
}
} else if (base == 10) {
+ unsigned long maxres = ULONG_MAX / 10;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > 9) {
break;
}
- result = (10*result) + digit;
+ if (result > maxres) { overflow = 1; }
+ result *= 10;
+ if (digit > (ULONG_MAX - result)) { overflow = 1; }
+ result += digit;
anyDigits = 1;
}
} else if (base == 16) {
+ unsigned long maxres = ULONG_MAX >> 4;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > ('z' - '0')) {
if (digit > 15) {
break;
}
- result = (result << 4) + digit;
+ if (result > maxres) { overflow = 1; }
+ result = (result << 4);
+ if (digit > (ULONG_MAX - result)) { overflow = 1; }
+ result += digit;
anyDigits = 1;
}
- } else {
+ } else if ( base >= 2 && base <= 36 ) {
+ unsigned long maxres = ULONG_MAX / base;
for ( ; ; p += 1) {
digit = *p - '0';
if (digit > ('z' - '0')) {
break;
}
digit = cvtIn[digit];
- if (digit >= base) {
+ if (digit >= ( (unsigned) base )) {
break;
}
- result = result*base + digit;
+ if (result > maxres) { overflow = 1; }
+ result *= base;
+ if (digit > (ULONG_MAX - result)) { overflow = 1; }
+ result += digit;
anyDigits = 1;
}
}
}
if (endPtr != 0) {
- *endPtr = p;
+ /* unsafe, but required by the strtoul prototype */
+ *endPtr = (char *) p;
}
+ if (overflow) {
+ errno = ERANGE;
+ return ULONG_MAX;
+ }
+ if (negative) {
+ return -result;
+ }
return result;
}
* RCS: @(#) $Id$
*/
-extern int errno; /* global error number */
-
-#define EPERM 1 /* Operation not permitted */
-#define ENOENT 2 /* No such file or directory */
-#define ESRCH 3 /* No such process */
-#define EINTR 4 /* Interrupted system call */
-#define EIO 5 /* Input/output error */
-#define ENXIO 6 /* Device not configured */
-#define E2BIG 7 /* Argument list too long */
-#define ENOEXEC 8 /* Exec format error */
-#define EBADF 9 /* Bad file descriptor */
-#define ECHILD 10 /* No child processes */
-#define EDEADLK 11 /* Resource deadlock avoided */
- /* 11 was EAGAIN */
-#define ENOMEM 12 /* Cannot allocate memory */
-#define EACCES 13 /* Permission denied */
-#define EFAULT 14 /* Bad address */
-#define ENOTBLK 15 /* Block device required */
-#define EBUSY 16 /* Device busy */
-#define EEXIST 17 /* File exists */
-#define EXDEV 18 /* Cross-device link */
-#define ENODEV 19 /* Operation not supported by device */
-#define ENOTDIR 20 /* Not a directory */
-#define EISDIR 21 /* Is a directory */
-#define EINVAL 22 /* Invalid argument */
-#define ENFILE 23 /* Too many open files in system */
-#define EMFILE 24 /* Too many open files */
-#define ENOTTY 25 /* Inappropriate ioctl for device */
-#define ETXTBSY 26 /* Text file busy */
-#define EFBIG 27 /* File too large */
-#define ENOSPC 28 /* No space left on device */
-#define ESPIPE 29 /* Illegal seek */
-#define EROFS 30 /* Read-only file system */
-#define EMLINK 31 /* Too many links */
-#define EPIPE 32 /* Broken pipe */
-#define EDOM 33 /* Numerical argument out of domain */
-#define ERANGE 34 /* Result too large */
-#define EAGAIN 35 /* Resource temporarily unavailable */
-#define EWOULDBLOCK EAGAIN /* Operation would block */
-#define EINPROGRESS 36 /* Operation now in progress */
-#define EALREADY 37 /* Operation already in progress */
-#define ENOTSOCK 38 /* Socket operation on non-socket */
-#define EDESTADDRREQ 39 /* Destination address required */
-#define EMSGSIZE 40 /* Message too long */
-#define EPROTOTYPE 41 /* Protocol wrong type for socket */
-#define ENOPROTOOPT 42 /* Protocol not available */
-#define EPROTONOSUPPORT 43 /* Protocol not supported */
-#define ESOCKTNOSUPPORT 44 /* Socket type not supported */
-#define EOPNOTSUPP 45 /* Operation not supported on socket */
-#define EPFNOSUPPORT 46 /* Protocol family not supported */
-#define EAFNOSUPPORT 47 /* Address family not supported by protocol family */
-#define EADDRINUSE 48 /* Address already in use */
-#define EADDRNOTAVAIL 49 /* Can't assign requested address */
-#define ENETDOWN 50 /* Network is down */
-#define ENETUNREACH 51 /* Network is unreachable */
-#define ENETRESET 52 /* Network dropped connection on reset */
-#define ECONNABORTED 53 /* Software caused connection abort */
-#define ECONNRESET 54 /* Connection reset by peer */
-#define ENOBUFS 55 /* No buffer space available */
-#define EISCONN 56 /* Socket is already connected */
-#define ENOTCONN 57 /* Socket is not connected */
-#define ESHUTDOWN 58 /* Can't send after socket shutdown */
-#define ETOOMANYREFS 59 /* Too many references: can't splice */
-#define ETIMEDOUT 60 /* Connection timed out */
-#define ECONNREFUSED 61 /* Connection refused */
-#define ELOOP 62 /* Too many levels of symbolic links */
-#define ENAMETOOLONG 63 /* File name too long */
-#define EHOSTDOWN 64 /* Host is down */
-#define EHOSTUNREACH 65 /* No route to host */
-#define ENOTEMPTY 66 /* Directory not empty */
-#define EPROCLIM 67 /* Too many processes */
-#define EUSERS 68 /* Too many users */
-#define EDQUOT 69 /* Disc quota exceeded */
-#define ESTALE 70 /* Stale NFS file handle */
-#define EREMOTE 71 /* Too many levels of remote in path */
-#define EBADRPC 72 /* RPC struct is bad */
-#define ERPCMISMATCH 73 /* RPC version wrong */
-#define EPROGUNAVAIL 74 /* RPC prog. not avail */
-#define EPROGMISMATCH 75 /* Program version wrong */
-#define EPROCUNAVAIL 76 /* Bad procedure for program */
-#define ENOLCK 77 /* No locks available */
-#define ENOSYS 78 /* Function not implemented */
-#define EFTYPE 79 /* Inappropriate file type or format */
+extern int errno; /* global error number */
+#define EPERM 1 /* Operation not permitted */
+#define ENOENT 2 /* No such file or directory */
+#define ESRCH 3 /* No such process */
+#define EINTR 4 /* Interrupted system call */
+#define EIO 5 /* Input/output error */
+#define ENXIO 6 /* Device not configured */
+#define E2BIG 7 /* Argument list too long */
+#define ENOEXEC 8 /* Exec format error */
+#define EBADF 9 /* Bad file descriptor */
+#define ECHILD 10 /* No child processes */
+#define EDEADLK 11 /* Resource deadlock avoided */
+ /* 11 was EAGAIN */
+#define ENOMEM 12 /* Cannot allocate memory */
+#define EACCES 13 /* Permission denied */
+#define EFAULT 14 /* Bad address */
+#define ENOTBLK 15 /* Block device required */
+#define EBUSY 16 /* Device busy */
+#define EEXIST 17 /* File exists */
+#define EXDEV 18 /* Cross-device link */
+#define ENODEV 19 /* Operation not supported by device */
+#define ENOTDIR 20 /* Not a directory */
+#define EISDIR 21 /* Is a directory */
+#define EINVAL 22 /* Invalid argument */
+#define ENFILE 23 /* Too many open files in system */
+#define EMFILE 24 /* Too many open files */
+#define ENOTTY 25 /* Inappropriate ioctl for device */
+#define ETXTBSY 26 /* Text file busy */
+#define EFBIG 27 /* File too large */
+#define ENOSPC 28 /* No space left on device */
+#define ESPIPE 29 /* Illegal seek */
+#define EROFS 30 /* Read-only file system */
+#define EMLINK 31 /* Too many links */
+#define EPIPE 32 /* Broken pipe */
+#define EDOM 33 /* Numerical argument out of domain */
+#define ERANGE 34 /* Result too large */
+#define EAGAIN 35 /* Resource temporarily unavailable */
+#define EWOULDBLOCK EAGAIN /* Operation would block */
+#define EINPROGRESS 36 /* Operation now in progress */
+#define EALREADY 37 /* Operation already in progress */
+#define ENOTSOCK 38 /* Socket operation on non-socket */
+#define EDESTADDRREQ 39 /* Destination address required */
+#define EMSGSIZE 40 /* Message too long */
+#define EPROTOTYPE 41 /* Protocol wrong type for socket */
+#define ENOPROTOOPT 42 /* Protocol not available */
+#define EPROTONOSUPPORT 43 /* Protocol not supported */
+#define ESOCKTNOSUPPORT 44 /* Socket type not supported */
+#define EOPNOTSUPP 45 /* Operation not supported on socket */
+#define EPFNOSUPPORT 46 /* Protocol family not supported */
+#define EAFNOSUPPORT 47 /* Address family not supported by protocol family */
+#define EADDRINUSE 48 /* Address already in use */
+#define EADDRNOTAVAIL 49 /* Can't assign requested address */
+#define ENETDOWN 50 /* Network is down */
+#define ENETUNREACH 51 /* Network is unreachable */
+#define ENETRESET 52 /* Network dropped connection on reset */
+#define ECONNABORTED 53 /* Software caused connection abort */
+#define ECONNRESET 54 /* Connection reset by peer */
+#define ENOBUFS 55 /* No buffer space available */
+#define EISCONN 56 /* Socket is already connected */
+#define ENOTCONN 57 /* Socket is not connected */
+#define ESHUTDOWN 58 /* Can't send after socket shutdown */
+#define ETOOMANYREFS 59 /* Too many references: can't splice */
+#define ETIMEDOUT 60 /* Connection timed out */
+#define ECONNREFUSED 61 /* Connection refused */
+#define ELOOP 62 /* Too many levels of symbolic links */
+#define ENAMETOOLONG 63 /* File name too long */
+#define EHOSTDOWN 64 /* Host is down */
+#define EHOSTUNREACH 65 /* No route to host */
+#define ENOTEMPTY 66 /* Directory not empty */
+#define EPROCLIM 67 /* Too many processes */
+#define EUSERS 68 /* Too many users */
+#define EDQUOT 69 /* Disc quota exceeded */
+#define ESTALE 70 /* Stale NFS file handle */
+#define EREMOTE 71 /* Too many levels of remote in path */
+#define EBADRPC 72 /* RPC struct is bad */
+#define ERPCMISMATCH 73 /* RPC version wrong */
+#define EPROGUNAVAIL 74 /* RPC prog. not avail */
+#define EPROGMISMATCH 75 /* Program version wrong */
+#define EPROCUNAVAIL 76 /* Bad procedure for program */
+#define ENOLCK 77 /* No locks available */
+#define ENOSYS 78 /* Function not implemented */
+#define EOVERFLOW 79 /* Value too large to be stored in data type */
# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
-cat > conftest.defs <<\EOF
-s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
-s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g
-s%\[%\\&%g
-s%\]%\\&%g
-s%\$%$$%g
-EOF
-DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
-rm -f conftest.defs
+#
+# If the first sed substitution is executed (which looks for macros that
+# take arguments), then we branch to the quote section. Otherwise,
+# look for a macro that doesn't take arguments.
+cat >confdef2opt.sed <<\_ACEOF
+t clear
+: clear
+s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g
+t quote
+s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g
+t quote
+d
+: quote
+s,[ `~#$^&*(){}\\|;'"<>?],\\&,g
+s,\[,\\&,g
+s,\],\\&,g
+s,\$,$$,g
+p
+_ACEOF
+# We use echo to avoid assuming a particular line-breaking character.
+# The extra dot is to prevent the shell from consuming trailing
+# line-breaks from the sub-command output. A line-break within
+# single-quotes doesn't work because, if this script is created in a
+# platform that uses two characters for line-breaks (e.g., DOS), tr
+# would break.
+ac_LF_and_DOT=`echo; echo .`
+DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'`
+rm -f confdef2opt.sed
# Without the "./", some shells look in PATH for config.status.
+++ /dev/null
-# CYGNUS LOCAL
-#
-# This entire file is Cygnus local, it contains a set of cross
-# platform autoconf macros to be used by Tcl extensions.
-
-# FIXME: There seems to be a problem with variable
-# names that still need an expansion (like $foo_FILE)
-# since another eval might be needed in these macros.
-
-#--------------------------------------------------------------------
-# TCL_TOOL_PATH
-#
-# Return a file path that the build system tool will understand.
-# This path might be different than the path used in the
-# Makefiles.
-#
-# Arguments:
-#
-# VAR
-# PATH
-#
-# Results:
-#
-#
-# Example:
-#
-# TCL_TOOL_PATH(TCL_CC_PATH, /usr/local/compiler)
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(TCL_TOOL_PATH, [
- val=$2
-
- if test "$val" = "" ; then
- AC_MSG_ERROR([Empty value for variable $1])
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- AC_MSG_ERROR([CYGPATH variable is not defined.])
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- $1=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- $1="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- $1=$val
- ;;
- esac
-])
-
-# FIXME: It would simplify things if no SUFFIX had to be passed
-# into these LONGNAME macros. Using the TCL_SHARED_LIB_SUFFIX
-# and TCL_UNSHARED_LIB_SUFFIX from tclConfig.sh might do the trick!
-
-#--------------------------------------------------------------------
-# TCL_TOOL_STATIC_LIB_LONGNAME
-#
-# Return static library name in the "long format" understood by
-# the build tools. This might involve prepending a suffix
-# and appending version information to the library name.
-#
-# Arguments:
-#
-# VAR
-# LIBNAME
-# SUFFIX
-#
-# Depends on:
-# TCL_DBGX
-# TCL_VENDOR_PREFIX
-#
-# Example:
-#
-# TCL_TOOL_STATIC_LIB_LONGNAME(TCL_LIB, tcl, $TCL_UNSHARED_LIB_SUFFIX)
-#
-# Results:
-#
-# TCL_LIB=libtcl83.a
-#
-# or
-#
-# TCL_LIB=tcl83.lib
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(TCL_TOOL_STATIC_LIB_LONGNAME, [
- libname=$2
- suffix=$3
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- else
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- fi
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- $1=$long_libname
-])
-
-#--------------------------------------------------------------------
-# TCL_TOOL_SHARED_LIB_LONGNAME
-#
-# Return the shared library name in the "long format" understood by
-# the build tools. This might involve prepending a suffix
-# and appending version information to the shared library name.
-#
-# Arguments:
-#
-# VAR
-# LIBNAME
-# SUFFIX
-#
-# Depends on:
-# TCL_DBGX
-# TCL_VENDOR_PREFIX
-#
-# Example:
-#
-# TCL_TOOL_SHARED_LIB_LONGNAME(TCL_SHLIB, tcl, $TCL_SHARED_LIB_SUFFIX)
-#
-# Results:
-# The above example could result in the following.
-#
-# TCL_SHLIB=libtcl83.so
-#
-# or
-#
-# TCL_SHLIB=tcl83.dll
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(TCL_TOOL_SHARED_LIB_LONGNAME, [
- libname=$2
- suffix=$3
-
- case "${host}" in
- *windows32* | *mingw32* | *cygwin*)
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- $1=$long_libname
-])
-
-#--------------------------------------------------------------------
-# TCL_TOOL_LIB_SHORTNAME
-#
-# Return the library name in the "short format" understood by
-# the build tools. This might involve prepending a suffix
-# and appending version information to the library name.
-# The VC++ compiler does not support short library names
-# so we just use the static import lib name in that case.
-#
-# Arguments:
-#
-# VAR
-# LIBNAME
-# VERSION
-#
-# Depends on:
-# TCL_LIB_VERSIONS_OK
-# TCL_DBGX
-# SHARED_BUILD
-#
-#
-# Example:
-#
-# TCL_TOOL_LIB_SHORTNAME(TCL_LIB, tcl, 8.3)
-#
-# Results:
-# The above example could result in the following.
-#
-# TCL_LIB=-ltcl83
-#
-# or
-#
-# TCL_LIB=tcl83.lib
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(TCL_TOOL_LIB_SHORTNAME, [
- libname=$2
- version=$3
-
- if test "$TCL_LIB_SUFFIX" = "" ; then
- AC_MSG_ERROR([The TCL_LIB_SUFFIX variable is not defined])
- fi
-
- # If the . character is not allowed in lib name, remove it from version
- if test "${TCL_LIB_VERSIONS_OK}" != "ok"; then
- version=`echo $version | tr -d .`
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "short_libname=\"${TCL_VENDOR_PREFIX}${libname}${version}${TCL_LIB_SUFFIX}\""
- else
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}${TCL_DBGX}"
- fi
- ;;
- *)
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}\${TCL_DBGX}"
- ;;
- esac
-
- $1=$short_libname
-])
-
-#--------------------------------------------------------------------
-# TCL_TOOL_LIB_SPEC
-#
-# Return the "lib spec format" understood by the build tools.
-#
-# Arguments:
-#
-# VAR
-# DIR
-# LIBARG
-#
-# Depends on:
-#
-#
-# Example:
-#
-# TCL_TOOL_LIB_SPEC(SPEC, /usr/lib, -ltcl)
-#
-# Results:
-# The above example could result in the following.
-#
-# SPEC="-L/usr/lib -ltcl83"
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(TCL_TOOL_LIB_SPEC, [
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- TCL_TOOL_PATH($1, "$2/$3")
- else
- TCL_TOOL_PATH(dirname, $2)
- $1="-L${dirname} $3"
- fi
- ;;
- *)
- $1="-L$2 $3"
- ;;
- esac
-])
-
-#--------------------------------------------------------------------
-# TCL_TOOL_LIB_PATH
-#
-# Return the "lib path format" understood by the build tools.
-# Typically, this is the fully qualified path name of the library.
-#
-# Arguments:
-#
-# VAR
-# DIR
-# LIBARG
-#
-# Depends on:
-#
-#
-# Example:
-#
-# TCL_TOOL_LIB_PATH(TMP_PATH, /usr/lib, libtcl83.a)
-#
-# Results:
-# The above example could result in the following.
-#
-# TMP_PATH="/usr/lib/libtcl83.a"
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(TCL_TOOL_LIB_PATH, [
- TCL_TOOL_PATH($1, "$2/$3")
-])
TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@
INCLUDES = -I$(updir)/generic
-AM_CFLAGS = -D__TCL_UNIX_VARIANT -DTCL_LIBRARY='"$(TCL_LIBRARY)"' -DTCL_PACKAGE_PATH='"$(TCL_PACKAGE_PATH)"'
+AM_CFLAGS = -DTCL_LIBRARY='"$(TCL_LIBRARY)"' -DTCL_PACKAGE_PATH='"$(TCL_PACKAGE_PATH)"'
# $(OBJECTS): termcap.h pathnames.h
TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@
INCLUDES = -I$(updir)/generic
-AM_CFLAGS = -D__TCL_UNIX_VARIANT -DTCL_LIBRARY='"$(TCL_LIBRARY)"' -DTCL_PACKAGE_PATH='"$(TCL_PACKAGE_PATH)"'
+AM_CFLAGS = -DTCL_LIBRARY='"$(TCL_LIBRARY)"' -DTCL_PACKAGE_PATH='"$(TCL_PACKAGE_PATH)"'
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
mkinstalldirs = $(SHELL) $(top_srcdir)/../../mkinstalldirs
CONFIG_CLEAN_FILES =
PACKAGE=libtcl_cygwin
-VERSION=8.3
+VERSION=8.4
if test "`cd $srcdir && pwd`" != "`pwd`" && test -f $srcdir/config.status; then
{ echo "configure: error: source directory already configured; run "make distclean" there first" 1>&2; exit 1; }
AC_INIT(Makefile.in)
AC_CANONICAL_SYSTEM
-AM_INIT_AUTOMAKE(libtcl_cygwin, 8.3)
+AM_INIT_AUTOMAKE(libtcl_cygwin, 8.4)
AM_MAINTAINER_MODE
AC_EXEEXT
#define RETSIGTYPE void
#define HAVE_SIGNED_CHAR 1
#define HAVE_SYS_IOCTL_H 1
+#define HAVE_TM_ZONE 1
EOF
'\"
-'\" Copyright (c) 1998-1999 Scriptics Corportation
+'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
int
\fBTcl_Stat\fR(\fIpath\fR, \fIstatPtr\fR)
.SH ARGUMENTS
-.AS stat *statPtr in
+.AS "struct stat" *statPtr in
.AP char *path in
Native name of the file to check the attributes of.
.AP int mode in
W_OK and X_OK request checking whether the file exists and has read,
write and execute permissions, respectively. F_OK just requests
checking for the existence of the file.
-.AP stat *statPtr out
+.AP "struct stat" *statPtr out
The structure that contains the result.
.BE
.SH DESCRIPTION
.PP
+As of Tcl 8.4, the object-based APIs \fBTcl_FSAccess\fR and
+\fBTcl_FSStat\fR should be used in preference to \fBTcl_Access\fR and
+\fBTcl_Stat\fR, wherever possible.
+.PP
There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR
rather than calling system level functions \fBaccess\fR and \fBstat\fR
directly. First, the Windows implementation of both functions fixes
some bugs in the system level calls. Second, both \fBTcl_Access\fR
and \fBTcl_Stat\fR (as well as \fBTcl_OpenFileChannelProc\fR) hook
-into a linked list of functions. This allows the possibity to reroute
+into a linked list of functions. This allows the possibility to reroute
file access to alternative media or access methods.
.PP
\fBTcl_Access\fR checks whether the process would be allowed to read,
file to get this information but you need search rights to all
directories named in the path leading to the file. The stat structure
includes info regarding device, inode (always 0 on Windows),
-priviledge mode, nlink (always 1 on Windows), user id (always 0 on
+privilege mode, nlink (always 1 on Windows), user id (always 0 on
Windows), group id (always 0 on Windows), rdev (same as device on
Windows), size, last access time, last modification time, and creation
time.
given.
.SH KEYWORDS
-stat access
+stat, access
+
.sp
\fBTcl_SetErrorCodeVA\fR(\fIinterp, argList\fR)
.sp
-char *
+CONST char *
\fBTcl_PosixError\fR(\fIinterp\fR)
.sp
void
String to record as one element of \fBerrorCode\fR variable.
Last \fIelement\fR argument must be NULL.
.AP va_list argList in
-An argument list which must have been initialised using
+An argument list which must have been initialized using
\fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR.
-.AP char *script in
+.AP "CONST char" *script in
Pointer to first character in script containing command (must be <= command)
-.AP char *command in
+.AP "CONST char" *command in
Pointer to first character in command that generated the error
.AP int commandLength in
Number of bytes in command; -1 means use all bytes up to first NULL byte
.PP
\fBTcl_LogCommandInfo\fR is invoked after an error occurs in an
interpreter. It adds information about the command that was being
-executed when the error occured to the \fBerrorInfo\fR variable, and
+executed when the error occurred to the \fBerrorInfo\fR variable, and
the line number stored internally in the interpreter is set. On the
first call to \fBTcl_LogCommandInfo\fR or \fBTcl_AddObjErrorInfo\fR
since an error occurred, the old information in \fBerrorInfo\fR is
.TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_Alloc, Tcl_Free, Tcl_Realloc \- allocate or free heap memory
+Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
char *
\fBTcl_Alloc\fR(\fIsize\fR)
.sp
+void
\fBTcl_Free\fR(\fIptr\fR)
.sp
char *
\fBTcl_Realloc\fR(\fIptr, size\fR)
+.sp
+char *
+\fBTcl_AttemptAlloc\fR(\fIsize\fR)
+.sp
+char *
+\fBTcl_AttemptRealloc\fR(\fIptr, size\fR)
+.sp
+char *
+\fBckalloc\fR(\fIsize\fR)
+.sp
+void
+\fBckfree\fR(\fIptr\fR)
+.sp
+char *
+\fBckrealloc\fR(\fIptr, size\fR)
+.sp
+char *
+\fBattemptckalloc\fR(\fIsize\fR)
+.sp
+char *
+\fBattemptckrealloc\fR(\fIptr, size\fR)
.SH ARGUMENTS
.AS char *size
.AP int size in
\fIptr\fR to \fIsize\fR bytes and returns a pointer to the new block.
The contents will be unchanged up to the lesser of the new and old
sizes. The returned location may be different from \fIptr\fR.
+.PP
+\fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR are identical in
+function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that
+\fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl
+interpreter to \fBpanic\fR if the memory allocation fails. If the
+allocation fails, these functions will return NULL. Note that on some
+platforms, attempting to allocate a block of memory will also cause
+these functions to return NULL.
+.PP
+The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR,
+\fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented
+as macros. Normally, they are synonyms for the corresponding
+procedures documented on this page. When Tcl and all modules
+calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however,
+these macros are redefined to be special debugging versions of
+of these procedures. To support Tcl's memory debugging within a
+module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc.
+
.SH KEYWORDS
-alloc, allocation, free, malloc, memory, realloc
+alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG
.PP
If a script is evaluated at top-level (i.e. no other scripts are
pending evaluation when the script is invoked), and if the script
-terminates with a completion code other than TCL_OK, TCL_CONTINUE
+terminates with a completion code other than TCL_OK, TCL_ERROR
or TCL_RETURN, then Tcl normally converts this into a TCL_ERROR
-return with an appropriate message.
+return with an appropriate message. The particular script
+evaluation procedures of Tcl that act in the manner are
+\fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR,
+\fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR, \fBTcl_VarEval\fR and
+\fBTcl_VarEvalVA\fR.
.PP
However, if \fBTcl_AllowExceptions\fR is invoked immediately before
-calling a procedure such as \fBTcl_Eval\fR, then arbitrary completion
+calling one of those a procedures, then arbitrary completion
codes are permitted from the script, and they are returned without
modification.
This is useful in cases where the caller can deal with exceptions
.AS Tcl_InterpDeleteProc *delProcPtr
.AP Tcl_Interp *interp in
Interpreter in which to execute the specified command.
-.AP char *key in
+.VS 8.4
+.AP "CONST char" *key in
+.VE
Key for association with which to store data or from which to delete or
retrieve data. Typically the module prefix for a package.
.AP Tcl_InterpDeleteProc *delProc in
occurred, then handle the event later when the world has returned
to a clean state, such as after the current Tcl command completes.
.PP
+\fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR
+are thread sensitive. They access and/or set a thread-specific data
+structure in the event of an --enable-thread built core. The token
+created by Tcl_AsyncCreate contains the needed thread information it
+was called from so that calling Tcl_AsyncMark(token) will only yield
+the origin thread into the AsyncProc.
+.PP
\fBTcl_AsyncCreate\fR creates an asynchronous handler and returns
a token for it.
The asynchronous handler must be created before
The use of \fBTcl_Backslash\fR is deprecated in favor of
\fBTcl_UtfBackslash\fR.
.PP
-This is a utility procedure provided for backwards compatibilty with
+This is a utility procedure provided for backwards compatibility with
non-internationalized Tcl extensions. It parses a backslash sequence and
returns the low byte of the Unicode character corresponding to the sequence.
.VE
and stores the boolean value in the address given by \fIboolPtr\fR.
If the object is not already a boolean object,
the conversion will free any old internal representation.
+Objects having a string representation equal to any of \fB0\fR,
+\fBfalse\fR, \fBno\fR, or \fBoff\fR have a boolean value 0; if the
+string representation is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or
+\fBon\fR the boolean value is 1.
+Any of these string values may be abbreviated, and upper-case spellings
+are also acceptable.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
\fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR)
.SH ARGUMENTS
.AS "unsigned char" *lengthPtr in/out
-.AP "unsigned char" *bytes in
+.AP "CONST unsigned char" *bytes in
The array of bytes used to initialize or set a byte-array object.
.AP int length in
The length of the array of bytes. It must be >= 0.
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Tcl_StackChannel, Tcl_UnstackChannel, Tcl_GetStackedChannel \- stack an I/O channel on top of another, and undo it
+Tcl_StackChannel, Tcl_UnstackChannel, Tcl_GetStackedChannel, Tcl_GetTopChannel \- stack an I/O channel on top of another, and undo it
.SH SYNOPSIS
.nf
.nf
Tcl_Channel
\fBTcl_GetStackedChannel\fR(\fIchannel\fR)
.sp
+Tcl_Channel
+\fBTcl_GetTopChannel\fR(\fIchannel\fR)
+.sp
.SH ARGUMENTS
.AS Tcl_ChannelType
.AP Tcl_Interp *interp in
\fBTcl_UnstackChannel\fP is equivalent to \fBTcl_Close\fP. If an error
occurs unstacking the channel, \fBTCL_ERROR\fR is returned, otherwise
\fBTCL_OK\fR is returned.
+.PP
+\fBTcl_GetTopChannel\fR returns the top channel in the stack of
+channels the supplied channel is part of.
+.PP
+\fBTcl_GetStackedChannel\fR returns the channel in the stack of
+channels which is just below the supplied channel.
.SH "SEE ALSO"
Notifier(3), Tcl_CreateChannel(3), Tcl_OpenFileChannel(3), vwait(n).
int
\fBTcl_CommandComplete\fR(\fIcmd\fR)
.SH ARGUMENTS
-.AS char *cmd
-.AP char *cmd in
+.AS "CONST char" *cmd
+.AP "CONST char" *cmd in
Command string to test for completeness.
.BE
.nf
\fB#include <tcl.h>\fR
.sp
-char *
+CONST char *
\fBTcl_Concat\fR(\fIargc, argv\fR)
.SH ARGUMENTS
.AP int argc in
Number of strings.
-.AP char *argv[] in
+.AP "CONST char * CONST" argv[] in
Array of strings to concatenate. Must have \fIargc\fR entries.
.BE
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, \- procedures for creating and manipulating channels
+Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
Tcl_ChannelType *
\fBTcl_GetChannelType\fR(\fIchannel\fR)
.sp
-char *
+CONST char *
\fBTcl_GetChannelName\fR(\fIchannel\fR)
.sp
int
\fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR)
.sp
+.VS 8.4
+Tcl_ThreadId
+\fBTcl_GetChannelThread\fR(\fIchannel\fR)
+.VE 8.4
+.sp
int
\fBTcl_GetChannelBufferSize\fR(\fIchannel\fR)
.sp
.sp
int
\fBTcl_BadChannelOption\fR(\fIinterp, optionName, optionList\fR)
-.VS 8.3.2
+.VS 8.4
+.sp
+int
+\fBTcl_IsChannelShared\fR(\fIchannel\fR)
+.sp
+int
+\fBTcl_IsChannelRegistered\fR(\fIinterp, channel\fR)
+.sp
+int
+\fBTcl_IsChannelExisting\fR(\fIchannelName\fR)
.sp
-char *
+void
+\fBTcl_CutChannel\fR(\fIchannel\fR)
+.sp
+void
+\fBTcl_SpliceChannel\fR(\fIchannel\fR)
+.sp
+void
+\fBTcl_ClearChannelHandlers\fR(\fIchannel\fR)
+.VE 8.4
+.sp
+int
+\fBTcl_ChannelBuffered\fR(\fIchannel\fR)
+.sp
+CONST char *
\fBTcl_ChannelName\fR(\fItypePtr\fR)
.sp
Tcl_ChannelTypeVersion
Tcl_DriverSeekProc *
\fBTcl_ChannelSeekProc\fR(\fItypePtr\fR)
.sp
+.VS 8.4
+Tcl_DriverWideSeekProc *
+\fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR)
+.VE 8.4
+.sp
Tcl_DriverSetOptionProc *
\fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR)
.sp
.sp
Tcl_DriverHandlerProc *
\fBTcl_ChannelHandlerProc\fR(\fItypePtr\fR)
-.VE
.sp
.SH ARGUMENTS
-.AS Tcl_EolTranslation *channelName in
+.AS Tcl_ChannelType *channelName in
.AP Tcl_ChannelType *typePtr in
Points to a structure containing the addresses of procedures that
can be called to perform I/O and other functions on the channel.
-.AP char *channelName in
+.AP "CONST char" *channelName in
The name of this channel, such as \fBfile3\fR; must not be in use
by any other channel. Can be NULL, in which case the channel is
created without a name.
.AP ClientData *handlePtr out
Points to the location where the desired OS-specific handle should be
stored.
-.AP Tcl_EolTranslation transMode in
-The translation mode; one of the constants \fBTCL_TRANSLATE_AUTO\fR,
-\fBTCL_TRANSLATE_CR\fR, \fBTCL_TRANSLATE_LF\fR and \fBTCL_TRANSLATE_CRLF\fR.
.AP int size in
The size, in bytes, of buffers to allocate in this channel.
.AP int mask in
this channel.
.AP Tcl_Interp *interp in
Current interpreter. (can be NULL)
-.AP char *optionName in
+.AP "CONST char" *optionName in
Name of the invalid option.
-.AP char *optionList in
+.AP "CONST char" *optionList in
Specific options list (space separated words, without "-")
to append to the standard generic options list.
Can be NULL for generic options error message only.
For a discussion of channel drivers, their operations and the
\fBTcl_ChannelType\fR structure, see the section TCL_CHANNELTYPE, below.
.PP
+\fBTcl_CreateChannel\fR interacts with the code managing the standard
+channels. Once a standard channel was initialized either through a
+call to \fBTcl_GetStdChannel\fR or a call to \fBTcl_SetStdChannel\fR
+closing this standard channel will cause the next call to
+\fBTcl_CreateChannel\fR to make the new channel the new standard
+channel too. See \fBTcl_StandardChannels\fR for a general treatise
+about standard channels and the behaviour of the Tcl library with
+regard to them.
+.PP
\fBTcl_GetChannelInstanceData\fR returns the instance data associated with
the channel in \fIchannel\fR. This is the same as the \fIinstanceData\fR
argument in the call to \fBTcl_CreateChannel\fR that created this channel.
then \fBTCL_ERROR\fR is returned instead. Different channel drivers
will return different types of handle. Refer to the manual entries
for each driver to determine what type of handle is returned.
+.VS 8.4
+.PP
+\fBTcl_GetChannelThread\fR returns the id of the thread currently managing
+the specified \fIchannel\fR. This allows channel drivers to send their file
+events to the correct event queue even for a multi-threaded core.
+.VE 8.4
.PP
\fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR
and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input
and output.
.PP
- \fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
-allocated to store input or output in \fIchan\fR. If the value was not set
+\fBTcl_GetChannelBufferSize\fR returns the size, in bytes, of buffers
+allocated to store input or output in \fIchannel\fR. If the value was not set
by a previous call to \fBTcl_SetChannelBufferSize\fR, described below, then
the default value of 4096 is returned.
.PP
.PP
\fBTcl_BadChannelOption\fR is called from driver specific set or get option
procs to generate a complete error message.
+.PP
+\fBTcl_ChannelBuffered\fR returns the number of bytes of input
+currently buffered in the internal buffer (push back area) of the
+channel itself. It does not report about the data in the overall
+buffers for the stack of channels the supplied channel is part of.
+.PP
+.VS 8.4
+\fBTcl_IsChannelShared\fR checks the refcount of the specified
+\fIchannel\fR and returns whether the \fIchannel\fR was shared among
+multiple interpreters (result == 1) or not (result == 0).
+.PP
+\fBTcl_IsChannelRegistered\fR checks whether the specified \fIchannel\fR is
+registered in the given \fIinterp\fRreter (result == 1) or not
+(result == 0).
+.PP
+\fBTcl_IsChannelExisting\fR checks whether a channel with the specified
+name is registered in the (thread)-global list of all channels (result
+== 1) or not (result == 0).
+.PP
+\fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the
+(thread)global list of all channels (of the current thread).
+Application to a channel still registered in some interpreter
+is not allowed.
+.PP
+\fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the
+(thread)global list of all channels (of the current thread).
+Application to a channel registered in some interpreter is not allowed.
+.PP
+\fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event
+scripts associated with the specified \fIchannel\fR, thus shutting
+down all event processing for this channel.
+.VE 8.4
.SH TCL_CHANNELTYPE
.PP
pointers to functions that implement the various operations on a channel;
these operations are invoked as needed by the generic layer. The structure
was versioned starting in Tcl 8.3.2/8.4 to correct a problem with stacked
-channel drivers. See the \fBOLD_CHANNEL\fR section below for details about
-the old structure.
+channel drivers. See the \fBOLD CHANNEL TYPES\fR section below for
+details about the old structure.
.PP
The \fBTcl_ChannelType\fR structure contains the following fields:
.CS
Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
Tcl_DriverFlushProc *\fIflushProc\fR;
Tcl_DriverHandlerProc *\fIhandlerProc\fR;
+ Tcl_DriverWideSeekProc *\fIwideSeekProc\fR;
} Tcl_ChannelType;
.CE
.PP
are not implemented, except in the case of \fIflushProc\fR and
\fIhandlerProc\fR, which should specified as NULL if not otherwise defined.
.PP
-.VS 8.3.2
The user should only use the above structure for \fBTcl_ChannelType\fR
instantiation. When referencing fields in a \fBTcl_ChannelType\fR
structure, the following functions should be used to obtain the values:
\fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR,
\fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR,
\fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR,
+.VS 8.4
+\fBTcl_ChannelWideSeekProc\fR,
+.VE 8.4
\fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR,
\fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR,
\fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR.
types are binary compatible. However, channel types that use stacked
channels (ie: TLS, Trf) have new versions to correspond to the above change
since the previous code for stacked channels had problems.
-.VE
.SH TYPENAME
.PP
identifies the type of the device implemented by this driver, e.g.
\fBfile\fR or \fBsocket\fR.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelName\fR, which returns
+This value can be retrieved with \fBTcl_ChannelName\fR, which returns
a pointer to the string.
-.VE
-.VS 8.3.2
.SH VERSION
.PP
The \fIversion\fR field should be set to \fBTCL_CHANNEL_VERSION_2\fR.
-If it is not set to this value \fBTCL_CHANNEL_VERSION_2\fR, then this
+If it is not set to this value \fBTCL_CHANNEL_VERSION_3\fR, then this
\fBTcl_ChannelType\fR is assumed to have the older structure. See
-\fBOLD_CHANNEL\fR for more details. While Tcl will recognize and
-function with either structure, stacked channels must be of the newer
-style to function correctly.
-.PP
-This value can be retried with \fBTcl_ChannelVersion\fR, which returns
-either \fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR.
-.VE
+\fBOLD CHANNEL TYPES\fR for more details. While Tcl will recognize
+and function with either structure, stacked channels must be of at
+least \fBTCL_CHANNEL_VERSION_2\fR to function correctly.
+.PP
+This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns
+.VS 8.4
+one of \fBTCL_CHANNEL_VERSION_3\fR,
+.VE 8.4
+\fBTCL_CHANNEL_VERSION_2\fR or \fBTCL_CHANNEL_VERSION_1\fR.
.SH BLOCKMODEPROC
.PP
implemented by the underlying operating system; for other device types, the
behavior must be emulated in the channel driver.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelBlockModeProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelBlockModeProc\fR, which returns
a pointer to the function.
-.VE
.SH "CLOSEPROC AND CLOSE2PROC"
.PP
\fIinterp\fR is not NULL, the procedure should store an error message
in the interpreter's result.
.PP
-.VS 8.3.2
-These value can be retried with \fBTcl_ChannelCloseProc\fR or
+These value can be retrieved with \fBTcl_ChannelCloseProc\fR or
\fBTcl_ChannelClose2Proc\fR, which returns a pointer to the respective
function.
-.VE
.SH INPUTPROC
.PP
from the device; then, it should return as much data as it can read without
blocking.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelInputProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelInputProc\fR, which returns
a pointer to the function.
-.VE
.SH OUTPUTPROC
.PP
.CS
typedef int Tcl_DriverOutputProc(
ClientData \fIinstanceData\fR,
- char *\fIbuf\fR,
+ CONST char *\fIbuf\fR,
int \fItoWrite\fR,
int *\fIerrorCodePtr\fR);
.CE
data whatsoever, the function should return -1 with an \fBEAGAIN\fR error
without writing any data.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelOutputProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelOutputProc\fR, which returns
a pointer to the function.
-.VE
-.SH SEEKPROC
+.SH "SEEKPROC AND WIDESEEKPROC"
.PP
The \fIseekProc\fR field contains the address of a function called by the
generic layer to move the access point at which subsequent input or output
The return value is the new access point or -1 in case of error. If an
error occurred, the function should not move the access point.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelSeekProc\fR, which returns
-a pointer to the function.
-.VE
+.VS 8.4
+If there is a non-NULL \fIseekProc\fR field, the \fIwideSeekProc\fR
+field may contain the address of an alternative function to use which
+handles wide (i.e. larger than 32-bit) offsets, so allowing seeks
+within files larger than 2GB. The \fIwideSeekProc\fR will be called
+in preference to the \fIseekProc\fR, but both must be defined if the
+\fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the
+following prototype:
+.PP
+.CS
+typedef Tcl_WideInt Tcl_DriverWideSeekProc(
+ ClientData \fIinstanceData\fR,
+ Tcl_WideInt \fIoffset\fR,
+ int \fIseekMode\fR,
+ int *\fIerrorCodePtr\fR);
+.CE
+.PP
+The arguments and return values mean the same thing as with
+\fIseekProc\fR above, except that the type of offsets and the return
+type are different.
+.PP
+The \fIseekProc\fR value can be retrieved with
+\fBTcl_ChannelSeekProc\fR, which returns a pointer to the function,
+and similarly the \fIwideSeekProc\fR can be retrieved with
+\fBTcl_ChannelWideSeekProc\fR.
+.VE 8.4
.SH SETOPTIONPROC
.PP
typedef int Tcl_DriverSetOptionProc(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
- char *\fIoptionName\fR,
- char *\fIoptionValue\fR);
+ CONST char *\fIoptionName\fR,
+ CONST char *\fInewValue\fR);
.CE
.PP
-\fIoptionName\fR is the name of an option to set, and \fIoptionValue\fR is
+\fIoptionName\fR is the name of an option to set, and \fInewValue\fR is
the new value for that option, as a string. The \fIinstanceData\fR is the
same as the value given to \fBTcl_CreateChannel\fR when this channel was
created. The function should do whatever channel type specific action is
It should call \fBTcl_BadChannelOption\fR which itself returns
\fBTCL_ERROR\fR if the \fIoptionName\fR is
unrecognized.
-If \fIoptionValue\fR specifies a value for the option that
+If \fInewValue\fR specifies a value for the option that
is not supported or if a system call error occurs,
the function should leave an error message in the
\fIresult\fR field of \fIinterp\fR if \fIinterp\fR is not NULL. The
function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelSetOptionProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelSetOptionProc\fR, which returns
a pointer to the function.
-.VE
.SH GETOPTIONPROC
.PP
typedef int Tcl_DriverGetOptionProc(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
- char *\fIoptionName\fR,
- Tcl_DString *\fIdsPtr\fR);
+ CONST char *\fIoptionName\fR,
+ Tcl_DString *\fIoptionValue\fR);
.CE
.PP
\fIOptionName\fR is the name of an option supported by this type of
channel. If the option name is not NULL, the function stores its current
-value, as a string, in the Tcl dynamic string \fIdsPtr\fR.
-If \fIoptionName\fR is NULL, the function stores in \fIdsPtr\fR an
+value, as a string, in the Tcl dynamic string \fIoptionValue\fR.
+If \fIoptionName\fR is NULL, the function stores in \fIoptionValue\fR an
alternating list of all supported options and their current values.
On success, the function returns \fBTCL_OK\fR.
It should call \fBTcl_BadChannelOption\fR which itself returns
\fBTCL_ERROR\fR if the \fIoptionName\fR is
unrecognized. If a system call error occurs,
the function should leave an error message in the
-\fIresult\fR field of \fIinterp\fR if \fIinterp\fR is not NULL. The
+result of \fIinterp\fR if \fIinterp\fR is not NULL. The
function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.PP
field can be NULL, which indicates that this channel type supports no type
specific options.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelGetOptionProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelGetOptionProc\fR, which returns
a pointer to the function.
-.VE
.SH WATCHPROC
.PP
with other events. See the description of \fBTcl_QueueEvent\fR for
details on how to queue an event.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelWatchProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelWatchProc\fR, which returns
a pointer to the function.
-.VE
.SH GETHANDLEPROC
.PP
specified direction, or if the channel implementation does not use
device handles, the function should return \fBTCL_ERROR\fR.
.PP
-.VS 8.3.2
-This value can be retried with \fBTcl_ChannelGetHandleProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelGetHandleProc\fR, which returns
a pointer to the function.
-.VE
-.VS 8.3.2
.SH FLUSHPROC
.PP
The \fIflushProc\fR field is currently reserved for future use.
ClientData \fIinstanceData\fR);
.CE
.PP
-This value can be retried with \fBTcl_ChannelFlushProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns
a pointer to the function.
.SH HANDLERPROC
.PP
The \fIhandlerProc\fR field contains the address of a function called by
-the generic layer to notify the channel that an event occured. It should
+the generic layer to notify the channel that an event occurred. It should
be defined for stacked channel drivers that wish to be notified of events
that occur on the underlying (stacked) channel.
\fIHandlerProc\fR should match the following prototype:
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created. The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
-type of event occured on this channel.
+type of event occurred on this channel.
.PP
-This value can be retried with \fBTcl_ChannelHandlerProc\fR, which returns
+This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns
a pointer to the function.
-.VE
.SH TCL_BADCHANNELOPTION
.PP
.PP
It always return \fBTCL_ERROR\fR
.PP
-An error message is generated in interp's result object to
+An error message is generated in \fIinterp\fR's result object to
indicate that a command was invoked with the a bad option
The message has the form
.CS
bad option "-blah": should be one of -blocking,
-buffering, -buffersize, -eofchar, -translation,
-peername, or -sockname
-when called with optionList="peername sockname"
+when called with \fIoptionList\fR="peername sockname"
.CE
-``blah'' is the optionName argument and ``<specific options>''
+``blah'' is the \fIoptionName\fR argument and ``<specific options>''
is a space separated list of specific option words.
The function takes good care of inserting minus signs before
each option, commas after, and an ``or'' before the last option.
-.SH OLD_CHANNEL
+.SH "OLD CHANNEL TYPES"
The original (8.3.1 and below) \fBTcl_ChannelType\fR structure contains
the following fields:
the new \fBTcl_ChannelType\fR structure if you are creating a stacked
channel driver, due to problems with the earlier stacked channel
implementation (in 8.2.0 to 8.3.1).
+.PP
+.VS 8.4
+Prior to 8.4.0 (i.e. during the later releases of 8.3 and early part
+of the 8.4 development cycle) the \fBTcl_ChannelType\fR structure
+contained the following fields:
+.PP
+.CS
+typedef struct Tcl_ChannelType {
+ char *\fItypeName\fR;
+ Tcl_ChannelTypeVersion \fIversion\fR;
+ Tcl_DriverCloseProc *\fIcloseProc\fR;
+ Tcl_DriverInputProc *\fIinputProc\fR;
+ Tcl_DriverOutputProc *\fIoutputProc\fR;
+ Tcl_DriverSeekProc *\fIseekProc\fR;
+ Tcl_DriverSetOptionProc *\fIsetOptionProc\fR;
+ Tcl_DriverGetOptionProc *\fIgetOptionProc\fR;
+ Tcl_DriverWatchProc *\fIwatchProc\fR;
+ Tcl_DriverGetHandleProc *\fIgetHandleProc\fR;
+ Tcl_DriverClose2Proc *\fIclose2Proc\fR;
+ Tcl_DriverBlockModeProc *\fIblockModeProc\fR;
+ Tcl_DriverFlushProc *\fIflushProc\fR;
+ Tcl_DriverHandlerProc *\fIhandlerProc\fR;
+} Tcl_ChannelType;
+.CE
+.PP
+When the above structure is registered as a channel type, the
+\fIversion\fR field should always be \fBTCL_CHANNEL_VERSION_2\fR.
+.VE 8.4
.SH "SEE ALSO"
-Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3)
+Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3), Tcl_QueueEvent(3), Tcl_StackChannel(3), Tcl_GetStdChannel(3)
.SH KEYWORDS
blocking, channel driver, channel registration, channel type, nonblocking
.AS Tcl_CmdDeleteProc **deleteProcPtr
.AP Tcl_Interp *interp in
Interpreter in which to create new command.
-.AP char *cmdName in
+.VS 8.4
+.AP "CONST char" *cmdName in
+.VE
Name of command.
.AP Tcl_CmdProc *proc in
Implementation of new command: \fIproc\fR will be called whenever
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIargc\fR,
- char *\fIargv\fR[]);
+ CONST char *\fIargv\fR[]);
.CE
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
parameters will be copies of the \fIclientData\fR and \fIinterp\fR
Clients are only allowed to access a few of the fields of
Tcl_Interp structures; see the \fBTcl_Interp\fR
and \fBTcl_CreateCommand\fR man pages for details.
-The new interpreter is initialized with no defined variables and only
-the built-in Tcl commands. To bind in additional commands, call
-\fBTcl_CreateCommand\fR.
+The new interpreter is initialized with the built-in Tcl commands
+and with the variables documented in tclvars(n). To bind in
+additional commands, call \fBTcl_CreateCommand\fR.
.PP
\fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter
will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have
it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other
code already called \fBTcl_DeleteInterp\fR; if not, call
\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code.
-Do not call \fBTcl_DeleteInterp\fR on an interpreter for which
-\fBTcl_InterpDeleted\fR returns nonzero.
.TP
Retrieving An Interpreter From A Data Structure
When an interpreter is retrieved from a data structure (e.g. the client
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH Tcl_CreateMathFunc 3 7.0 Tcl "Tcl Library Procedures"
+.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_CreateMathFunc \- Define a new math function for expressions
+Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
+void
\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR)
+.sp
+.VS 8.4
+int
+\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr, clientDataPtr\fR)
+.sp
+Tcl_Obj *
+\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR)
+.VE
.SH ARGUMENTS
-.AS Tcl_ValueType clientData
+.AS Tcl_ValueType *clientDataPtr
.AP Tcl_Interp *interp in
Interpreter in which new function will be defined.
-.AP char *name in
+.VS 8.4
+.AP "CONST char" *name in
+.VE
Name for new function.
.AP int numArgs in
Number of arguments to new function; also gives size of \fIargTypes\fR array.
Procedure that implements the function.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR when it is invoked.
+.AP int *numArgsPtr out
+Points to a variable that will be set to contain the number of
+arguments to the function.
+.AP Tcl_ValueType *argTypesPtr out
+Points to a variable that will be set to contain a pointer to an array
+giving the permissible types for each argument to the function which
+will need to be freed up using \fITcl_Free\fR.
+.AP Tcl_MathProc *procPtr out
+Points to a variable that will be set to contain a pointer to the
+implementation code for the function (or NULL if the function is
+implemented directly in bytecode.)
+.AP ClientData *clientDataPtr out
+Points to a variable that will be set to contain the clientData
+argument passed to \fITcl_CreateMathFunc\fR when the function was
+created if the function is not implemented directly in bytecode.
+.AP "CONST char" *pattern in
+Pattern to match against function names so as to filter them (by
+passing to \fITcl_StringMatch\fR), or NULL to not apply any filter.
.BE
.SH DESCRIPTION
Under normal circumstances \fIproc\fR should return TCL_OK.
If an error occurs while executing the function, \fIproc\fR should
return TCL_ERROR and leave an error message in the interpreter's result.
+.PP
+.VS 8.4
+\fBTcl_GetMathFuncInfo\fR retrieves the values associated with
+function \fIname\fR that were passed to a preceding
+\fBTcl_CreateMathFunc\fR call. Normally, the return code is
+\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR
+is returned and an error message is placed in the interpreter's
+result.
+.PP
+If an error did not occur, the array reference placed in the variable
+pointed to by \fIargTypesPtr\fR is newly allocated, and should be
+released by passing it to \fBTcl_Free\fR. Some functions (the
+standard set implemented in the core) are implemented directly at the
+bytecode level; attempting to retrieve values for them causes a NULL
+to be stored in the variable pointed to by \fIprocPtr\fR and the
+variable pointed to by \fIclientDataPtr\fR will not be modified.
+.PP
+\fBTcl_ListMathFuncs\fR returns a Tcl object containing a list of all
+the math functions defined in the interpreter whose name matches
+\fIpattern\fR. In the case of an error, NULL is returned and an error
+message is left in the interpreter result, and otherwise the returned
+object will have a reference count of zero.
+.VE
.SH KEYWORDS
expression, mathematical function
+
+.SH "SEE ALSO"
+expr(n), info(n), Tcl_Free(3), Tcl_NewListObj(3)
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_SetCommandInfo, Tcl_GetCommandName \- implement new commands in C
+Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
int
\fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR)
.sp
-char *
+.VS 8.4
+int
+\fBTcl_GetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
+.sp
+int
+\fBTcl_SetCommandInfoFromToken\fR(\fItoken, infoPtr\fR)
+.VE
+.sp
+.VS 8.4
+CONST char *
+.VE
\fBTcl_GetCommandName\fR(\fIinterp, token\fR)
+.sp
+void
+\fBTcl_GetCommandFullName\fR(\fIinterp, token, objPtr\fR)
+.sp
+Tcl_Command
+\fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR)
.SH ARGUMENTS
.AS Tcl_ObjCmdProc *deleteProc in/out
.AP Tcl_Interp *interp in
Interpreter in which to create a new command or that contains a command.
+.VS 8.4
.AP char *cmdName in
+.VE
Name of command.
.AP Tcl_ObjCmdProc *proc in
Implementation of the new command: \fIproc\fR will be called whenever
.AP Tcl_CmdInfo *infoPtr in/out
Pointer to structure containing various information about a
Tcl command.
+.AP Tcl_Obj *objPtr in
+Object containing the name of a Tcl command.
.BE
.SH DESCRIPTION
.PP
The field \fInamespacePtr\fR holds a pointer to the
Tcl_Namespace that contains the command.
.PP
+\fBTcl_GetCommandInfoFromToken\fR is identical to
+\fBTcl_GetCommandInfo\fR except that it uses a command token returned
+from \fBTcl_CreateObjCommand\fR in place of the command name. If the
+\fItoken\fR parameter is NULL, it returns 0; otherwise, it returns 1
+and fills in the structure designated by \fIinfoPtr\fR.
+.PP
\fBTcl_SetCommandInfo\fR is used to modify the procedures and
ClientData values associated with a command.
Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR.
If this command does not exist then \fBTcl_SetCommandInfo\fR returns 0.
Otherwise, it copies the information from \fI*infoPtr\fR to
Tcl's internal structure for the command and returns 1.
-Note that this procedure allows the ClientData for a command's
-deletion procedure to be given a different value than the ClientData
-for its command procedure.
-Note that \fBTcl_SetCmdInfo\fR will not change a command's namespace;
-you must use \fBTcl_RenameCommand\fR to do that.
+.PP
+\fBTcl_SetCommandInfoFromToken\fR is identical to
+\fBTcl_SetCommandInfo\fR except that it takes a command token as
+returned by \fBTcl_CreateObjCommand\fR instead of the command name.
+If the \fItoken\fR parameter is NULL, it returns 0. Otherwise, it
+copies the information from \fI*infoPtr\fR to Tcl's internal structure
+for the command and returns 1.
+.PP
+Note that \fBTcl_SetCommandInfo\fR and
+\fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a
+command's deletion procedure to be given a different value than the
+ClientData for its command procedure.
+.PP
+Note that neither \fBTcl_SetCommandInfo\fR nor
+\fBTcl_SetCommandInfoFromToken\fR will change a command's namespace.
+You must use \fBTcl_RenameCommand\fR to do that.
.PP
\fBTcl_GetCommandName\fR provides a mechanism for tracking commands
that have been renamed.
owned by Tcl and is only guaranteed to retain its value as long as the
command isn't deleted or renamed; callers should copy the string if
they need to keep it for a long time.
-
+.PP
+\fBTcl_GetCommandFullName\fR produces the fully-qualified name
+of a command from a command token.
+The name, including all namespace prefixes,
+is appended to the object specified by \fIobjPtr\fP.
+.PP
+\fBTcl_GetCommandFromObj\fR returns a token for the command
+specified by the name in a \fBTcl_Obj\fP.
+The command name is resolved relative to the current namespace.
+Returns NULL if the command is not found.
.SH "SEE ALSO"
Tcl_CreateCommand, Tcl_ResetResult, Tcl_SetObjResult
.sp
.VS
int
-\fBTcl_CreateAlias\fR(\fIslaveInterp, srcCmd, targetInterp, targetCmd, argc, argv\fR)
+\fBTcl_CreateAlias\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv\fR)
.sp
int
-\fBTcl_CreateAliasObj\fR(\fIslaveInterp, srcCmd, targetInterp, targetCmd, objc, objv\fR)
+\fBTcl_CreateAliasObj\fR(\fIslaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv\fR)
.VE
.sp
int
-\fBTcl_GetAlias\fR(\fIinterp, srcCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr\fR)
+\fBTcl_GetAlias\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr\fR)
.sp
.VS
int
-\fBTcl_GetAliasObj\fR(\fIinterp, srcCmd, targetInterpPtr, targetCmdPtr, objcPtr, objvPtr\fR)
+\fBTcl_GetAliasObj\fR(\fIinterp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objvPtr\fR)
.sp
int
\fBTcl_ExposeCommand\fR(\fIinterp, hiddenCmdName, cmdName\fR)
.AS Tcl_InterpDeleteProc **hiddenCmdName
.AP Tcl_Interp *interp in
Interpreter in which to execute the specified command.
-.AP char *slaveName in
+.AP "CONST char" *slaveName in
Name of slave interpreter to create or manipulate.
.AP int isSafe in
If non-zero, a ``safe'' slave that is suitable for running untrusted code
.AP Tcl_Interp *slaveInterp in
Interpreter to use for creating the source command for an alias (see
below).
-.AP char *srcCmd in
+.AP "CONST char" *slaveCmd in
Name of source command for alias.
.AP Tcl_Interp *targetInterp in
Interpreter that contains the target command for an alias.
-.AP char *targetCmd in
+.AP "CONST char" *targetCmd in
Name of target command for alias in \fItargetInterp\fR.
.AP int argc in
Count of additional arguments to pass to the alias command.
-.AP char **argv in
+.AP "CONST char * CONST" *argv in
Vector of strings, the additional arguments to pass to the alias command.
This storage is owned by the caller.
.AP int objc in
Count of additional object arguments to pass to the alias object command.
.AP Tcl_Object **objv in
-Vector of Tcl_Obj structures, the additional object argumenst to pass to
+Vector of Tcl_Obj structures, the additional object arguments to pass to
the alias object command.
This storage is owned by the caller.
.AP Tcl_Interp **targetInterpPtr in
Pointer to location to store the address of the interpreter where a target
command is defined for an alias.
-.AP char **targetCmdPtr out
+.AP "CONST char" **targetCmdPtr out
Pointer to location to store the address of the name of the target command
for an alias.
.AP int *argcPtr out
Pointer to location to store count of additional arguments to be passed to
the alias. The location is in storage owned by the caller.
-.AP char ***argvPtr out
+.AP "CONST char" ***argvPtr out
Pointer to location to store a vector of strings, the additional arguments
to pass to an alias. The location is in storage owned by the caller, the
vector of strings is owned by the called function.
owned by the caller, the vector of Tcl_Obj structures is owned by the
called function.
.VS
-.AP char *cmdName in
+.VS 8.4
+.AP "CONST char" *cmdName in
+.VE
Name of an exposed command to hide or create.
-.AP char *hiddenCmdName in
+.VS 8.4
+.AP "CONST char" *hiddenCmdName in
+.VE
Name under which a hidden command is stored and with which it can be
exposed or invoked.
.VE
\fIaskingInterp\fR contains the error message.
.PP
.VS
-\fBTcl_CreateAlias\fR creates an object command named \fIsrcCmd\fR in
+\fBTcl_CreateAlias\fR creates an object command named \fIslaveCmd\fR in
\fIslaveInterp\fR that when invoked, will cause the command \fItargetCmd\fR
to be invoked in \fItargetInterp\fR. The arguments specified by the strings
contained in \fIargv\fR are always prepended to any arguments supplied in the
-invocation of \fIsrcCmd\fR and passed to \fItargetCmd\fR.
+invocation of \fIslaveCmd\fR and passed to \fItargetCmd\fR.
This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if
it fails; in that case, an error message is left in the object result
of \fIslaveInterp\fR.
After executing this command, attempts to use \fIcmdName\fR in a call to
\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will fail.
.PP
-.SH "SEE ALSO"
For a description of the Tcl interface to multiple interpreters, see
\fIinterp(n)\fR.
+.SH "SEE ALSO"
+interp
.SH KEYWORDS
alias, command, exposed commands, hidden commands, interpreter, invoke,
-master, slave,
-
+master, slave
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_CreateTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
+Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
Tcl_Trace
\fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR)
.sp
+Tcl_Trace
+\fBTcl_CreateObjTrace\fR(\fIinterp, level, flags, objProc, clientData, deleteProc\fR)
+.sp
\fBTcl_DeleteTrace\fR(\fIinterp, trace\fR)
.SH ARGUMENTS
-.AS Tcl_CmdTraceProc (clientData)()
+.AS Tcl_CmdObjTraceDeleteProc (clientData)()
.AP Tcl_Interp *interp in
Interpreter containing command to be traced or untraced.
.AP int level in
-Only commands at or below this nesting level will be traced. 1 means
+Only commands at or below this nesting level will be traced unless
+0 is specified. 1 means
top-level commands only, 2 means top-level commands or those that are
invoked as immediate consequences of executing top-level commands
(procedure bodies, bracketed commands, etc.) and so on.
+A value of 0 means that commands at any level are traced.
+.AP int flags in
+Flags governing the trace execution. See below for details.
+.AP Tcl_CmdObjTraceProc *objProc in
+Procedure to call for each command that's executed. See below for
+details of the calling sequence.
.AP Tcl_CmdTraceProc *proc in
Procedure to call for each command that's executed. See below for
details on the calling sequence.
.AP ClientData clientData in
-Arbitrary one-word value to pass to \fIproc\fR.
+Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR.
+.AP Tcl_CmdObjTraceDeleteProc *deleteProc
+Procedure to call when the trace is deleted. See below for details of
+the calling sequence. A null pointer is permissible and results in no
+callback when the trace is deleted.
.AP Tcl_Trace trace in
Token for trace to be removed (return value from previous call
to \fBTcl_CreateTrace\fR).
.BE
-
.SH DESCRIPTION
.PP
-\fBTcl_CreateTrace\fR arranges for command tracing. From now on, \fIproc\fR
-will be invoked before Tcl calls command procedures to process
-commands in \fIinterp\fR. The return value from
-\fBTcl_CreateTrace\fR is a token for the trace,
-which may be passed to \fBTcl_DeleteTrace\fR to remove the trace. There may
-be many traces in effect simultaneously for the same command interpreter.
+\fBTcl_CreateObjTrace\fR arranges for command tracing. After it is
+called, \fIobjProc\fR will be invoked before the Tcl interpreter calls
+any command procedure when evaluating commands in \fIinterp\fR.
+The return value from \fBTcl_CreateObjTrace\fR is a token for the trace,
+which may be passed to \fBTcl_DeleteTrace\fR to remove the trace.
+There may be many traces in effect simultaneously for the same
+interpreter.
.PP
-\fIProc\fR should have arguments and result that match the
-type \fBTcl_CmdTraceProc\fR:
+\fIobjProc\fR should have arguments and result that match the type,
+\fBTcl_CmdObjTraceProc\fR:
.CS
-typedef void Tcl_CmdTraceProc(
- ClientData \fIclientData\fR,
- Tcl_Interp *\fIinterp\fR,
- int \fIlevel\fR,
- char *\fIcommand\fR,
- Tcl_CmdProc *\fIcmdProc\fR,
- ClientData \fIcmdClientData\fR,
- int \fIargc\fR,
- char *\fIargv\fR[]);
+typedef int \fBTcl_CmdObjTraceProc\fR(
+ \fBClientData\fR \fIclientData\fR,
+ \fBTcl_Interp\fR* \fIinterp\fR,
+ int \fIlevel\fR,
+ CONST char* \fIcommand\fR,
+ \fBTcl_Command\fR \fIcommandToken\fR,
+ int \fIobjc\fR,
+ \fBTcl_Obj\fR *CONST \fIobjv\fR[] );
.CE
-The \fIclientData\fR and \fIinterp\fR parameters are
-copies of the corresponding arguments given to \fBTcl_CreateTrace\fR.
-\fIClientData\fR typically points to an application-specific
-data structure that describes what to do when \fIproc\fR
-is invoked. \fILevel\fR gives the nesting level of the command
-(1 for top-level commands passed to \fBTcl_Eval\fR by the application,
-2 for the next-level commands passed to \fBTcl_Eval\fR as part of parsing
-or interpreting level-1 commands, and so on). \fICommand\fR
-points to a string containing the text of the
-command, before any argument substitution.
-\fICmdProc\fR contains the address of the command procedure that
-will be called to process the command (i.e. the \fIproc\fR argument
-of some previous call to \fBTcl_CreateCommand\fR) and \fIcmdClientData\fR
-contains the associated client data for \fIcmdProc\fR (the \fIclientData\fR
-value passed to \fBTcl_CreateCommand\fR). \fIArgc\fR and \fIargv\fR give
-the final argument information that will be passed to \fIcmdProc\fR, after
-command, variable, and backslash substitution.
-\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings.
+The \fIclientData\fR and \fIinterp\fR parameters are copies of the
+corresponding arguments given to \fBTcl_CreateTrace\fR.
+\fIClientData\fR typically points to an application-specific data
+structure that describes what to do when \fIobjProc\fR is invoked. The
+\fIlevel\fR parameter gives the nesting level of the command (1 for
+top-level commands passed to \fBTcl_Eval\fR by the application, 2 for
+the next-level commands passed to \fBTcl_Eval\fR as part of parsing or
+interpreting level-1 commands, and so on). The \fIcommand\fR parameter
+points to a string containing the text of the command, before any
+argument substitution. The \fIcommandToken\fR parameter is a Tcl
+command token that identifies the command to be invoked. The token
+may be passed to \fBTcl_GetCommandName\fR,
+\fBTcl_GetCommandTokenInfo\fR, or \fBTcl_SetCommandTokenInfo\fR to
+manipulate the definition of the command. The \fIobjc\fR and \fIobjv\fR
+parameters designate the final parameter count and parameter vector
+that will be passed to the command, and have had all substitutions
+performed.
+.PP
+The \fIobjProc\fR callback is expected to return a standard Tcl status
+return code. If this code is \fBTCL_OK\fR (the normal case), then
+the Tcl interpreter will invoke the command. Any other return code
+is treated as if the command returned that status, and the command is
+\fInot\fR invoked.
+.PP
+The \fIobjProc\fR callback must not modify \fIobjv\fR in any way. It
+is, however, permissible to change the command by calling
+\fBTcl_SetCommandTokenInfo\fR prior to returning. Any such change
+takes effect immediately, and the command is invoked with the new
+information.
.PP
Tracing will only occur for commands at nesting level less than
or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR
-parameter to \fIproc\fR will always be less than or equal to the
+parameter to \fIobjProc\fR will always be less than or equal to the
\fIlevel\fR parameter to \fBTcl_CreateTrace\fR).
.PP
-Calls to \fIproc\fR will be made by the Tcl parser immediately before
+Tracing has a significant effect on runtime performance because it
+causes the bytecode compiler to refrain from generating in-line code
+for Tcl commands such as \fBif\fR and \fBwhile\fR in order that they
+may be traced. If traces for the built-in commands are not required,
+the \fIflags\fR parameter may be set to the constant value
+\fBTCL_ALLOW_INLINE_COMPILATION\fR. In this case, traces on built-in
+commands may or may not result in trace callbacks, depending on the
+state of the interpreter, but run-time performance will be improved
+significantly. (This functionality is desirable, for example, when
+using \fBTcl_CreateObjTrace\fR to implement an execution time
+profiler.)
+.PP
+Calls to \fIobjProc\fR will be made by the Tcl parser immediately before
it calls the command procedure for the command (\fIcmdProc\fR). This
occurs after argument parsing and substitution, so tracing for
substituted commands occurs before tracing of the commands
command, or if there is no command procedure associated with a
command name, then no tracing will occur for that command. If a
string passed to Tcl_Eval contains multiple commands (bracketed, or
-on different lines) then multiple calls to \fIproc\fR will occur,
-one for each command. The \fIcommand\fR string for each of these
-trace calls will reflect only a single command, not the entire string
-passed to Tcl_Eval.
+on different lines) then multiple calls to \fIobjProc\fR will occur,
+one for each command.
.PP
\fBTcl_DeleteTrace\fR removes a trace, so that no future calls will be
made to the procedure associated with the trace. After \fBTcl_DeleteTrace\fR
returns, the caller should never again use the \fItrace\fR token.
-
+.PP
+When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the
+\fIdeleteProc\fR that was passed as a parameter to
+\fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type,
+\fBTcl_CmdObjTraceDeleteProc\fR:
+.CS
+typedef void \fBTcl_CmdObjTraceDeleteProc\fR(
+ \fBClientData\fR \fIclientData\fR
+);
+.CE
+The \fIclientData\fR parameter will be the same as the
+\fIclientData\fR parameter that was originally passed to
+\fBTcl_CreateObjTrace\fR.
+.PP
+\fBTcl_CreateTrace\fR is an alternative interface for command tracing,
+\fInot recommended for new applications\fR. It is provided for backward
+compatibility with code that was developed for older versions of the
+Tcl interpreter. It is similar to \fBTcl_CreateObjTrace\fR, except
+that its \fIproc\fR parameter should have arguments and result that
+match the type \fBTcl_CmdTraceProc\fR:
+.CS
+typedef void Tcl_CmdTraceProc(
+ ClientData \fIclientData\fR,
+ Tcl_Interp *\fIinterp\fR,
+ int \fIlevel\fR,
+ char *\fIcommand\fR,
+ Tcl_CmdProc *\fIcmdProc\fR,
+ ClientData \fIcmdClientData\fR,
+ int \fIargc\fR,
+ CONST char *\fIargv\fR[]);
+.CE
+The parameters to the \fIproc\fR callback are similar to those of the
+\fIobjProc\fR callback above. The \fIcommandToken\fR is
+replaced with \fIcmdProc\fR, a pointer to the (string-based) command
+procedure that will be invoked; and \fIcmdClientData\fR, the client
+data that will be passed to the procedure. The \fIobjc\fR parameter
+is replaced with an \fIargv\fR parameter, that gives the arguments to
+the command as character strings.
+\fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings.
+.PP
+If a trace created with \fBTcl_CreateTrace\fR is in effect, inline
+compilation of Tcl commands such as \fBif\fR and \fBwhile\fR is always
+disabled. There is no notification when a trace created with
+\fBTcl_CreateTrace\fR is deleted.
+There is no way to be notified when the trace created by
+\fBTcl_CreateTrace\fR is deleted. There is no way for the \fIproc\fR
+associated with a call to \fBTcl_CreateTrace\fR to abort execution of
+\fIcommand\fR.
.SH KEYWORDS
command, create, delete, interpreter, trace
.TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings
+Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.AS Tcl_DString newLength
.AP Tcl_DString *dsPtr in/out
Pointer to structure that is used to manage a dynamic string.
-.AP char *string in
+.AP "CONST char" *string in
Pointer to characters to add to dynamic string.
.AP int length in
Number of characters from string to add to dynamic string. If -1,
.TH Tcl_DetachPids 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_DetachPids, Tcl_ReapDetachedProcs \- manage child processes in background
+Tcl_DetachPids, Tcl_ReapDetachedProcs, Tcl_WaitPid \- manage child processes in background
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
\fBTcl_DetachPids\fR(\fInumPids, pidPtr\fR)
.sp
\fBTcl_ReapDetachedProcs\fR()
+.sp
+Tcl_Pid
+\fBTcl_WaitPid\fR(\fIpid, statPtr, options\fR)
.SH ARGUMENTS
.AS int *statusPtr
.AP int numPids in
Number of process ids contained in the array pointed to by \fIpidPtr\fR.
.AP int *pidPtr in
Address of array containing \fInumPids\fR process ids.
+.AP Tcl_Pid pid in
+The id of the process (pipe) to wait for.
+.AP int* statPtr out
+The result of waiting on a process (pipe). Either 0 or ECHILD.
+.AP int options
+The options controlling the wait. WNOHANG specifies not to wait when
+checking the process.
.BE
-
.SH DESCRIPTION
.PP
\fBTcl_DetachPids\fR and \fBTcl_ReapDetachedProcs\fR provide a
\fBexec\fR command may never get executed, you may wish to call
\fBTcl_ReapDetachedProcs\fR from time to time so that background
processes can be cleaned up.
+.PP
+\fBTcl_WaitPid\fR is a thin wrapper around the facilities provided by
+the operating system to wait on the end of a spawned process and to
+check a whether spawned process is still running. It is used by
+\fBTcl_ReapDetachedProcs\fR and the channel system to portably access
+the operating system.
.SH KEYWORDS
background, child, detach, process, wait
.SH ARGUMENTS
.AP Tcl_Interp *interp in
Tcl interpreter in which to add commands.
-.AP char *fileName in
+.AP "CONST char" *fileName in
For \fBTcl_DumpActiveMemory\fR, name of the file to which memory
information will be written. For \fBTcl_ValidateAllMemory\fR, name of
the file from which the call is being made (normally \fB__FILE__\fR).
.SH DESCRIPTION
These functions provide access to Tcl memory debugging information.
-They are only available when Tcl has been compiled with
-\fBTCL_MEM_DEBUG\fR defined at compile-time.
+They are only functional when Tcl has been compiled with
+\fBTCL_MEM_DEBUG\fR defined at compile-time. When \fBTCL_MEM_DEBUG\fR
+is not defined, these functions are all no-ops.
.PP
\fBTcl_DumpActiveMemory\fR will output a list of all currently
allocated memory to the specified file. The information output for
interpreter has been deleted.
.PP
\fBTcl_InitMemory\fR adds the Tcl \fBmemory\fR command to the
-interpreter given by \fIinterp\fR. It is called by \fBTcl_Main\fR
-when Tcl has been compiled with \fBTCL_MEM_DEBUG\fR defined.
+interpreter given by \fIinterp\fR. \fBTcl_InitMemory\fR is called
+by \fBTcl_Main\fR.
.PP
\fBTcl_ValidateAllMemory\fR forces a validation of the guard zones of
all currently allocated blocks of memory. Normally validation of a
TCHAR *
\fBTcl_WinUtfToTChar\fR(\fIsrc, srcLen, dstPtr\fR)
.sp
-char *
+CONST char *
\fBTcl_GetEncodingName\fR(\fIencoding\fR)
.sp
int
Tcl_Encoding
\fBTcl_CreateEncoding\fR(\fItypePtr\fR)
.sp
-char *
+CONST char *
\fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR)
.sp
void
stored in the output buffer. May be NULL.
.AP Tcl_EncodingType *typePtr in
Structure that defines a new type of encoding.
-.AP char *path in
+.AP "CONST char" *path in
A path to the location of the encoding file.
.BE
.SH INTRODUCTION
if you planned to use the Unicode interface when running on Windows NT
and the "char" interfaces when running on Windows 95, you would have
to perform the following type of test over and over in your program
-(as represented in psuedo-code):
+(as represented in pseudo-code):
.CS
if (running NT) {
encoding <- Tcl_GetEncoding("unicode");
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
+'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.AP int flags in
ORed combination of flag bits that specify additional options.
\fBTCL_EVAL_GLOBAL\fR and \fBTCL_EVAL_DIRECT\fR are currently supported.
-.AP char *fileName in
+.AP "CONST char" *fileName in
Name of a file containing a Tcl script.
.AP int objc in
The number of objects in the array pointed to by \fIobjPtr\fR;
The number of bytes in \fIscript\fR, not including any
null terminating character. If \-1, then all characters up to the
first null byte are used.
-.AP char *script in
-Points to first byte of script to execute. This script must be in
-writable memory: temporary modifications are made to it during
-parsing.
+.AP "CONST char" *script in
+Points to first byte of script to execute (NULL terminated and UTF-8).
.AP char *string in
String forming part of a Tcl script.
.AP va_list argList in
\fBTcl_EvalObjEx\fR.
If the file couldn't be read then a Tcl error is returned to describe
why the file couldn't be read.
+.VS 8.4
+The eofchar for files is '\\32' (^Z) for all platforms.
+If you require a ``^Z'' in code for string comparison, you can use
+``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl
+interpreter into ``^Z''.
+.VE 8.4
.PP
\fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a
script. The \fIobjc\fR and \fIobjv\fR arguments contain the values
.PP
\fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to
be executed is supplied as a string instead of an object and no compilation
-occurs. The string is parsed and executed directly (using
-\fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes.
-In situations where it is known that the script will never be executed
-again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR.
-\fBTcl_Eval\fR returns a completion code and result just like
+occurs. The string should be a proper UTF-8 string as converted by
+\fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known
+to possibly contain upper ASCII characters who's possible combinations
+might be a UTF-8 special code. The string is parsed and executed directly
+(using \fBTcl_EvalObjv\fR) instead of compiling it and executing the
+bytecodes. In situations where it is known that the script will never be
+executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR.
+ \fBTcl_Eval\fR returns a completion code and result just like
\fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before
Tcl 8.0, \fBTcl_Eval\fR copies the object result in \fIinterp\fR to
\fIinterp->result\fR (use is deprecated) where it can be accessed directly.
-This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which
+ This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which
doesn't do the copy.
.PP
\fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes
.SH KEYWORDS
execute, file, global, object, result, script
-
+++ /dev/null
-'\"
-'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
-'\"
-'\" See the file "license.terms" for information on usage and redistribution
-'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-'\"
-'\" RCS: @(#) $Id$
-'\"
-.so man.macros
-.TH Tcl_EvalObj 3 8.0 Tcl "Tcl Library Procedures"
-.BS
-.SH NAME
-Tcl_EvalObj, Tcl_GlobalEvalObj \- execute Tcl commands
-.SH SYNOPSIS
-.nf
-\fB#include <tcl.h>\fR
-.sp
-int
-\fBTcl_EvalObj\fR(\fIinterp, objPtr\fR)
-.sp
-int
-\fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR)
-.SH ARGUMENTS
-.AS Tcl_Interp **termPtr;
-.AP Tcl_Interp *interp in
-Interpreter in which to execute the command.
-The command's result will be stored in the interpreter's result object
-and can be retrieved using \fBTcl_GetObjResult\fR.
-.AP Tcl_Obj *objPtr in
-A Tcl object containing a command string
-(or sequence of commands in a string) to execute.
-.BE
-
-.SH DESCRIPTION
-.PP
-These two procedures execute Tcl commands.
-\fBTcl_EvalObj\fR is the core procedure
-and is used by \fBTcl_GlobalEvalObj\fR.
-It executes the commands in the script held by \fIobjPtr\fR
-until either an error occurs or it reaches the end of the script.
-If this is the first time \fIobjPtr\fR has been executed,
-its commands are compiled into bytecode instructions
-that are then executed if there are no compilation errors.
-.PP
-The return value from \fBTcl_EvalObj\fR is one of the Tcl return codes
-\fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or
-\fBTCL_CONTINUE\fR,
-and a result object containing additional information
-(a result value or error message)
-that can be retrieved using \fBTcl_GetObjResult\fR.
-If an error occurs during compilation, this return information
-describes the error.
-Otherwise, this return information corresponds to the last command
-executed from \fIobjPtr\fR.
-.PP
-\fBTcl_GlobalEvalObj\fR is similar to \fBTcl_EvalObj\fR except that it
-processes the command at global level.
-This means that the variable context for the command consists of
-global variables only (it ignores any Tcl procedure that is active).
-This produces an effect similar to the Tcl command ``\fBuplevel 0\fR''.
-.PP
-During the processing of a Tcl command it is legal to make nested
-calls to evaluate other commands (this is how procedures and
-some control structures are implemented).
-If a code other than \fBTCL_OK\fR is returned
-from a nested \fBTcl_EvalObj\fR invocation,
-then the caller should normally return immediately,
-passing that same return code back to its caller,
-and so on until the top-level application is reached.
-A few commands, like \fBfor\fR, will check for certain
-return codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them
-specially without returning.
-.PP
-\fBTcl_EvalObj\fR keeps track of how many nested \fBTcl_EvalObj\fR
-invocations are in progress for \fIinterp\fR.
-If a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is
-about to be returned from the topmost \fBTcl_EvalObj\fR
-invocation for \fIinterp\fR,
-it converts the return code to \fBTCL_ERROR\fR
-and sets the interpreter's result object
-to point to an error message indicating that
-the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was
-invoked in an inappropriate place.
-This means that top-level applications should never see a return code
-from \fBTcl_EvalObj\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR.
-
-.SH "SEE ALSO"
-Tcl_GetObjResult, Tcl_SetObjResult
-
-.SH KEYWORDS
-command, execute, file, global, object, object result, variable
.SH KEYWORDS
callback, cleanup, dynamic loading, end application, exit, unloading, thread
-
.AS Tcl_Interp *booleanPtr
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR.
-.AP char *string in
-Expression to be evaluated. Must be in writable memory (the expression
-parser makes temporary modifications to the string during parsing, which
-it undoes before returning).
+.VS 8.4
+.AP "CONST char" *string in
+.VE
+Expression to be evaluated.
.AP long *longPtr out
Pointer to location in which to store the integer value of the
expression.
The expression can have any of the forms accepted by the \fBexpr\fR command.
Note that these procedures have been largely replaced by the
object-based procedures \fBTcl_ExprLongObj\fR, \fBTcl_ExprDoubleObj\fR,
-\fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprStringObj\fR.
+\fBTcl_ExprBooleanObj\fR, and \fBTcl_ExprObj\fR.
Those object-based procedures evaluate an expression held in a Tcl object
instead of a string.
The object argument can retain an internal representation
.SH KEYWORDS
boolean, double, evaluate, expression, integer, object, string
-
int
\fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR)
.SH ARGUMENTS
-.AS Tcl_Interp *resultPtrPtr out
+.AS Tcl_Interp **resultPtrPtr out
.AP Tcl_Interp *interp in
Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR.
.AP Tcl_Obj *objPtr in
.AP int *booleanPtr out
Pointer to location in which to store the 0/1 boolean value of the
expression.
-.AP Tcl_Obj *resultPtrPtr out
+.AP Tcl_Obj **resultPtrPtr out
Pointer to location in which to store a pointer to the object
that is the result of the expression.
.BE
.PP
On UNIX platforms this procedure is typically invoked as the very
first thing in the application's main program; it must be passed
-\fIargv[0]\fR as its argument. \fBTcl_FindExecutable\fR uses \fIargv0\fR
+\fIargv[0]\fR as its argument. It is important not to change the
+working directory before the invocation.
+\fBTcl_FindExecutable\fR uses \fIargv0\fR
along with the \fBPATH\fR environment variable to find the
application's executable, if possible. If it fails to find
the binary, then future calls to \fBinfo nameofexecutable\fR
.SH KEYWORDS
binary, executable file
-
'\"
-'\" Copyright (c) 1998-1999 Scriptics Corportation
+'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.nf
\fB#include <tcl.h>\fR
.sp
-char *
+CONST char *
\fBTcl_GetHostName\fR()
.SH DESCRIPTION
.PP
.SH KEYWORDS
hostname
-
.VS
.sp
int
-\fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, tablePtr, offset,
+\fBTcl_GetIndexFromObjStruct\fR(\fIinterp, objPtr, structTablePtr, offset,
msg, flags, indexPtr\fR)
.VE
.SH ARGUMENTS
-.AS Tcl_Interp **tablePtr
+.AS "CONST char" **tablePtr
.AP Tcl_Interp *interp in
Interpreter to use for error reporting; if NULL, then no message is
provided on errors.
The string value of this object is used to search through \fItablePtr\fR.
The internal representation is modified to hold the index of the matching
table entry.
-.AP char **tablePtr in
-An array of null-terminated strings. The end of the array is marked
+.AP "CONST char" **tablePtr in
+An array of null-terminated ASCII strings. The end of the array is marked
by a NULL string pointer.
+.AP "CONST VOID" *structTablePtr in
+An array of arbitrary type, typically some \fBstruct\fP type.
+The first member of the structure must be a null-terminated ASCII string.
+The size of the structure is given by \fIoffset\fP.
.VS
.AP int offset in
-The offset to add to tablePtr to get to the next string in the
-list. The end of the array is marked by a NULL string pointer.
+The offset to add to structTablePtr to get to the next entry.
+The end of the array is marked by a NULL string pointer.
.VE
-.AP char *msg in
+.AP "CONST char" *msg in
Null-terminated string describing what is being looked up, such as
\fBoption\fR. This string is included in error messages.
.AP int flags in
.SH KEYWORDS
index, object, table lookup
-
.AS Tcl_Interp *doublePtr
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
-.AP char *string in
+.AP "CONST char" *string in
Textual value to be converted.
.AP int *intPtr out
Points to place to store integer value converted from \fIstring\fR.
.SH KEYWORDS
boolean, conversion, double, floating-point, integer
-
.AS Tcl_Interp checkUsage
.AP Tcl_Interp *interp in
Tcl interpreter from which file handle is to be obtained.
-.AP char *string in
+.AP "CONST char" *string in
String identifying channel, such as \fBstdin\fR or \fBfile4\fR.
.AP int write in
Non-zero means the file will be used for writing, zero means it will
.SH KEYWORDS
channel, file handle, permissions, pipeline, read, write
-
\fBTcl_GetStdChannel\fR, then the default channel will not be created.
.PP
If one of the standard channels is set to NULL, either by calling
-\fBTcl_SetStdChannel\fR with a null \fIchannel\fR argument, or by calling
+\fBTcl_SetStdChannel\fR with a NULL \fIchannel\fR argument, or by calling
\fBTcl_Close\fR on the channel, then the next call to \fBTcl_CreateChannel\fR
will automatically set the standard channel with the newly created channel. If
more than one standard channel is NULL, then the standard channels will be
assigned starting with standard input, followed by standard output, with
standard error being last.
+.PP
+See \fBTcl_StandardChannels\fR for a general treatise about standard
+channels and the behaviour of the Tcl library with regard to them.
+.PP
.SH "SEE ALSO"
-Tcl_Close(3), Tcl_CreateChannel(3)
+Tcl_Close(3), Tcl_CreateChannel(3), Tcl_Main(3), tclsh(1)
.SH KEYWORDS
standard channel, standard input, standard output, standard error
Use \fBTcl_GetVersion\fR to verify that fact, and possibly to
change the behavior of your extension.
.PP
-If may pass a NULL for any of the arguments. For instance if
+\fBTcl_GetVersion\fR accepts NULL for any of the arguments. For instance if
you do not care about the \fIpatchLevel\fR of the library, pass
a NULL for the \fIpatchLevel\fR argument.
.TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_InitHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables
+Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_InitHashTable\fR(\fItablePtr, keyType\fR)
.sp
+\fBTcl_InitCustomHashTable\fR(\fItablePtr, keyType, typePtr\fR)
+.sp
+\fBTcl_InitObjHashTable\fR(\fItablePtr\fR)
+.sp
\fBTcl_DeleteHashTable\fR(\fItablePtr\fR)
.sp
Tcl_HashEntry *
Tcl_HashEntry *
\fBTcl_NextHashEntry\fR(\fIsearchPtr\fR)
.sp
-char *
+CONST char *
\fBTcl_HashStats\fR(\fItablePtr\fR)
.SH ARGUMENTS
.AS Tcl_HashSearch *searchPtr
previous call to \fBTcl_InitHashTable\fR).
.AP int keyType in
Kind of keys to use for new hash table. Must be either
-TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an integer value
-greater than 1.
-.AP char *key in
+TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, TCL_CUSTOM_TYPE_KEYS,
+TCL_CUSTOM_PTR_KEYS, or an integer value greater than 1.
+.AP Tcl_HashKeyType *typePtr in
+Address of structure which defines the behaviour of the hash table.
+.AP "CONST char" *key in
Key to use for probe into table. Exact form depends on
\fIkeyType\fR used to create table.
.AP int *newPtr out
Pointer to record to use to keep track of progress in enumerating
all the entries in a hash table.
.BE
-
.SH DESCRIPTION
.PP
-A hash table consists of zero or more entries, each consisting of
-a key and a value.
-Given the key for an entry, the hashing routines can very quickly
-locate the entry, and hence its value.
-There may be at most one entry in a hash table with a
-particular key, but many entries may have the same value.
-Keys can take one of three forms: strings,
-one-word values, or integer arrays.
-All of the keys in a given table have the same form, which is
-specified when the table is initialized.
-.PP
-The value of a hash table entry can be anything that fits in
-the same space as a ``char *'' pointer.
-Values for hash table entries are managed entirely by clients,
-not by the hash module itself.
-Typically each entry's value is a pointer to a data structure
-managed by client code.
-.PP
-Hash tables grow gracefully as the number of entries increases,
-so that there are always less than three entries per hash bucket,
-on average.
-This allows for fast lookups regardless of the number of entries
-in a table.
-.PP
-\fBTcl_InitHashTable\fR initializes a structure that describes
-a new hash table.
-The space for the structure is provided by the caller, not by
-the hash module.
-The value of \fIkeyType\fR indicates what kinds of keys will
-be used for all entries in the table. \fIKeyType\fR must have
-one of the following values:
+A hash table consists of zero or more entries, each consisting of a
+key and a value. Given the key for an entry, the hashing routines can
+very quickly locate the entry, and hence its value. There may be at
+most one entry in a hash table with a particular key, but many entries
+may have the same value. Keys can take one of four forms: strings,
+one-word values, integer arrays, or custom keys defined by a
+Tcl_HashKeyType structure (See section \fBTHE TCL_HASHKEYTYPE
+STRUCTURE\fR below). All of the keys in a given table have the same
+form, which is specified when the table is initialized.
+.PP
+The value of a hash table entry can be anything that fits in the same
+space as a ``char *'' pointer. Values for hash table entries are
+managed entirely by clients, not by the hash module itself. Typically
+each entry's value is a pointer to a data structure managed by client
+code.
+.PP
+Hash tables grow gracefully as the number of entries increases, so
+that there are always less than three entries per hash bucket, on
+average. This allows for fast lookups regardless of the number of
+entries in a table.
+.PP
+The core provides three functions for the initialization of hash
+tables, Tcl_InitHashTable, Tcl_InitObjHashTable and
+Tcl_InitCustomHashTable.
+.PP
+\fBTcl_InitHashTable\fR initializes a structure that describes a new
+hash table. The space for the structure is provided by the caller,
+not by the hash module. The value of \fIkeyType\fR indicates what
+kinds of keys will be used for all entries in the table. All of the
+key types described later are allowed, with the exception of
+\fBTCL_CUSTOM_TYPE_KEYS\fR and \fBTCL_CUSTOM_PTR_KEYS\fR.
+.PP
+\fBTcl_InitObjHashTable\fR is a wrapper around
+\fBTcl_InitCustomHashTable\fR and initializes a hash table whose keys
+are Tcl_Obj *.
+.PP
+\fBTcl_InitCustomHashTable\fR initializes a structure that describes a
+new hash table. The space for the structure is provided by the
+caller, not by the hash module. The value of \fIkeyType\fR indicates
+what kinds of keys will be used for all entries in the table.
+\fIKeyType\fR must have one of the following values:
.IP \fBTCL_STRING_KEYS\fR 25
Keys are null-terminated ASCII strings.
They are passed to hashing routines using the address of the
and stored in hash table entries as ``char *'' values.
The pointer value is the key; it need not (and usually doesn't)
actually point to a string.
+.IP \fBTCL_CUSTOM_TYPE_KEYS\fR 25
+Keys are of arbitrary type, and are stored in the entry. Hashing
+and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType
+structure is described in the section
+\fBTHE TCL_HASHKEYTYPE STRUCTURE\fR below.
+.IP \fBTCL_CUSTOM_PTR_KEYS\fR 25
+Keys are pointers to an arbitrary type, and are stored in the entry. Hashing
+and comparison is determined by \fItypePtr\fR. The Tcl_HashKeyType
+structure is described in the section
+\fBTHE TCL_HASHKEYTYPE STRUCTURE\fR below.
.IP \fIother\fR 25
-If \fIkeyType\fR is not TCL_STRING_KEYS or TCL_ONE_WORD_KEYS,
+If \fIkeyType\fR is not one of the above,
then it must be an integer value greater than 1.
In this case the keys will be arrays of ``int'' values, where
\fIkeyType\fR gives the number of ints in each key.
However, users of the hashing routines should never refer directly
to any of the fields of any of the hash-related data structures;
use the procedures and macros defined here.
-
+.SH "THE TCL_HASHKEYTYPE STRUCTURE"
+.PP
+Extension writers can define new hash key types by defining four
+procedures, initializing a Tcl_HashKeyType structure to describe
+the type, and calling \fBTcl_InitCustomHashTable\fR.
+The \fBTcl_HashKeyType\fR structure is defined as follows:
+.CS
+typedef struct Tcl_HashKeyType {
+ int \fIversion\fR;
+ int \fIflags\fR;
+ Tcl_HashKeyProc *\fIhashKeyProc\fR;
+ Tcl_CompareHashKeysProc *\fIcompareKeysProc\fR;
+ Tcl_AllocHashEntryProc *\fIallocEntryProc\fR;
+ Tcl_FreeHashEntryProc *\fIfreeEntryProc\fR;
+} Tcl_HashKeyType;
+.CE
+.PP
+The \fIversion\fR member is the version of the table. If this
+structure is extended in future then the version can be used
+to distinguish between different structures. It should be set
+to \fBTCL_HASH_KEY_TYPE_VERSION\fR.
+.PP
+The \fIflags\fR member is one or more of the following values OR'ed together:
+.IP \fBTCL_HASH_KEY_RANDOMIZE_HASH\fR 25
+There are some things, pointers for example which don't hash well
+because they do not use the lower bits. If this flag is set then the
+hash table will attempt to rectify this by randomising the bits and
+then using the upper N bits as the index into the table.
+.PP
+The \fIhashKeyProc\fR member contains the address of a function
+called to calculate a hash value for the key.
+.CS
+typedef unsigned int (Tcl_HashKeyProc) (
+ Tcl_HashTable *\fItablePtr\fR,
+ VOID *\fIkeyPtr\fR);
+.CE
+If this is NULL then \fIkeyPtr\fR is used and
+\fBTCL_HASH_KEY_RANDOMIZE_HASH\fR is assumed.
+.PP
+The \fIcompareKeysProc\fR member contains the address of a function
+called to compare two keys.
+.CS
+typedef int (Tcl_CompareHashKeysProc) (VOID *\fIkeyPtr\fR,
+ Tcl_HashEntry *\fIhPtr\fR);
+.CE
+If this is NULL then the \fIkeyPtr\fR pointers are compared.
+If the keys don't match then the function returns 0, otherwise
+it returns 1.
+.PP
+The \fIallocEntryProc\fR member contains the address of a function
+called to allocate space for an entry and initialise the key.
+.CS
+typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) (
+ Tcl_HashTable *\fItablePtr\fR, VOID *\fIkeyPtr\fR);
+.CE
+If this is NULL then Tcl_Alloc is used to allocate enough space for a
+Tcl_HashEntry and the key pointer is assigned to key.oneWordValue.
+String keys and array keys use this function to allocate enough
+space for the entry and the key in one block, rather than doing
+it in two blocks. This saves space for a pointer to the key from
+the entry and another memory allocation. Tcl_Obj * keys use this
+function to allocate enough space for an entry and increment the
+reference count on the object.
+If
+.PP
+The \fIfreeEntryProc\fR member contains the address of a function
+called to free space for an entry.
+.CS
+typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *\fIhPtr\fR);
+.CE
+If this is NULL then Tcl_Free is used to free the space for the
+entry. Tcl_Obj * keys use this function to decrement the
+reference count on the object.
.SH KEYWORDS
hash table, key, lookup, search, value
'\"
-'\" Copyright (c) 1999 Scriptics Corportation
+'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.nf
\fB#include <tcl.h>\fR
.sp
-char *
+CONST char *
\fBTcl_InitStubs\fR(\fIinterp, version, exact\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp in
.AP Tcl_Interp *interp in
Tcl interpreter handle.
-.AP char *version in
+.AP "CONST char" *version in
A version string consisting of one or more decimal numbers
separated by dots.
.AP int exact in
of Tcl satisfying the request, or NULL if the Tcl version is not
acceptable, does not support stubs, or any other error condition occurred.
.SH "SEE ALSO"
-\fBTk_InitStubs\fR
+Tk_InitStubs
.SH KEYWORDS
stubs
.TH Tcl_IntObj 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_NewIntObj, Tcl_NewLongObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj \- manipulate Tcl objects as integers
+Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj \- manipulate Tcl objects as integers and wide integers
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
Tcl_Obj *
\fBTcl_NewLongObj\fR(\fIlongValue\fR)
.sp
+.VS 8.4
+Tcl_Obj *
+\fBTcl_NewWideIntObj\fR(\fIwideValue\fR)
+.VE 8.4
+.sp
\fBTcl_SetIntObj\fR(\fIobjPtr, intValue\fR)
.sp
\fBTcl_SetLongObj\fR(\fIobjPtr, longValue\fR)
.sp
+.VS 8.4
+\fBTcl_SetWideIntObj\fR(\fIobjPtr, wideValue\fR)
+.VE 8.4
+.sp
int
\fBTcl_GetIntFromObj\fR(\fIinterp, objPtr, intPtr\fR)
.sp
int
\fBTcl_GetLongFromObj\fR(\fIinterp, objPtr, longPtr\fR)
+.sp
+.VS 8.4
+int
+\fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR)
+.VE 8.4
.SH ARGUMENTS
-.AS Tcl_Interp *interp
+.AS Tcl_WideInt *interp
.AP int intValue in
Integer value used to initialize or set an integer object.
.AP long longValue in
Long integer value used to initialize or set an integer object.
+.AP Tcl_WideInt wideValue in
+.VS 8.4
+Wide integer value (minimum 64-bits wide where supported by the
+compiler) used to initialize or set a wide integer object.
+.VE 8.4
.AP Tcl_Obj *objPtr in/out
-For \fBTcl_SetIntObj\fR and \fBTcl_SetLongObj\fR,
-this points to the object to be converted to integer type.
-For \fBTcl_GetIntFromObj\fR and \fBTcl_GetLongFromObj\fR,
-this refers to the object
-from which to get an integer or long integer value;
-if \fIobjPtr\fR does not already point to an integer object,
-an attempt will be made to convert it to one.
+For \fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR, and
+.VS 8.4
+\fBTcl_SetWideIntObj\fR, this points to the object to be converted to
+integer type. For \fBTcl_GetIntFromObj\fR, \fBTcl_GetLongFromObj\fR,
+and \fBTcl_GetWideIntFromObj\fR, this refers to the object from which
+to get an integer or long integer value; if \fIobjPtr\fR does not
+already point to an integer object (or a wide integer object in the
+case of \fBTcl_SetWideIntObj\fR and \fBTcl_GetWideIntFromObj\fR,) an
+.VE 8.4
+attempt will be made to convert it to one.
.AP Tcl_Interp *interp in/out
If an error occurs during conversion,
an error message is left in the interpreter's result object
.AP long *longPtr out
Points to place to store the long integer value
obtained by \fBTcl_GetLongFromObj\fR from \fIobjPtr\fR.
+.AP Tcl_WideInt *widePtr out
+.VS 8.4
+Points to place to store the wide integer value
+obtained by \fBTcl_GetWideIntFromObj\fR from \fIobjPtr\fR.
+.VE 8.4
.BE
.SH DESCRIPTION
.PP
These procedures are used to create, modify, and read
-integer Tcl objects from C code.
+integer and wide integer Tcl objects from C code.
\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR,
\fBTcl_SetIntObj\fR, and \fBTcl_SetLongObj\fR
create a new object of integer type
-or modify an existing object to have integer type.
+or modify an existing object to have integer type,
+.VS 8.4
+and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR create a new
+object of wide integer type or modify an existing object to have wide
+integer type.
+.VE 8.4
\fBTcl_NewIntObj\fR and \fBTcl_SetIntObj\fR set the object to have the
integer value given by \fIintValue\fR,
-while \fBTcl_NewLongObj\fR and \fBTcl_SetLongObj\fR
+\fBTcl_NewLongObj\fR and \fBTcl_SetLongObj\fR
set the object to have the
-long integer value given by \fIlongValue\fR.
-\fBTcl_NewIntObj\fR and \fBTcl_NewLongObj\fR
+long integer value given by \fIlongValue\fR,
+.VS 8.4
+and \fBTcl_NewWideIntObj\fR and \fBTcl_SetWideIntObj\fR set the object
+to have the wide integer value given by \fIwideValue\fR.
+\fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR and \fBTcl_NewWideIntObj\fR
return a pointer to a newly created object with reference count zero.
These procedures set the object's type to be integer
and assign the integer value to the object's internal representation
-\fIlongValue\fR member.
-\fBTcl_SetIntObj\fR and \fBTcl_SetLongObj\fR
+\fIlongValue\fR or \fIwideValue\fR member (as appropriate).
+\fBTcl_SetIntObj\fR, \fBTcl_SetLongObj\fR
+and \fBTcl_SetWideIntObj\fR
+.VE 8.4
invalidate any old string representation and,
if the object is not already an integer object,
free any old internal representation.
.PP
\fBTcl_GetIntFromObj\fR and \fBTcl_GetLongFromObj\fR
-attempt to return an integer value from the Tcl object \fIobjPtr\fR.
+attempt to return an integer value from the Tcl object \fIobjPtr\fR,
+.VS 8.4
+and \fBTcl_GetWideIntFromObj\fR attempts to return a wide integer
+value from the Tcl object \fIobjPtr\fR.
If the object is not already an integer object,
+or a wide integer object in the case of \fBTcl_GetWideIntFromObj\fR
+.VE 8.4
they will attempt to convert it to one.
If an error occurs during conversion, they return \fBTCL_ERROR\fR
and leave an error message in the interpreter's result object
\fBTcl_GetIntFromObj\fR returns \fBTCL_ERROR\fR
and leaves an error message in the interpreter's result object
unless \fIinterp\fR is NULL.
-Otherwise, both procedures return \fBTCL_OK\fR and
-store the integer or the long integer value
-in the address given by \fIintPtr\fR and \fIlongPtr\fR respectively.
-If the object is not already an integer object,
-the conversion will free any old internal representation.
+Otherwise, all three procedures return \fBTCL_OK\fR and
+store the integer, long integer value
+.VS 8.4
+or wide integer in the address given by \fIintPtr\fR, \fIlongPtr\fR
+and \fIwidePtr\fR
+.VE 8.4
+respectively. If the object is not already an integer or wide integer
+object, the conversion will free any old internal representation.
.SH "SEE ALSO"
Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult
.SH KEYWORDS
free, initialized, interpreter, malloc, result
-
.AP Tcl_Interp *interp in
Interpreter that contains \fIvarName\fR.
Also used by \fBTcl_LinkVar\fR to return error messages.
-.AP char *varName in
-Name of global variable. Must be in writable memory: Tcl may make
-temporary modifications to it while parsing the variable name.
+.AP "CONST char" *varName in
+Name of global variable.
.AP char *addr in
Address of C variable that is to be linked to \fIvarName\fR.
.AP int type in
Type of C variable. Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE,
+.VS 8.4
+TCL_LINK_WIDE_INT,
+.VE 8.4
TCL_LINK_BOOLEAN, or TCL_LINK_STRING, optionally OR'ed with
TCL_LINK_READ_ONLY to make Tcl variable read-only.
.BE
\fBTCL_LINK_INT\fR
The C variable is of type \fBint\fR.
Any value written into the Tcl variable must have a proper integer
-form acceptable to \fBTcl_GetInt\fR; attempts to write
+form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write
non-integer values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
\fBTCL_LINK_DOUBLE\fR
The C variable is of type \fBdouble\fR.
Any value written into the Tcl variable must have a proper real
-form acceptable to \fBTcl_GetDouble\fR; attempts to write
+form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write
non-real values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
+\fBTCL_LINK_WIDE_INT\fR
+.VS 8.4
+The C variable is of type \fBTcl_WideInt\fR (which is an integer type
+at least 64-bits wide on all platforms that can support it.)
+Any value written into the Tcl variable must have a proper integer
+form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write
+non-integer values into \fIvarName\fR will be rejected with
+Tcl errors.
+.VE 8.4
+.TP
\fBTCL_LINK_BOOLEAN\fR
The C variable is of type \fBint\fR.
If its value is zero then it will read from Tcl as ``0'';
Whenever \fIvarName\fR is
modified, the C variable will be set to a 0 or 1 value.
Any value written into the Tcl variable must have a proper boolean
-form acceptable to \fBTcl_GetBoolean\fR; attempts to write
+form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write
non-boolean values into \fIvarName\fR will be rejected with
Tcl errors.
.TP
The C variable is of type \fBchar *\fR.
.VS
If its value is not null then it must be a pointer to a string
-allocated with \fBTcl_Alloc\fR.
+allocated with \fBTcl_Alloc\fR or \fBckalloc\fR.
.VE
Whenever the Tcl variable is modified the current C string will be
freed and new memory will be allocated to hold a copy of the variable's
.SH KEYWORDS
boolean, integer, link, read-only, real, string, traces, variable
-
passed to \fBTcl_DoOneEvent\fR.
.VS 8.1
.AP int mode in
-Inidicates whether events should be serviced by \fBTcl_ServiceAll\fR.
+Indicates whether events should be serviced by \fBTcl_ServiceAll\fR.
Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR.
.VE
.BE
.PP
\fBTcl_InitNotifier\fR initializes the notifier state and returns
a handle to the notifier state. Tcl calls this
-procedure when intializing a Tcl interpreter. Similarly,
+procedure when initializing a Tcl interpreter. Similarly,
\fBTcl_FinalizeNotifier\fR shuts down the notifier, and is
called by \fBTcl_Finalize\fR when shutting down a Tcl interpreter.
.PP
\fBTcl_DoOneEvent\fR, \fBThread(3)\fR
.SH KEYWORDS
event, notifier, event queue, event sources, file events, timer, idle, service mode, threads
-
+++ /dev/null
-'\"
-'\" Copyright (c) 1996-1997 Sun Microsystems, Inc.
-'\"
-'\" See the file "license.terms" for information on usage and redistribution
-'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-'\"
-'\" RCS: @(#) $Id$
-'\"
-.so man.macros
-.TH Tcl_ObjSetVar2 3 8.0 Tcl "Tcl Library Procedures"
-.BS
-.SH NAME
-Tcl_ObjSetVar2, Tcl_ObjGetVar2 \- manipulate Tcl variables
-.SH SYNOPSIS
-.nf
-\fB#include <tcl.h>\fR
-.sp
-Tcl_Obj *
-\fBTcl_ObjSetVar2\fR(\fIinterp, part1Ptr, part2Ptr, newValuePtr, flags\fR)
-.sp
-Tcl_Obj *
-\fBTcl_ObjGetVar2\fR(\fIinterp, part1Ptr, part2Ptr, flags\fR)
-.SH ARGUMENTS
-.AS Tcl_Interp *newValuePtr
-.AP Tcl_Interp *interp in
-Interpreter containing variable.
-.AP Tcl_Obj *part1Ptr in
-Points to a Tcl object containing the variable's name.
-The name may include a series of \fB::\fR namespace qualifiers
-to specify a variable in a particular namespace.
-May refer to a scalar variable or an element of an array variable.
-.AP Tcl_Obj *part2Ptr in
-If non-NULL, points to an object containing the name of an element
-within an array and \fIpart1Ptr\fR must refer to an array variable.
-.AP Tcl_Obj *newValuePtr in
-Points to a Tcl object containing the new value for the variable.
-.AP int flags in
-OR-ed combination of bits providing additional information for
-operation. See below for valid values.
-.BE
-
-.SH DESCRIPTION
-.PP
-These two procedures may be used to read and modify
-Tcl variables from C code.
-\fBTcl_ObjSetVar2\fR will create a new variable or modify an existing one.
-It sets the specified variable to
-the object referenced by \fInewValuePtr\fR
-and returns a pointer to the object which is the variable's new value.
-The returned object may not be the same one
-referenced by \fInewValuePtr\fR;
-this might happen because variable traces may modify the variable's value.
-The reference count for the variable's old value is decremented
-and the reference count for its new value is incremented.
-If the new value for the variable
-is not the same one referenced by \fInewValuePtr\fR
-(perhaps as a result of a variable trace),
-then \fInewValuePtr\fR's reference count is left unchanged.
-The reference count for the returned object is not incremented
-to reflect the returned reference.
-If the caller needs to keep a reference to the object,
-say in a data structure,
-it must increment its reference count using \fBTcl_IncrRefCount\fR.
-If an error occurs in setting the variable
-(e.g. an array variable is referenced
-without giving an index into the array),
-then NULL is returned.
-.PP
-The variable name specified to \fBTcl_ObjSetVar2\fR consists of two parts.
-\fIpart1Ptr\fR contains the name of a scalar or array variable.
-If \fIpart2Ptr\fR is NULL, the variable must be a scalar.
-If \fIpart2Ptr\fR is not NULL,
-it contains the name of an element in the array named by \fIpart2Ptr\fR.
-As a special case, if the flag TCL_PARSE_PART1 is specified,
-\fIpart1Ptr\fR may contain both an array and an element name:
-if the name contains an open parenthesis and ends with a
-close parenthesis, then the value between the parentheses is
-treated as an element name (which can have any string value) and
-the characters before the first open
-parenthesis are treated as the name of an array variable.
-If the flag TCL_PARSE_PART1 is given,
-\fIpart2Ptr\fR should be NULL since the array and element names
-are taken from \fIpart2Ptr\fR.
-.PP
-The \fIflags\fR argument may be used to specify any of several
-options to the procedures.
-It consists of an OR-ed combination of any of the following
-bits:
-.TP
-\fBTCL_GLOBAL_ONLY\fR
-Under normal circumstances the procedures look up variables as follows:
-If a procedure call is active in \fIinterp\fR,
-a variable is looked up at the current level of procedure call.
-Otherwise, a variable is looked up first in the current namespace,
-then in the global namespace.
-However, if this bit is set in \fIflags\fR then the variable
-is looked up only in the global namespace
-even if there is a procedure call active.
-If both \fBTCL_GLOBAL_ONLY\fR and \fBTCL_NAMESPACE_ONLY\fR are given,
-\fBTCL_GLOBAL_ONLY\fR is ignored.
-.TP
-\fBTCL_NAMESPACE_ONLY\fR
-Under normal circumstances the procedures look up variables as follows:
-If a procedure call is active in \fIinterp\fR,
-a variable is looked up at the current level of procedure call.
-Otherwise, a variable is looked up first in the current namespace,
-then in the global namespace.
-However, if this bit is set in \fIflags\fR then the variable
-is looked up only in the current namespace
-even if there is a procedure call active.
-.TP
-\fBTCL_LEAVE_ERR_MSG\fR
-If an error is returned and this bit is set in \fIflags\fR, then
-an error message will be left in the interpreter's result,
-where it can be retrieved with \fBTcl_GetObjResult\fR
-or \fBTcl_GetStringResult\fR.
-If this flag bit isn't set then no error message is left
-and the interpreter's result will not be modified.
-.TP
-\fBTCL_APPEND_VALUE\fR
-If this bit is set then \fInewValuePtr\fR is appended to the current
-value, instead of replacing it.
-If the variable is currently undefined, then this bit is ignored.
-.TP
-\fBTCL_LIST_ELEMENT\fR
-If this bit is set, then \fInewValuePtr\fR is converted to a valid
-Tcl list element before setting (or appending to) the variable.
-A separator space is appended before the new list element unless
-the list element is going to be the first element in a list or
-sublist (i.e. the variable's current value is empty, or contains
-the single character ``{'', or ends in `` }'').
-.TP
-\fBTCL_PARSE_PART1\fR
-If this bit is set,
-then \fBTcl_ObjGetVar2\fR and \fBTcl_ObjSetVar2\fR
-will parse \fIpart1Ptr\fR
-to obtain both an array name and an element name.
-If the name in \fIpart1Ptr\fR contains an open parenthesis
-and ends with a close parenthesis,
-the name is treated as the name of an element of an array;
-otherwise, the name in \fIpart1Ptr\fR
-is interpreted as the name of a scalar variable.
-When this bit is set,
-\fIpart2Ptr\fR is ignored.
-.PP
-\fBTcl_ObjGetVar2\fR returns the value of the specified variable.
-Its arguments are treated the same way as those for \fBTcl_ObjSetVar2\fR.
-It returns a pointer to the object which is the variable's value.
-The reference count for the returned object is not incremented.
-If the caller needs to keep a reference to the object,
-say in a data structure,
-it must increment the reference count using \fBTcl_IncrRefCount\fR.
-If an error occurs in setting the variable
-(e.g. an array variable is referenced
-without giving an index into the array),
-then NULL is returned.
-
-.SH "SEE ALSO"
-Tcl_GetObjResult, Tcl_GetStringResult, Tcl_GetVar, Tcl_GetVar2, Tcl_SetVar, Tcl_SetVar2, Tcl_TraceVar, Tcl_UnsetVar, Tcl_UnsetVar2
-
-.SH KEYWORDS
-array, interpreter, object, scalar, set, unset, variable
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH Tcl_Obj 3 8.0 Tcl "Tcl Library Procedures"
+.TH Tcl_Obj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
Tcl_NewObj, Tcl_DuplicateObj, Tcl_IncrRefCount, Tcl_DecrRefCount, Tcl_IsShared, Tcl_InvalidateStringRep \- manipulate Tcl objects
} Tcl_Obj;
.CE
The \fIbytes\fR and the \fIlength\fR members together hold
-an object's string representation,
-which is a \fIcounted\fR or \fIbinary string\fR
-that may contain binary data with embedded null bytes.
+.VS 8.1
+an object's UTF-8 string representation,
+which is a \fIcounted string\fR not containing null bytes (UTF-8 null
+characters should be encoded as a two byte sequence: 192, 128.)
\fIbytes\fR points to the first byte of the string representation.
The \fIlength\fR member gives the number of bytes.
-The byte array must always have a null after the last byte,
+The byte array must always have a null byte after the last data byte,
at offset \fIlength\fR;
-this allows string representations that do not contain nulls
+this allows string representations
to be treated as conventional null-terminated C strings.
+.VE 8.1
C programs use \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR to get
an object's string representation.
If \fIbytes\fR is NULL,
.SH KEYWORDS
internal representation, object, object creation, object type, reference counting, string representation, type conversion
-
.AS Tcl_ObjType *typeName in
.AP Tcl_ObjType *typePtr in
Points to the structure containing information about the Tcl object type.
-This storage must must live forever,
+This storage must live forever,
typically by being statically allocated.
-.AP char *typeName in
+.AP "CONST char" *typeName in
The name of a Tcl object type that \fBTcl_GetObjType\fR should look up.
.AP Tcl_Interp *interp in
Interpreter to use for error reporting.
describes the new type by giving its name
and by supplying pointers to four procedures
that implement the type.
-If the type table already containes a type
+If the type table already contains a type
with the same name as in \fItypePtr\fR,
it is replaced with the new type.
The Tcl_ObjType structure is described
stores the integer in \fIobjPtr\fR's internal representation
and sets \fIobjPtr\fR's \fItypePtr\fR member to point to the integer type's
Tcl_ObjType structure.
+Do not release \fIobjPtr\fR's old internal representation unless you
+replace it with a new one or reset the \fItypePtr\fR member to NULL.
.PP
The \fIupdateStringProc\fR member contains the address of a function
called to create a valid string representation
to have a null after the last byte, at offset \fIlength\fR;
this allows string representations that do not contain null bytes
to be treated as conventional null character-terminated C strings.
-Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR.
-Note that \fIupdateStringProc\fRs must allocate
+Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR
+or \fBckalloc\fR. Note that \fIupdateStringProc\fRs must allocate
enough storage for the string's bytes and the terminating null byte.
The \fIupdateStringProc\fR for Tcl's builtin list type, for example,
builds an array of strings for each element object
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_Ungets \- buffered I/O facilities using channels
+Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
-typedef ... Tcl_Channel;
-.sp
Tcl_Channel
\fBTcl_OpenFileChannel\fR(\fIinterp, fileName, mode, permissions\fR)
.sp
Tcl_Channel
\fBTcl_OpenCommandChannel\fR(\fIinterp, argc, argv, flags\fR)
-.VS 8.0
.sp
Tcl_Channel
\fBTcl_MakeFileChannel\fR(\fIhandle, readOrWrite\fR)
-.VE
.sp
Tcl_Channel
\fBTcl_GetChannel\fR(\fIinterp, channelName, modePtr\fR)
\fBTcl_UnregisterChannel\fR(\fIinterp, channel\fR)
.sp
int
+\fBTcl_DetachChannel\fR(\fIinterp, channel\fR)
+.sp
+int
+\fBTcl_IsStandardChannel\fR(\fIchannel\fR)
+.sp
+int
\fBTcl_Close\fR(\fIinterp, channel\fR)
.sp
.VS 8.1
\fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR)
.sp
int
-\fBTcl_Read\fR(\fIchannel, byteBuf, bytesToRead\fR)
+\fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR)
.sp
int
\fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR)
int
\fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR)
.VE
+.VS 8.3.2
+.sp
+int
+\fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR)
+.sp
+int
+\fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR)
+.VE
.sp
int
\fBTcl_Eof\fR(\fIchannel\fR)
.sp
int
\fBTcl_InputBuffered\fR(\fIchannel\fR)
+.VS 8.4
+.sp
+int
+\fBTcl_OutputBuffered\fR(\fIchannel\fR)
+.VE
.sp
int
\fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR)
.AS Tcl_ChannelType newClientProcPtr in
.AP Tcl_Interp *interp in
Used for error reporting and to look up a channel registered in it.
-.AP char *fileName in
+.AP "CONST char" *fileName in
The name of a local or network file.
-.AP char *mode in
+.AP "CONST char" *mode in
Specifies how the file is to be accessed. May have any of the values
-allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. For
-\fBTcl_OpenCommandChannel\fR, may be NULL.
+allowed for the \fImode\fR argument to the Tcl \fBopen\fR command.
.AP int permissions in
POSIX-style permission flags such as 0644. If a new file is created, these
permissions will be set on the created file.
.AP int argc in
The number of elements in \fIargv\fR.
-.AP char **argv in
+.AP "CONST char" **argv in
Arguments for constructing a command pipeline. These values have the same
meaning as the non-switch arguments to the Tcl \fBexec\fR command.
.AP int flags in
redirect stdio handles to override the stdio handles for which
\fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it
is set, then such redirections cause an error.
-.VS 8.0
.AP ClientData handle in
Operating system specific handle for I/O to a file. For Unix this is a
file descriptor, for Windows it is a HANDLE.
.AP int readOrWrite in
OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate
what operations are valid on \fIhandle\fR.
-.AP char *channelName in
+.AP "CONST char" *channelName in
The name of the channel.
-.VE
.AP int *modePtr out
Points at an integer variable that will receive an OR-ed combination of
\fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR denoting whether the channel is
open for reading and writing.
+.VS 8.3
+.AP "CONST char" *pattern in
+The pattern to match on, passed to Tcl_StringMatch, or NULL.
+.VE
.AP Tcl_Channel channel in
A Tcl channel for input or output. Must have been the return value
from a procedure such as \fBTcl_OpenFileChannel\fR.
A pointer to a Tcl dynamic string in which to store the line read from the
channel. Must have been initialized by the caller. The line read will be
appended to any data already in the dynamic string.
+.VS 8.3
+.AP "CONST char" *input in
+The input to add to a channel buffer.
+.AP int inputLen in
+Length of the input
+.AP int addAtEnd in
+Flag indicating whether the input should be added to the end or
+beginning of the channel buffer.
+.VE
.AP Tcl_Obj *writeObjPtr in
A pointer to a Tcl Object whose contents will be output to the channel.
.AP "CONST char" *charBuf in
A buffer containing the characters to output to the channel.
-.AP char *byteBuf in
+.AP "CONST char" *byteBuf in
A buffer containing the bytes to output to the channel.
.AP int bytesToWrite in
The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and
Relative to which point to seek; used with \fIoffset\fR to calculate the new
access point for the channel. Legal values are \fBSEEK_SET\fR,
\fBSEEK_CUR\fR, and \fBSEEK_END\fR.
-.AP char *optionName in
+.AP "CONST char" *optionName in
The name of an option applicable to this channel, such as \fB\-blocking\fR.
May have any of the values accepted by the \fBfconfigure\fR command.
.AP Tcl_DString *optionValue in
Where to store the value of an option or a list of all options and their
values. Must have been initialized by the caller.
-.AP char *newValue in
+.AP "CONST char" *newValue in
New value for the option given by \fIoptionName\fR.
-.VS 8.3
-.AP char *pattern in
-The pattern to match on, passed to Tcl_StringMatch, or NULL.
-.AP char *input in
-The input to add to a channel buffer.
-.AP int inputLen in
-Length of the input
-.AP int addToEnd in
-Flag indicating whether the input should be added to the end or
-beginning of the channel buffer.
-.VE
.BE
.SH DESCRIPTION
returns NULL and records a POSIX error code that can be
retrieved with \fBTcl_GetErrno\fR.
In addition, if \fIinterp\fR is non-NULL, \fBTcl_OpenFileChannel\fR
-leaves an error message in \fIinterp\fR's result after any error.
+leaves an error message in \fIinterp\fR's result after any error.
+As of Tcl 8.4, the object-based API \fBTcl_FSOpenFileChannel\fR should
+be used in preference to \fBTcl_OpenFileChannel\fR wherever possible.
+.PP
+
.PP
The newly created channel is not registered in the supplied interpreter; to
register it, use \fBTcl_RegisterChannel\fR, described below.
\fBTcl_GetChannel\fR returns a channel given the \fIchannelName\fR used to
create it with \fBTcl_CreateChannel\fR and a pointer to a Tcl interpreter in
\fIinterp\fR. If a channel by that name is not registered in that interpreter,
-the procedure returns NULL. If the \fImode\fR argument is not NULL, it
+the procedure returns NULL. If the \fImodePtr\fR argument is not NULL, it
points at an integer variable that will receive an OR-ed combination of
\fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR describing whether the channel is
open for reading and writing.
list object. \fBTcl_GetChannelNamesEx\fR will filter these names
according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it
will not do any filtering. The return value is \fBTCL_OK\fR if no
-errors occured writing to the result, otherwise it is \fBTCL_ERROR\fR,
+errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR,
and the error message is left in the interpreter's result.
.SH TCL_REGISTERCHANNEL
matching number of calls to \fBTcl_UnregisterChannel\fR have been made.
This allows code executing outside of any interpreter to safely hold a
reference to a channel that is also registered in a Tcl interpreter.
+.PP
+This procedure interacts with the code managing the standard
+channels. If no standard channels were initialized before the first
+call to \fBTcl_RegisterChannel\fR they will get initialized by that
+call. See \fBTcl_StandardChannels\fR for a general treatise about
+standard channels and the behaviour of the Tcl library with regard to
+them.
.SH TCL_UNREGISTERCHANNEL
.PP
Code not associated with a Tcl interpreter can call
\fBTcl_UnregisterChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl
that it no longer holds a reference to that channel. If this is the last
-reference to the channel, it will now be closed.
+reference to the channel, it will now be closed. \fBTcl_UnregisterChannel\fR
+is very similar to \fBTcl_DetachChannel\fR except that it will also
+close the channel if no further references to it exist.
+
+.SH TCL_DETACHCHANNEL
+.PP
+\fBTcl_DetachChannel\fR removes a channel from the set of channels
+accessible in \fIinterp\fR. After this call, Tcl programs will no longer be
+able to use the channel's name to refer to the channel in that interpreter.
+Beyond that, this command has no further effect. It cannot be used on
+the standard channels (stdout, stderr, stdin), and will return
+TCL_ERROR if passed one of those channels.
+.PP
+Code not associated with a Tcl interpreter can call
+\fBTcl_DetachChannel\fR with \fIinterp\fR as NULL, to indicate to Tcl
+that it no longer holds a reference to that channel. If this is the last
+reference to the channel, unlike \fBTcl_UnregisterChannel\fR,
+it will not be closed.
+
+.SH TCL_ISSTANDARDCHANNEL
+.PP
+\fBTcl_IsStandardChannel\fR tests whether a channel is one of the
+three standard channels, stdin, stdout or stderr. If so, it returns
+1, otherwise 0.
+.PP
+No attempt is made to check whether the given channel or the standard
+channels are initialized or otherwise valid.
.SH TCL_CLOSE
.PP
to UTF-8 based on the channel's encoding and storing the produced data in
\fIreadObjPtr\fR's string representation. The return value of
\fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR,
-that were stored in \fIobjPtr\fR. If an error occurs while reading, the
+that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the
return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that
can be retrieved with \fBTcl_GetErrno\fR.
.PP
encoding conversions, regardless of the channel's encoding. It is deprecated
and exists for backwards compatibility with non-internationalized Tcl
extensions. It consumes bytes from \fIchannel\fR and stores them in
-\fIbuf\fR, performing end-of-line translations on the way. The return value
-of \fBTcl_Read\fR is the number of bytes, up to \fItoRead\fR, written in
-\fIbuf\fR. The buffer produced by \fBTcl_Read\fR is not NULL terminated.
+\fIreadBuf\fR, performing end-of-line translations on the way. The return value
+of \fBTcl_Read\fR is the number of bytes, up to \fIbytesToRead\fR, written in
+\fIreadBuf\fR. The buffer produced by \fBTcl_Read\fR is not NULL terminated.
Its contents are valid from the zeroth position up to and excluding the
position indicated by the return value.
+.PP
+\fBTcl_ReadRaw\fR is the same as \fBTcl_Read\fR but does not
+compensate for stacking. While \fBTcl_Read\fR (and the other functions
+in the API) always get their data from the topmost channel in the
+stack the supplied channel is part of, \fBTcl_ReadRaw\fR does
+not. Thus this function is \fBonly\fR usable for transformational
+channel drivers, i.e. drivers used in the middle of a stack of
+channels, to move data from the channel below into the transformation.
.SH "TCL_GETSOBJ AND TCL_GETS"
.PP
of input unavailability.
.PP
\fBTcl_Gets\fR is the same as \fBTcl_GetsObj\fR except the resulting
-characters are appended to the appended to the dynamic string given by
-\fIdsPtr\fR rather than a Tcl object.
+characters are appended to the dynamic string given by
+\fIlineRead\fR rather than a Tcl object.
.SH "TCL_UNGETS"
.PP
\fBTcl_Ungets\fR is used to add data to the input queue of a channel,
-at either the head or tail of the queue. \fIInput\fR is a pointer to
-the data that is to be added. \fIInputLen\fR gives the length of the
-input to add. \fIAddAtEnd\fR, in non-zero, indicates that the data is
-to be added at the end of queue; otherwise it will be added at the
+at either the head or tail of the queue. The pointer \fIinput\fR points
+to the data that is to be added. The length of the input to add is given
+by \fIinputLen\fR. A non-zero value of \fIaddAtEnd\fR indicates that the
+data is to be added at the end of queue; otherwise it will be added at the
head of the queue. If \fIchannel\fR has a "sticky" EOF set, no data will be
added to the input queue. \fBTcl_Ungets\fR returns \fIinputLen\fR or
-1 if an error occurs.
\fIbyteBuf\fR and queues them for output to \fIchannel\fR. If
\fIbytesToWrite\fR is negative, \fBTcl_Write\fR expects \fIbyteBuf\fR to be
NULL terminated and it outputs everything up to the NULL.
+.PP
+\fBTcl_WriteRaw\fR is the same as \fBTcl_Write\fR but does not
+compensate for stacking. While \fBTcl_Write\fR (and the other
+functions in the API) always feed their input to the topmost channel
+in the stack the supplied channel is part of, \fBTcl_WriteRaw\fR does
+not. Thus this function is \fBonly\fR usable for transformational
+channel drivers, i.e. drivers used in the middle of a stack of
+channels, to move data from the transformation into the channel below
+it.
.VE
.SH TCL_FLUSH
.SH TCL_GETCHANNELOPTION
.PP
-\fBTcl_GetChannelOption\fR retrieves, in \fIdsPtr\fR, the value of one of
+\fBTcl_GetChannelOption\fR retrieves, in \fIoptionValue\fR, the value of one of
the options currently in effect for a channel, or a list of all options and
their values. The \fIchannel\fR argument identifies the channel for which
to query an option or retrieve all options and their values.
.SH TCL_SETCHANNELOPTION
.PP
-\fBTcl_SetChannelOption\fR sets a new value for an option on \fIchannel\fR.
-\fIOptionName\fR is the option to set and \fInewValue\fR is the value to
-set.
+\fBTcl_SetChannelOption\fR sets a new value \fInewValue\fR
+for an option \fIoptionName\fR on \fIchannel\fR.
The procedure normally returns \fBTCL_OK\fR. If an error occurs,
it returns \fBTCL_ERROR\fR; in addition, if \fIinterp\fR is non-NULL,
\fBTcl_SetChannelOption\fR leaves an error message in the interpreter's result.
buffered in the internal buffers for a channel. If the channel is not open
for reading, this function always returns zero.
-.VS 8.0
+.SH TCL_OUTPUTBUFFERED
+.VS 8.4
+\fBTcl_OutputBuffered\fR returns the number of bytes of output
+currently buffered in the internal buffers for a channel. If the
+channel is not open for writing, this function always returns zero.
+.VE
+
.SH "PLATFORM ISSUES"
.PP
The handles returned from \fBTcl_GetChannelHandle\fR depend on the
channel types may return a different type of handle on Windows
platforms. On the Macintosh platform, the handle is a file reference
number as returned from \fBHOpenDF\fR.
-.VE
.SH "SEE ALSO"
-DString(3), fconfigure(n), filename(n), fopen(2), Tcl_CreateChannel(3)
+DString(3), fconfigure(n), filename(n), fopen(3), Tcl_CreateChannel(3)
.SH KEYWORDS
access point, blocking, buffered I/O, channel, channel driver, end of file,
flush, input, nonblocking, output, read, seek, write
-
error occurs, an error message is left in the interpreter's result.
.AP int port in
A port number to connect to as a client or to listen on as a server.
-.AP char *host in
+.AP "CONST char" *host in
A string specifying a host name or address for the remote end of the connection.
.AP int myport in
A port number for the client's end of the socket. If 0, a port number
is allocated at random.
-.AP char *myaddr in
+.AP "CONST char" *myaddr in
A string specifying the host name or address for network interface to use
for the local end of the connection. If NULL, a default interface is
chosen.
.SH KEYWORDS
client, server, TCP
-
.TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens \- parse Tcl scripts and expressions
+Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
int
\fBTcl_ParseVarName\fR(\fIinterp, string, numBytes, parsePtr, append\fR)
.sp
-char *
+CONST char *
\fBTcl_ParseVar\fR(\fIinterp, string, termPtr\fR)
.sp
\fBTcl_FreeParse\fR(\fIusedParsePtr\fR)
.sp
Tcl_Obj *
\fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR)
+.sp
+Tcl_Obj *
+\fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR)
.SH ARGUMENTS
.AS Tcl_Interp *usedParsePtr
.AP Tcl_Interp *interp out
-For procedures other than \fBTcl_FreeParse\fR and \fBTcl_EvalTokens\fR,
-used only for error reporting;
+For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR
+and \fBTcl_EvalTokensStandard\fR, used only for error reporting;
if NULL, then no error messages are left after errors.
-For \fBTcl_EvalTokens\fR, determines the context for evaluating the
+For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR,
+determines the context for evaluating the
script and also is used for error reporting; must not be NULL.
-.AP char *string in
+.AP "CONST char" *string in
Pointer to first character in string to parse.
.AP int numBytes in
Number of bytes in \fIstring\fR, not including any terminating null
is ignored, unless \fIappend\fR is non-zero in a call to
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR,
or \fBTcl_ParseVarName\fR.
-.AP char **termPtr out
+.AP "CONST char" **termPtr out
If not NULL, points to a location where
\fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and
\fBTcl_ParseVar\fR will store a pointer to the character
(see below for details),
and stores a pointer to the character just after the terminating \fB}\fR
in the location given by \fI*termPtr\fR.
-If an error occurrs while parsing the string
+If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
(see below for details),
and stores a pointer to the character just after the terminating \fB"\fR
in the location given by \fI*termPtr\fR.
-If an error occurrs while parsing the string
+If an error occurs while parsing the string
then \fBTCL_ERROR\fR is returned,
an error message is left in \fIinterp\fR's result,
and no information is left at \fI*parsePtr\fR or \fI*termPtr\fR.
returns \fBTCL_OK\fR and fills in the structure pointed to by
\fIparsePtr\fR with information about the structure of the variable name
(see below for details). If an error
-occurrs while parsing the command then \fBTCL_ERROR\fR is returned, an
+occurs while parsing the command then \fBTCL_ERROR\fR is returned, an
error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't
NULL), and no information is left at \fI*parsePtr\fR.
.PP
so if repeated calls are being made to any of them
then \fBTcl_FreeParse\fR must be invoked once after each call.
.PP
-\fBTcl_EvalTokens\fR evaluates a sequence of parse tokens from a Tcl_Parse
-structure. The tokens typically consist
+\fBTcl_EvalTokensStandard\fR evaluates a sequence of parse tokens from
+a Tcl_Parse structure. The tokens typically consist
of all the tokens in a word or all the tokens that make up the index for
-a reference to an array variable. \fBTcl_EvalTokens\fR performs the
-substitutions requested by the tokens, concatenates the
-resulting values, and returns the result in a new Tcl_Obj. The
-reference count of the object returned as result has been
+a reference to an array variable. \fBTcl_EvalTokensStandard\fR performs the
+substitutions requested by the tokens and concatenates the
+resulting values.
+The return value from \fBTcl_EvalTokensStandard\fR is a Tcl completion
+code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR,
+\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR.
+In addition, a result value or error message is left in \fIinterp\fR's
+result; it can be retrieved using \fBTcl_GetObjResult\fR.
+.PP
+\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in
+the return convention used: it returns the result in a new Tcl_Obj.
+The reference count of the object returned as result has been
incremented, so the caller must
invoke \fBTcl_DecrRefCount\fR when it is finished with the object.
-If an error occurs while evaluating the tokens (such as a reference to
-a non-existent variable) then the return value is NULL and an error
-message is left in \fIinterp\fR's result.
+If an error or other exception occurs while evaluating the tokens
+(such as a reference to a non-existent variable) then the return value
+is NULL and an error message is left in \fIinterp\fR's result. The use
+of \fBTcl_EvalTokens\fR is deprecated.
.SH "TCL_PARSE STRUCTURE"
.PP
\fBTCL_TOKEN_OPERATOR\fR
The token describes one operator of an expression
such as \fB&&\fR or \fBhypot\fR.
-An \fBTCL_TOKEN_OPERATOR\fR token is always preceeded by a
+An \fBTCL_TOKEN_OPERATOR\fR token is always preceded by a
\fBTCL_TOKEN_SUB_EXPR\fR token
that describes the operator and its operands;
the \fBTCL_TOKEN_SUB_EXPR\fR token's \fInumComponents\fR field
.SH KEYWORDS
backslash substitution, braces, command, expression, parse, token, variable substitution
-
.nf
\fB#include <tcl.h>\fR
.sp
-char *
+CONST char *
\fBTcl_PkgRequire\fR(\fIinterp, name, version, exact\fR)
.sp
-char *
+CONST char *
\fBTcl_PkgRequireEx\fR(\fIinterp, name, version, exact, clientDataPtr\fR)
.sp
-char *
+CONST char *
\fBTcl_PkgPresent\fR(\fIinterp, name, version, exact\fR)
.sp
-char *
+CONST char *
\fBTcl_PkgPresentEx\fR(\fIinterp, name, version, exact, clientDataPtr\fR)
.sp
int
int
\fBTcl_PkgProvideEx\fR(\fIinterp, name, version, clientData\fR)
.SH ARGUMENTS
-.AS Tcl_FreeProc clientDataPtr
+.AS ClientData clientDataPtr
.AP Tcl_Interp *interp in
Interpreter where package is needed or available.
-.AP char *name in
+.AP "CONST char" *name in
Name of package.
-.AP char *version in
+.AP "CONST char" *version in
A version string consisting of one or more decimal numbers
separated by dots.
.AP int exact in
.SH KEYWORDS
package, present, provide, require, version
-
\fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical
reasons, but the value is the same.
.PP
+When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR
+refers to storage allocated and returned by a prior call to
+\fBTcl_Alloc\fR, \fBckalloc\fR, or another function of the Tcl library,
+then the \fIfreeProc\fR argument should be given the special value of
+\fBTCL_DYNAMIC\fR.
+.PP
This mechanism can be used to solve the problem described above
by placing \fBTcl_Preserve\fR and \fBTcl_Release\fR calls around
actions that may cause undesired storage re-allocation. The
structure of the objects being freed; it keeps the reference
counts in a separate structure.
+.SH "SEE ALSO"
+Tcl_Interp, Tcl_Alloc
+
.SH KEYWORDS
free, reference count, storage
.SH KEYWORDS
command, event, execute, history, interpreter, object, record
-
.AS Tcl_Interp *interp;
.AP Tcl_Interp *interp in
Tcl interpreter in which to evaluate command.
-.AP char *cmd in
+.AP "CONST char" *cmd in
Command (or sequence of commands) to execute.
.AP int flags in
An OR'ed combination of flag bits. TCL_NO_EVAL means record the
.SH KEYWORDS
command, event, execute, history, interpreter, record
-
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
-'\" Copyright (c) 1998-1999 Scriptics Corportation
+'\" Copyright (c) 1998-1999 Scriptics Corporation
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.VE 8.1
.AP char *string in
String to check for a match with a regular expression.
-.AP char *pattern in
+.AP "CONST char" *pattern in
String in the form of a regular expression pattern.
.AP Tcl_RegExp regexp in
Compiled regular expression. Must have been returned previously
Specifies which range is desired: 0 means the range of the entire
match, 1 or greater means the range that matched a parenthesized
sub-expression.
-.AP char **startPtr out
+.VS 8.4
+.AP "CONST char" **startPtr out
The address of the first character in the range is stored here, or
NULL if there is no such range.
-.AP char **endPtr out
+.AP "CONST char" **endPtr out
The address of the character just after the last one in the range
is stored here, or NULL if there is no such range.
+.VE 8.4
.VS 8.1
.AP int cflags in
OR-ed combination of compilation flags. See below for more information.
information is returned about the range of characters that matched the
\fIindex\fR'th parenthesized subexpression within the pattern.
If there is no range corresponding to \fIindex\fR then NULL
-is stored in \fI*firstPtr\fR and \fI*lastPtr\fR.
+is stored in \fI*startPtr\fR and \fI*endPtr\fR.
.PP
.VS 8.1
\fBTcl_GetRegExpFromObj\fR, \fBTcl_RegExpExecObj\fR, and
to Unicode translations as well as providing improved performance
through caching in the pattern and string objects.
.PP
-\fBTcl_GetRegExpFromObj\fR attepts to return a compiled regular
+\fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular
expression from the \fIpatObj\fR. If the object does not already
contain a compiled regular expression it will attempt to create one
from the string in the object and assign it to the internal
re_syntax(n)
.SH KEYWORDS
match, pattern, regular expression, string, subexpression, Tcl_RegExpIndices, Tcl_RegExpInfo
-
int
\fBTcl_GetErrno\fR()
.sp
-char *
+CONST char *
\fBTcl_ErrnoId\fR()
.sp
-char *
-\fBTcl_ErrnoMsg\fR()
+CONST char *
+\fBTcl_ErrnoMsg\fR(\fIerrorCode\fR)
.sp
.SH ARGUMENTS
-.AS Tcl_Interp *errorCode in
+.AS int errorCode in
.AP int errorCode in
A POSIX error code such as \fBENOENT\fR.
.BE
Procedures wishing to access \fBerrno\fR should call this procedure
instead of accessing \fBerrno\fR directly.
.PP
-\fBTcl_ErrnoId\fR and \fBTcl_ErrnoMsg\fR return a string
-representation of the current \fBerrno\fR value. \fBTcl_ErrnoId\fR
+\fBTcl_ErrnoId\fR and \fBTcl_ErrnoMsg\fR return string
+representations of \fBerrno\fR values. \fBTcl_ErrnoId\fR
returns a machine-readable textual identifier such as
-"EACCES". \fBTcl_ErrnoMsg\fR returns a human-readable string such as
-"permission denied". The strings returned by these functions are
+"EACCES" that corresponds to the current value of \fBerrno\fR.
+\fBTcl_ErrnoMsg\fR returns a human-readable string such as
+"permission denied" that corresponds to the value of its
+\fIerrorCode\fR argument. The \fIerrorCode\fR argument is
+typically the value returned by \fBTcl_GetErrno\fR.
+The strings returned by these functions are
statically allocated and the caller must not free or modify them.
.SH KEYWORDS
.sp
\fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR)
.sp
-char *
+CONST char *
\fBTcl_GetStringResult\fR(\fIinterp\fR)
.sp
\fBTcl_AppendResult\fR(\fIinterp, string, string, ... , \fB(char *) NULL\fR)
.SH KEYWORDS
append, command, element, list, object, result, return value, interpreter
-
\fBTcl_SetVar2Ex\fR(\fIinterp, name1, name2, newValuePtr, flags\fR)
.VE
.sp
-char *
+CONST char *
\fBTcl_SetVar\fR(\fIinterp, varName, newValue, flags\fR)
.sp
-char *
+CONST char *
\fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR)
.sp
Tcl_Obj *
\fBTcl_GetVar2Ex\fR(\fIinterp, name1, name2, flags\fR)
.VE
.sp
-char *
+CONST char *
\fBTcl_GetVar\fR(\fIinterp, varName, flags\fR)
.sp
-char *
+CONST char *
\fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR)
.sp
Tcl_Obj *
.AS Tcl_Interp *newValuePtr
.AP Tcl_Interp *interp in
Interpreter containing variable.
-.AP char *name1 in
+.AP "CONST char" *name1 in
Contains the name of an array variable (if \fIname2\fR is non-NULL)
or (if \fIname2\fR is NULL) either the name of a scalar variable
or a complete name including both variable name and index.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
-.AP char *name2 in
+.AP "CONST char" *name2 in
If non-NULL, gives name of element within array; in this
case \fIname1\fR must refer to an array variable.
.AP Tcl_Obj *newValuePtr in
.AP int flags in
OR-ed combination of bits providing additional information. See below
for valid values.
-.AP char *varName in
+.AP "CONST char" *varName in
Name of variable.
May include \fB::\fR namespace qualifiers
to specify a variable in a particular namespace.
May refer to a scalar variable or an element of
an array.
-If the name references an element of an array, then the name
-must be in writable memory: Tcl will make temporary modifications
-to it while looking up the name.
-.AP char *newValue in
+.AP "CONST char" *newValue in
New value for variable, specified as a NULL-terminated string.
A copy of this value is stored in the variable.
.AP Tcl_Obj *part1Ptr in
int
\fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR)
.SH ARGUMENTS
-.AS Tcl_Interp ***argvPtr
+.AS "CONST char * CONST" ***argvPtr
.AP Tcl_Interp *interp out
Interpreter to use for error reporting. If NULL, then no error message
is left.
Pointer to a string with proper list structure.
.AP int *argcPtr out
Filled in with number of elements in \fIlist\fR.
-.AP char ***argvPtr out
+.AP "CONST char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIlist\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP int argc in
Number of elements in \fIargv\fR.
-.AP char **argv in
+.AP "CONST char * CONST" *argv in
Array of strings to merge together into a single list.
Each string will become a separate element of the list.
-.AP char *src in
+.AP "CONST char" *src in
String that is to become an element of a list.
.AP int *flagsPtr in
Pointer to word to fill in with information about \fIsrc\fR.
.SH KEYWORDS
backslash, convert, element, list, merge, split, strings
-
\fBTcl_GetPathType\fR(\fIpath\fR)
.SH ARGUMENTS
.AS Tcl_DString ***argvPtr
-.AP char *path in
+.AP "CONST char * CONST" *argvPtr in
File path in a form appropriate for the current platform (see the
\fBfilename\fR manual entry for acceptable forms for path names).
.AP int *argcPtr out
Filled in with number of path elements in \fIpath\fR.
-.AP char ***argvPtr out
+.AP "CONST char" ***argvPtr out
\fI*argvPtr\fR will be filled in with the address of an array of
pointers to the strings that are the extracted elements of \fIpath\fR.
There will be \fI*argcPtr\fR valid entries in the array, followed by
a NULL entry.
.AP int argc in
Number of elements in \fIargv\fR.
-.AP char **argv in
+.AP "CONST char * CONST" *argv in
Array of path elements to merge together into a single path.
.AP Tcl_DString *resultPtr in/out
A pointer to an initialized \fBTcl_DString\fR to which the result of
.SH DESCRIPTION
.PP
+These procedures have been superceded by the objectified procedures in
+the \fBFileSystem\fR man page, which are more efficient.
+.PP
These procedures may be used to disassemble and reassemble file
paths in a platform independent manner: they provide C-level access to
the same functionality as the \fBfile split\fR, \fBfile join\fR, and
already been loaded (i.e., the caller has already invoked the
appropriate initialization procedure). NULL means the package
hasn't yet been incorporated into any interpreter.
-.AP char *pkgName in
+.AP "CONST char" *pkgName in
Name of the package; should be properly capitalized (first letter
upper-case, all others lower-case).
.AP Tcl_PackageInitProc *initProc in
.SH KEYWORDS
initialization procedure, package, static linking
-
.sp
int
\fBTcl_StringMatch\fR(\fIstring\fR, \fIpattern\fR)
-.VS 8.1
.sp
-\fBTcl_StringCaseMatch\fR(\fIstring, pattern, nocase\fR)
-.VE 8.1
+int
+\fBTcl_StringCaseMatch\fR(\fIstring\fR, \fIpattern\fR, \fInocase\fR)
.SH ARGUMENTS
.AP char *string in
String to test.
.AP char *pattern in
Pattern to match against string. May contain special
characters from the set *?\e[].
-.VS 8.1
.AP int nocase in
Specifies whether the match should be done case-sensitive (0) or
case-insensitive (1).
-.VE 8.1
.BE
.SH DESCRIPTION
.TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj \- manipulate Tcl objects as strings
+Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
Tcl_Obj *
\fBTcl_NewStringObj\fR(\fIbytes, length\fR)
-.VS 8.1.2
.sp
Tcl_Obj *
\fBTcl_NewUnicodeObj\fR(\fIunicode, numChars\fR)
-.VE
.sp
void
\fBTcl_SetStringObj\fR(\fIobjPtr, bytes, length\fR)
-.VS 8.1.2
.sp
void
\fBTcl_SetUnicodeObj\fR(\fIobjPtr, unicode, numChars\fR)
-.VE
.sp
char *
\fBTcl_GetStringFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
char *
\fBTcl_GetString\fR(\fIobjPtr\fR)
-.VS 8.1.2
+.sp
+Tcl_UniChar *
+\fBTcl_GetUnicodeFromObj\fR(\fIobjPtr, lengthPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_GetUnicode\fR(\fIobjPtr\fR)
.sp
Tcl_Obj *
\fBTcl_GetRange\fR(\fIobjPtr, first, last\fR)
-.VE
.sp
void
\fBTcl_AppendToObj\fR(\fIobjPtr, bytes, length\fR)
-.VS 8.1.2
.sp
void
\fBTcl_AppendUnicodeToObj\fR(\fIobjPtr, unicode, numChars\fR)
-.VE
.sp
void
\fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR)
void
\fBTcl_SetObjLength\fR(\fIobjPtr, newLength\fR)
.sp
+int
+\fBTcl_AttemptSetObjLength\fR(\fIobjPtr, newLength\fR)
+.sp
Tcl_Obj *
\fBTcl_ConcatObj\fR(\fIobjc, objv\fR)
.SH ARGUMENTS
-.AS Tcl_Interp *appendObjPtr in/out
-.AP char *bytes in
-Points to the first byte of an array of bytes
+.AS "CONST Tcl_UniChar" *appendObjPtr in/out
+.AP "CONST char" *bytes in
+.VS 8.1
+Points to the first byte of an array of UTF-8-encoded bytes
used to set or append to a string object.
-This byte array may contain embedded null bytes
-unless \fIlength\fR is negative.
+This byte array should not contain embedded null bytes
+unless \fIlength\fR is negative. (Applications needing null bytes
+should represent them as the two-byte sequence \fI\\700\\600\fR, use
+\fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if
+the string is a collection of uninterpreted bytes.)
+.VE 8.1
.AP int length in
The number of bytes to copy from \fIbytes\fR when
initializing, setting, or appending to a string object.
If negative, all bytes up to the first null are used.
-.AP Tcl_UniChar *unicode in
+.AP "CONST Tcl_UniChar" *unicode in
Points to the first byte of an array of Unicode characters
used to set or append to a string object.
This byte array may contain embedded null characters
unless \fInumChars\fR is negative.
-.VS 8.1.2
.AP int numChars in
The number of Unicode characters to copy from \fIunicode\fR when
initializing, setting, or appending to a string object.
.AP int last in
The index of the last Unicode character in the Unicode range to be
returned as a new object.
-.VE
.AP Tcl_Obj *objPtr in/out
Points to an object to manipulate.
.AP Tcl_Obj *appendObjPtr in
.AP int *lengthPtr out
If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store
the the length of an object's string representation.
-.AP char *string in
+.AP "CONST char" *string in
Null-terminated string value to append to \fIobjPtr\fR.
.AP va_list argList in
An argument list which must have been initialised using
manipulations more efficient. In particular, they make a series of
append operations efficient by allocating extra storage space for the
string so that it doesn't have to be copied for each append.
-.VS 8.1.2
Also, indexing and length computations are optimized because the
Unicode string representation is calculated and cached as needed.
-.VE
+When using the \fBTcl_Append*\fR family of functions where the
+interpreter's result is the object being appended to, it is important
+to call Tcl_ResetResult first to ensure you are not unintentionally
+appending to existing data in the result object.
.PP
-.VS 8.1.2
\fBTcl_NewStringObj\fR and \fBTcl_SetStringObj\fR create a new object
or modify an existing object to hold a copy of the string given by
\fIbytes\fR and \fIlength\fR. \fBTcl_NewUnicodeObj\fR and
string. \fBTcl_SetStringObj\fR and \fBTcl_SetUnicodeObj\fR free any
old string representation as well as any old internal representation
of the object.
-.VE
.PP
\fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return an object's
string representation. This is given by the returned byte pointer and
representation is invalid (its byte pointer is NULL), the string
representation is regenerated from the object's internal
representation. The storage referenced by the returned byte pointer
-is owned by the object manager and should not be modified by the
-caller. The procedure \fBTcl_GetString\fR is used in the common case
+is owned by the object manager. It is passed back as a writable
+pointer so that extension author creating their own \fBTcl_ObjType\fR
+will be able to modify the string representation within the
+\fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR. Except for that
+limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR
+or \fBTcl_GetString\fR should be treated as read-only. It is
+recommended that this pointer be assigned to a (CONST char *) variable.
+Even in the limited situations where writing to this pointer is
+acceptable, one should take care to respect the copy-on-write
+semantics required by \fBTcl_Obj\fR's, with appropriate calls
+to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any
+in-place modification of the string representation.
+The procedure \fBTcl_GetString\fR is used in the common case
where the caller does not need the length of the string
representation.
.PP
-.VS 8.1.2
-\fBTcl_GetUnicode\fR returns an object's value as a Unicode string.
+\fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return an object's
+value as a Unicode string. This is given by the returned pointer and
+(for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in
+\fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned
+byte pointer is owned by the object manager and should not be modified by
+the caller. The procedure \fBTcl_GetUnicode\fR is used in the common case
+where the caller does not need the length of the unicode string
+representation.
+.PP
\fBTcl_GetUniChar\fR returns the \fIindex\fR'th character in the
object's Unicode representation.
.PP
appends the string or Unicode value (whichever exists and is best
suited to be appended to \fIobjPtr\fR) of \fIappendObjPtr\fR to
\fIobjPtr\fR.
-.VE
.PP
\fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR
except that it can be passed more than one value to append and
reallocating storage. In all cases \fBTcl_SetObjLength\fR leaves
a null character at \fIobjPtr->bytes[newLength]\fR.
.PP
+\fBTcl_AttemptSetObjLength\fR is identical in function to
+\fBTcl_SetObjLength\fR except that if sufficient memory to satisfy the
+request cannot be allocated, it does not cause the Tcl interpreter to
+\fBpanic\fR. Thus, if \fInewLength\fR is greater than the space
+allocated for the object's string, and there is not enough memory
+available to satisfy the request, \fBTcl_AttemptSetObjLength\fR will take
+no action and return 0 to indicate failure. If there is enough memory
+to satisfy the request, \fBTcl_AttemptSetObjLength\fR behaves just like
+\fBTcl_SetObjLength\fR and returns 1 to indicate success.
+.PP
The \fBTcl_ConcatObj\fR function returns a new string object whose
value is the space-separated concatenation of the string
representations of all of the objects in the \fIobjv\fR
memory leaks, memory allocation overruns, and other memory related
errors.
-.SH ENABLING MEMORY DEBUGGING
+.SH "ENABLING MEMORY DEBUGGING"
.PP
To enable memory debugging, Tcl should be recompiled from scratch with
\fBTCL_MEM_DEBUG\fR defined. This will also compile in a non-stub
and the Tcl \fBmemory\fR command can be used to validate and examine
memory usage.
-.SH GUARD ZONES
+.SH "GUARD ZONES"
.PP
When memory debugging is enabled, whenever a call to \fBckalloc\fR is
made, slightly more memory than requested is allocated so the memory debugging
code can keep track of the allocated memory, and eight-byte ``guard
zones'' are placed in front of and behind the space that will be
-returned to the caller. (The size of the guard zone is defined by the
-C #define \fBGUARD_SIZE\fR in \fIbaseline/src/ckalloc.c\fR -- it can
+returned to the caller. (The sizes of the guard zones are defined by the
+C #define \fBLOW_GUARD_SIZE\fR and #define \fBHIGH_GUARD_SIZE\fR
+in the file \fIgeneric/tclCkalloc.c\fR -- it can
be extended if you suspect large overwrite problems, at some cost in
performance.) A known pattern is written into the guard zones and, on
a call to \fBckfree\fR, the guard zones of the space being freed are
not enough space was allocated to contain the data written, for
example.
-.SH DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS
+.SH "DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS"
.PP
Normally, Tcl compiled with memory debugging enabled will make it easy
to isolate a corruption problem. Turning on memory validation with
to remove the calls after you find the problem.
.SH "SEE ALSO"
-memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory
+ckalloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory
.SH KEYWORDS
memory, debug
.RS
.TP 15
\fB$\fIname\fR
-\fIName\fR is the name of a scalar variable; the name is terminated
-by any character that isn't a letter, digit, or underscore.
+\fIName\fR is the name of a scalar variable; the name is a sequence
+of one or more characters that are a letter, digit, underscore,
+or namespace separators (two or more colons).
.TP 15
\fB$\fIname\fB(\fIindex\fB)\fR
\fIName\fR gives the name of an array variable and \fIindex\fR gives
the name of an element within that array.
-\fIName\fR must contain only letters, digits, and underscores.
+\fIName\fR must contain only letters, digits, underscores, and
+namespace separators, and may be an empty string.
Command substitutions, variable substitutions, and backslash
substitutions are performed on the characters of \fIindex\fR.
.TP 15
+++ /dev/null
-'\"
-'\" Copyright (c) 1999 Scriptics Corportation
-'\"
-'\" See the file "license.terms" for information on usage and redistribution
-'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-'\"
-'\" RCS: @(#) $Id$
-'\"
-.so man.macros
-.TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures"
-.BS
-.SH NAME
-Tcl_InitStubs \- initialize the Tcl stubs mechanism
-.SH SYNOPSIS
-.nf
-\fB#include <tcl.h>\fR
-.sp
-char *
-\fBTcl_InitStubs\fR(\fIinterp, version, exact\fR)
-.SH ARGUMENTS
-.AS Tcl_Interp *interp in
-.AP Tcl_Interp *interp in
-Tcl interpreter handle.
-.AP char *version in
-A version string consisting of one or more decimal numbers
-separated by dots.
-.AP int exact in
-Non-zero means that only the particular version specified by
-\fIversion\fR is acceptable.
-Zero means that versions newer than \fIversion\fR are also
-acceptable as long as they have the same major version number
-as \fIversion\fR.
-.BE
-.SH INTRODUCTION
-.PP
-The Tcl stubs mechanism defines a way to dynamically bind
-extensions to a particular Tcl implementation at run time.
-This provides two significant benefits to Tcl users:
-.IP 1) 5
-Extensions that use the stubs mechanism can be loaded into
-multiple versions of Tcl without being recompiled or
-relinked.
-.IP 2) 5
-Extensions that use the stubs mechanism can be dynamically
-loaded into statically-linked Tcl applications.
-.PP
-The stubs mechanism accomplishes this by exporting function tables
-that define an interface to the Tcl API. The extension then accesses
-the Tcl API through offsets into the function table, so there are no
-direct references to any of the Tcl library's symbols. This
-redirection is transparent to the extension, so an extension writer
-can continue to use all public Tcl functions as documented.
-.PP
-The stubs mechanism requires no changes to applications incorporating
-Tcl interpreters. Only developers creating C-based Tcl extensions
-need to take steps to use the stubs mechanism with their extensions.
-.PP
-Enabling the stubs mechanism for an extension requires the following
-steps:
-.IP 1) 5
-Call \fBTcl_InitStubs\fR in the extension before calling any other
-Tcl functions.
-.IP 2) 5
-Define the USE_TCL_STUBS symbol. Typically, you would include the
--DUSE_TCL_STUBS flag when compiling the extension.
-.IP 3) 5
-Link the extension with the Tcl stubs library instead of the standard
-Tcl library. On Unix platforms, the library name is
-\fIlibtclstub8.1.a\fR; on Windows platforms, the library name is
-\fItclstub81.lib\fR.
-.PP
-If the extension also requires the Tk API, it must also call
-\fBTk_InitStubs\fR to initialize the Tk stubs interface and link
-with the Tk stubs libraries. See the \fBTk_InitStubs\fR page for
-more information.
-.SH DESCRIPTION
-\fBTcl_InitStubs\fR attempts to initialize the stub table pointers
-and ensure that the correct version of Tcl is loaded. In addition
-to an interpreter handle, it accepts as arguments a version number
-and a Boolean flag indicating whether the extension requires
-an exact version match or not. If \fIexact\fR is 0, then the
-extension is indicating that newer versions of Tcl are acceptable
-as long as they have the same major version number as \fIversion\fR;
-non-zero means that only the specified \fIversion\fR is acceptable.
-\fBTcl_InitStubs\fR returns a string containing the actual version
-of Tcl satisfying the request, or NULL if the Tcl version is not
-acceptable, does not support stubs, or any other error condition occurred.
-.SH "SEE ALSO"
-\fBTk_InitStubs\fR
-.SH KEYWORDS
-stubs
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH Tcl_Main 3 7.4 Tcl "Tcl Library Procedures"
+.TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_Main \- main program for Tcl-based applications
+Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
\fBTcl_Main\fR(\fIargc, argv, appInitProc\fR)
+.sp
+\fBTcl_SetMainLoop\fR(\fImainLoopProc\fR)
.SH ARGUMENTS
.AS Tcl_AppInitProc *appInitProc
.AP int argc in
.AP Tcl_AppInitProc *appInitProc in
Address of an application-specific initialization procedure.
The value for this argument is usually \fBTcl_AppInit\fR.
+.AP Tcl_MainLoopProc *mainLoopProc in
+Address of an application-specific event loop procedure.
.BE
.SH DESCRIPTION
.PP
-\fBTcl_Main\fR acts as the main program for most Tcl-based applications.
-Starting with Tcl 7.4 it is not called \fBmain\fR anymore because it
-is part of the Tcl library and having a function \fBmain\fR
-in a library (particularly a shared library) causes problems on many
-systems.
+\fBTcl_Main\fR can serve as the main program for Tcl-based shell
+applications. A ``shell application'' is a program
+like tclsh or wish that supports both interactive interpretation
+of Tcl and evaluation of a script contained in a file given as
+a command line argument. \fBTcl_Main\fR is offered as a convenience
+to developers of shell applications, so they do not have to
+reproduce all of the code for proper initialization of the Tcl
+library and interactive shell operation. Other styles of embedding
+Tcl in an application are not supported by \fBTcl_Main\fR. Those
+must be achieved by calling lower level functions in the Tcl library
+directly.
+
+The \fBTcl_Main\fR function has been offered by the Tcl library
+since release Tcl 7.4. In older releases of Tcl, the Tcl library
+itself defined a function \fBmain\fR, but that lacks flexibility
+of embedding style and having a function \fBmain\fR in a library
+(particularly a shared library) causes problems on many systems.
Having \fBmain\fR in the Tcl library would also make it hard to use
Tcl in C++ programs, since C++ programs must have special C++
\fBmain\fR functions.
.PP
-Normally each application contains a small \fBmain\fR function that does
-nothing but invoke \fBTcl_Main\fR.
+Normally each shell application contains a small \fBmain\fR function
+that does nothing but invoke \fBTcl_Main\fR.
\fBTcl_Main\fR then does all the work of creating and running a
\fBtclsh\fR-like application.
.PP
-When it is has finished its own initialization, but before
-it processes commands, \fBTcl_Main\fR calls the procedure given by
-the \fIappInitProc\fR argument. This procedure provides a ``hook''
-for the application to perform its own initialization, such as defining
-application-specific commands. The procedure must have an interface
-that matches the type \fBTcl_AppInitProc\fR:
+\fBTcl_Main\fR is not provided by the public interface of Tcl's
+stub library. Programs that call \fBTcl_Main\fR must be linked
+against the standard Tcl library. Extensions (stub-enabled or
+not) are not intended to call \fBTcl_Main\fR.
+.PP
+\fBTcl_Main\fR is not thread-safe. It should only be called by
+a single master thread of a multi-threaded application. This
+restriction is not a problem with normal use described above.
+.PP
+\fBTcl_Main\fR and therefore all applications based upon it, like
+\fBtclsh\fR, use \fBTcl_GetStdChannel\fR to initialize the standard
+channels to their default values. See \fBTcl_StandardChannels\fR for
+more information.
+.PP
+\fBTcl_Main\fR supports two modes of operation, depending on the
+values of \fIargc\fR and \fIargv\fR. If \fIargv[1]\fR exists and
+does not begin with the character \fI-\fR, it is taken to be the
+name of a file containing a \fIstartup script\fR, which \fBTcl_Main\fR
+will attempt to evaluate. Otherwise, \fBTcl_Main\fR will enter an
+interactive mode.
+.PP
+In either mode, \fBTcl_Main\fR will define in its master interpreter
+the Tcl variables \fIargc\fR, \fIargv\fR, \fIargv0\fR, and
+\fItcl_interactive\fR, as described in the documentation for \fBtclsh\fR.
+.PP
+When it has finished its own initialization, but before it processes
+commands, \fBTcl_Main\fR calls the procedure given by the
+\fIappInitProc\fR argument. This procedure provides a ``hook'' for
+the application to perform its own initialization of the interpreter
+created by \fBTcl_Main\fR, such as defining application-specific
+commands. The procedure must have an interface that matches the
+type \fBTcl_AppInitProc\fR:
.CS
typedef int Tcl_AppInitProc(Tcl_Interp *\fIinterp\fR);
.CE
-\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR;
-for more details on this procedure, see the documentation
-for \fBTcl_AppInit\fR.
+
+\fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more
+details on this procedure, see the documentation for \fBTcl_AppInit\fR.
+.PP
+When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one
+of its two modes. If a startup script has been provided, \fBTcl_Main\fR
+attempts to evaluate it. Otherwise, interactive mode begins with
+examination of the variable \fItcl_rcFileName\fR in the master
+interpreter. If that variable exists and holds the name of a readable
+file, the contents of that file are evaluated in the master interpreter.
+Then interactive operations begin,
+with prompts and command evaluation results written to the standard
+output channel, and commands read from the standard input channel
+and then evaluated. The prompts written to the standard output
+channel may be customized by defining the Tcl variables \fItcl_prompt1\fR
+and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR.
+The prompts and command evaluation results are written to the standard
+output channel only if the Tcl variable \fItcl_interactive\fR in the
+master interpreter holds a non-zero integer value.
+.PP
+.VS 8.4
+\fBTcl_SetMainLoop\fR allows setting an event loop procedure to be run.
+This allows, for example, Tk to be dynamically loaded and set its event
+loop. The event loop will run following the startup script. If you
+are in interactive mode, setting the main loop procedure will cause the
+prompt to become fileevent based and then the loop procedure is called.
+When the loop procedure returns in interactive mode, interactive operation
+will continue.
+The main loop procedure must have an interface that matches the type
+\fBTcl_MainLoopProc\fR:
+.CS
+typedef void Tcl_MainLoopProc(void);
+.CE
+.VE 8.4
+.PP
+\fBTcl_Main\fR does not return. Normally a program based on
+\fBTcl_Main\fR will terminate when the \fBexit\fR command is
+evaluated. In interactive mode, if an EOF or channel error
+is encountered on the standard input channel, then \fBTcl_Main\fR
+itself will evaluate the \fBexit\fR command after the main loop
+procedure (if any) returns. In non-interactive mode, after
+\fBTcl_Main\fR evaluates the startup script, and the main loop
+procedure (if any) returns, \fBTcl_Main\fR will also evaluate
+the \fBexit\fR command.
+
+.SH "SEE ALSO"
+tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3),
+exit(n)
.SH KEYWORDS
application-specific initialization, command-line arguments, main program
.TH Threads 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread \- Tcl thread support.
+Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_CreateThread\fR(\fIidPtr, threadProc, clientData, stackSize, flags\fR)
+.sp
+int
+\fBTcl_JoinThread\fR(\fIid, result\fR)
.SH ARGUMENTS
.AS Tcl_ThreadDataKey *keyPtr
.AP Tcl_Condition *condPtr in
is allocated and initialized to zero the first time each thread
calls \fBTcl_GetThreadData\fR.
.AP Tcl_ThreadId *idPtr out
-The refered storage will contain the id of the newly created thread as
+The referred storage will contain the id of the newly created thread as
returned by the operating system.
.AP Tcl_ThreadId id in
Id of the thread waited upon.
Bitmask containing flags allowing the caller to modify behaviour of
the new thread.
.AP int *result out
-The refered storage is used to place the exit code of the thread
+The referred storage is used to place the exit code of the thread
waited upon into it.
.BE
.SH INTRODUCTION
you must include the \fB--enable-threads\fR option to \fBconfigure\fR
when you configure and compile your Tcl core.
.PP
-An important contstraint of the Tcl threads implementation is that
+An important constraint of the Tcl threads implementation is that
\fIonly the thread that created a Tcl interpreter can use that
interpreter\fR. In other words, multiple threads can not access
the same Tcl interpreter. (However, as was the case in previous
for the new thread. As for the flags, currently are only the values
\fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR defined. The
first of them invokes the default behaviour with no
-specialities. Using the second value marks the new thread as
+specialties. Using the second value marks the new thread as
\fIjoinable\fR. This means that another thread can wait for the such
marked thread to exit and join it.
.PP
handlers. See the \fBTcl_Exit\fR page for more information on these
procedures.
.PP
+.VS
+The \fBTcl_JoinThread\fR function is provided to allow threads to wait
+upon the exit of another thread, which must have been marked as
+joinable through usage of the \fBTCL_THREAD_JOINABLE\fR-flag during
+its creation via \fBTcl_CreateThread\fR.
+.PP
+Trying to wait for the exit of a non-joinable thread or a thread which
+is already waited upon will result in an error. Waiting for a joinable
+thread which already exited is possible, the system will retain the
+necessary information until after the call to \fBTcl_JoinThread\fR.
+This means that not calling \fBTcl_JoinThread\fR for a joinable thread
+will cause a memory leak.
+.VE
+.PP
Tcl provides \fBTcl_ThreadQueueEvent\fR and \fBTcl_ThreadAlert\fR
for handling event queueing in multithreaded applications. See
the \fBNotifier\fR manual page for more information on these procedures.
Tcl_CreateThreadExitHandler, Tcl_DeleteThreadExitHandler
.SH KEYWORDS
thread, mutex, condition variable, thread local storage
-
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variable.
-.AP char *varName in
+.AP "CONST char" *varName in
Name of variable. May refer to a scalar variable, to
an array variable with no index, or to an array variable
with a parenthesized index.
-If the name references an element of an array, then it
-must be in writable memory: Tcl will make temporary modifications
-to it while looking up the name.
.AP int flags in
-OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and
-TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, and TCL_GLOBAL_ONLY.
+OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES,
+TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+TCL_TRACE_RESULT_DYNAMIC and TCL_TRACE_RESULT_OBJECT.
Not all flags are used by all
procedures. See below for more information.
.AP Tcl_VarTraceProc *proc in
Procedure to invoke whenever one of the traced operations occurs.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
-.AP char *name1 in
+.AP "CONST char" *name1 in
Name of scalar or array variable (without array index).
-.AP char *name2 in
+.AP "CONST char" *name2 in
For a trace on an element of an array, gives the index of the
element. For traces on scalar variables or on whole arrays,
is NULL.
procedure call; if this bit is set then the variable will be looked
up at global level, ignoring any active procedures.
.TP
+\fBTCL_NAMESPACE_ONLY\fR
+Normally, the variable will be looked up at the current level of
+procedure call; if this bit is set then the variable will be looked
+up in the current namespace, ignoring any active procedures.
+.TP
\fBTCL_TRACE_READS\fR
Invoke \fIproc\fR whenever an attempt is made to read the variable.
.TP
This gives the trace procedure a chance to update the array before
array names or array get is called. Note that this is called
before an array set, but that will trigger write traces.
+.VS 8.4
+.TP
+\fBTCL_TRACE_RESULT_DYNAMIC\fR
+The result of invoking the \fIproc\fR is a dynamically allocated
+string that will be released by the Tcl library via a call to
+\fBckfree\fR. Must not be specified at the same time as
+TCL_TRACE_RESULT_OBJECT.
+.TP
+\fBTCL_TRACE_RESULT_OBJECT\fR
+The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*)
+with a reference count of at least one. The ownership of that
+reference will be transferred to the Tcl core for release (when the
+core has finished with it) via a call to \fBTcl_DecrRefCount\fR. Must
+not be specified at the same time as TCL_TRACE_RESULT_DYNAMIC.
+.VE 8.4
.PP
Whenever one of the specified operations occurs on the variable,
\fIproc\fR will be invoked.
procedure call: the trace procedure will need to pass this flag
back to variable-related procedures like \fBTcl_GetVar\fR if it
attempts to access the variable.
+The bit TCL_NAMESPACE_ONLY will be set whenever the variable being
+accessed is a namespace one not accessible from the current level of
+procedure call: the trace procedure will need to pass this flag
+back to variable-related procedures like \fBTcl_GetVar\fR if it
+attempts to access the variable.
The bit TCL_TRACE_DESTROYED will be set in \fIflags\fR if the trace is
about to be destroyed; this information may be useful to \fIproc\fR
so that it can clean up its own internal data structures (see
The return value from \fBTcl_VarTraceInfo\fR is the \fIclientData\fR
associated with a particular trace.
The trace must be on the variable specified by the \fIinterp\fR,
-\fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY
-bit from \fIflags\fR is used; other bits are ignored) and its trace procedure
-must the same as the \fIproc\fR argument.
+\fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY and
+TCL_NAMESPACE_ONLY bits from \fIflags\fR is used; other bits are
+ignored) and its trace procedure must the same as the \fIproc\fR
+argument.
If the \fIprevClientData\fR argument is NULL then the return
value corresponds to the first (most recently created) matching
trace, or NULL if there are no matching traces.
If \fIproc\fR returns a non-NULL value it signifies that an
error occurred.
The return value must be a pointer to a static character string
-containing an error message.
+containing an error message,
+.VS 8.4
+unless (\fIexactly\fR one of) the TCL_TRACE_RESULT_DYNAMIC and
+TCL_TRACE_RESULT_OBJECT flags is set, which specify that the result is
+either a dynamic string (to be released with \fBckfree\fR) or a
+Tcl_Obj* (cast to char* and to be released with
+\fBTcl_DecrRefCount\fR) containing the error message.
+.VE 8.4
If a trace procedure returns an error, no further traces are
invoked for the access and the traced access aborts with the
given message.
.SH KEYWORDS
clientData, trace, variable
-
.AS Tcl_DString *bufferPtr
.AP Tcl_Interp *interp in
Interpreter in which to report an error, if any.
-.AP char *name in
+.AP "CONST char" *name in
File name, which may start with a ``~''.
.AP Tcl_DString *bufferPtr in/out
If needed, this dynamic string is used to store the new file name.
.SH KEYWORDS
file name, home directory, tilde, translate, user
-
.AS Tcl_VarTraceProc prevClientData
.AP Tcl_Interp *interp in
Interpreter containing variables; also used for error reporting.
-.AP char *frameName in
+.AP "CONST char" *frameName in
Identifies the stack frame containing source variable.
May have any of the forms accepted by
the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR.
-.AP char *sourceName in
+.AP "CONST char" *sourceName in
Name of source variable, in the frame given by \fIframeName\fR.
May refer to a scalar variable or to an array variable with a
parenthesized index.
-.AP char *destName in
+.AP "CONST char" *destName in
Name of destination variable, which is to be linked to source
variable so that references to \fIdestName\fR
refer to the other variable. Must not currently exist except as
Either TCL_GLOBAL_ONLY or 0; if non-zero, then \fIdestName\fR is
a global variable; otherwise it is a local to the current procedure
(or global if no procedure is active).
-.AP char *name1 in
+.AP "CONST char" *name1 in
First part of source variable's name (scalar name, or name of array
without array index).
-.AP char *name2 in
+.AP "CONST char" *name2 in
If source variable is an element of an array, gives the index of the element.
For scalar source variables, is NULL.
.BE
.SH KEYWORDS
linked variable, upvar, variable
-
.TH Utf 3 "8.1" Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings.
+Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
int
\fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR)
+.VS 8.4
.sp
char *
\fBTcl_UniCharToUtfDString\fR(\fIuniStr, numChars, dstPtr\fR)
.sp
Tcl_UniChar *
\fBTcl_UtfToUniCharDString\fR(\fIsrc, len, dstPtr\fR)
+.VE 8.4
.sp
int
\fBTcl_UniCharLen\fR(\fIuniStr\fR)
.sp
int
\fBTcl_UniCharNcmp\fR(\fIuniStr, uniStr, num\fR)
+.VS 8.4
+.sp
+int
+\fBTcl_UniCharNcasecmp\fR(\fIuniStr, uniStr, num\fR)
+.sp
+int
+\fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR)
+.VE 8.4
.sp
int
\fBTcl_UtfNcmp\fR(\fIsrc, src, num\fR)
.sp
int
\fBTcl_NumUtfChars\fR(\fIsrc, len\fR)
+.VS 8.4
.sp
-char *
+CONST char *
\fBTcl_UtfFindFirst\fR(\fIsrc, ch\fR)
.sp
-char *
+CONST char *
\fBTcl_UtfFindLast\fR(\fIsrc, ch\fR)
.sp
-char *
+CONST char *
\fBTcl_UtfNext\fR(\fIsrc\fR)
.sp
-char *
+CONST char *
\fBTcl_UtfPrev\fR(\fIsrc, start\fR)
+.VE 8.4
.sp
Tcl_UniChar
\fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR)
+.VS 8.4
.sp
-char *
+CONST char *
\fBTcl_UtfAtIndex\fR(\fIsrc, index\fR)
+.VE 8.4
.sp
int
\fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR)
Pointer to a UTF-8 string.
.AP "CONST Tcl_UniChar" *uniStr in
A NULL-terminated Unicode string.
+.AP "CONST Tcl_UniChar" *uniPattern in
+A NULL-terminated Unicode string.
.AP int len in
The length of the UTF-8 string in bytes (not UTF-8 characters). If
negative, all bytes up to the first null byte are used.
.AP char *dst out
Buffer in which the bytes represented by the backslash sequence are stored.
At most TCL_UTF_MAX bytes are stored in the buffer.
+.VS 8.4
+.AP int nocase in
+Specifies whether the match should be done case-sensitive (0) or
+case-insensitive (1).
+.VE 8.4
.BE
.SH DESCRIPTION
Unicode string. Storage for the return value is appended to the
end of the \fBTcl_DString\fR.
.PP
-\fBTcl_UtfToUniCharDString\fR coverts the given UTF-8 string to Unicode,
-storing the result in the previously-initialized \fBTcl_Dstring\fR.
+\fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode,
+storing the result in the previously-initialized \fBTcl_DString\fR.
you may either specify the length of the given UTF-8 string or "-1",
in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to
calculate the length. The return value is a pointer to the Unicode
characters. It accepts a NULL-terminated Unicode string and returns
the number of Unicode characters (not bytes) in that string.
.PP
-\fBTcl_UniCharNcmp\fR corresponds to \fBstrncmp\fR for Unicode
-characters. It accepts two NULL-terminated Unicode strings
-and the number of characters to compare. (Both strings are
-assumed to be at least \fIlen\fR characters long.)
-\fBTcl_UniCharNcmp\fR compares the two strings character-by-character
-according to the Unicode character ordering. It returns an integer
-greater than, equal to,
-or less than 0 if the first string is greater than, equal to, or
-less than the second string respectively.
+\fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to
+\fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters.
+They accepts two NULL-terminated Unicode strings and the number of characters
+to compare. Both strings are assumed to be at least \fIlen\fR characters
+long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character
+according to the Unicode character ordering. It returns an integer greater
+than, equal to, or less than 0 if the first string is greater than, equal
+to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR
+is the Unicode case insensitive version.
+.PP
+.VS 8.4
+\fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to
+\fBTcl_StringCaseMatch\fR. It accepts a NULL-terminated Unicode string,
+a Unicode pattern, and a boolean value specifying whether the match should
+be case sensitive and returns whether the string matches the pattern.
+.VE 8.4
.PP
\fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It
accepts two NULL-terminated UTF-8 strings and the number of characters
length is negative, all bytes up to the first NULL byte are used.
.PP
\fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It
-returns a pointer to the first occurance of the Tcl_UniChar \fIch\fR
+returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR
in the NULL-terminated UTF-8 string \fIsrc\fR. The NULL terminator is
considered part of the UTF-8 string.
.PP
\fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It
-returns a pointer to the last occurance of the Tcl_UniChar \fIch\fR
+returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR
in the NULL terminated UTF-8 string \fIsrc\fR. The NULL terminator is
considered part of the UTF-8 string.
.PP
.SH KEYWORDS
utf, unicode, backslash
-
message.
.AP Tcl_Obj "*CONST\ objv[]" in
Arguments to command that had the wrong number of arguments.
-.AP char *message in
+.AP "CONST char" *message in
Additional error information to print after leading arguments
from \fIobjv\fR. This typically gives the acceptable syntax
of the command. This argument may be NULL.
the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any
\fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand
name in the error message instead of the abbreviated name that was
-origionally passed in. Using the above example, lets assume that
+originally passed in. Using the above example, lets assume that
\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object
-is now an indexObject becasue it was passed to
+is now an indexObject because it was passed to
\fBTcl_GetIndexFromObj\fR. In this case the error message would be:
.CS
wrong # args: should be "foo barfly fileName count"
and \fBupdate\fR commands.
.SH "SEE ALSO"
-bgerror
+bgerror(n), concat(n), update(n), vwait(n)
.SH KEYWORDS
cancel, delay, idle callback, sleep, time
For example, ``\fBappend a $b\fR'' is much more efficient than
``\fBset a $a$b\fR'' if \fB$a\fR is long.
+.SH "SEE ALSO"
+concat(n), lappend(n)
+
.SH KEYWORDS
append, variable
If \fIarrayName\fR isn't the name of an array variable, or if
the array contains no elements, then an empty list is returned.
.TP
-\fBarray names \fIarrayName\fR ?\fIpattern\fR?
+\fBarray names \fIarrayName\fR ?\fImode\fR? ?\fIpattern\fR?
Returns a list containing the names of all of the elements in
-the array that match \fIpattern\fR (using the matching
-rules of \fBstring match\fR).
+the array that match \fIpattern\fR. \fIMode\fR may be one of
+\fB-exact\fR, \fB-glob\fR, or \fB-regexp\fR. If specified, \fImode\fR
+designates which matching rules to use to match \fIpattern\fR against
+the names of the elements in the array. If not specified, \fImode\fR
+defaults to \fB-glob\fR. See the documentation for \fBstring match\fR
+for information on glob style matching, and the documentation for
+\fBregexp\fR for information on regexp matching.
If \fIpattern\fR is omitted then the command returns all of
-the element names in the array.
-If there are no (matching) elements in the array, or if \fIarrayName\fR
-isn't the name of an array variable, then an empty string is
-returned.
+the element names in the array. If there are no (matching) elements
+in the array, or if \fIarrayName\fR isn't the name of an array
+variable, then an empty string is returned.
.TP
\fBarray nextelement \fIarrayName searchId\fR
Returns the name of the next element in \fIarrayName\fR, or
search identifier that must be used in \fBarray nextelement\fR
and \fBarray donesearch\fR commands; it allows multiple
searches to be underway simultaneously for the same array.
+.VS 8.4
+.TP
+\fBarray statistics \fIarrayName\fR
+Returns statistics about the distribution of data within the hashtable
+that represents the array. This information includes the number of
+entries in the table, the number of buckets, and the utilization of
+the buckets.
+.VE 8.4
.VS 8.3
.TP
\fBarray unset \fIarrayName\fR ?\fIpattern\fR?
Unsets all of the elements in the array that match \fIpattern\fR (using the
matching rules of \fBstring match\fR). If \fIarrayName\fR isn't the name
-of an array variable or there are no matching elements in the array, then
-an empty string is returned. If \fIpattern\fR is omitted and is it an
-array variable, then the command unsets the entire array.
+of an array variable or there are no matching elements in the array, no
+error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is
+an array variable, then the command unsets the entire array.
+The command always returns an empty string.
.VE 8.3
+.SH "SEE ALSO"
+list(n), string(n), variable(n), trace(n)
+
.SH KEYWORDS
array, element names, search
For a non-background error, the error can simply be returned up
through nested Tcl command evaluations until it reaches the top-level
code in the application; then the application can report the error
-in whatever way it wishes.
-When a background error occurs, the unwinding ends in
-the Tcl library and there is no obvious way for Tcl to report
-the error.
+in whatever way it wishes. When a background error occurs, the
+unwinding ends in the Tcl library and there is no obvious way for Tcl
+to report the error.
.PP
When Tcl detects a background error, it saves information about the
-error and invokes the \fBbgerror\fR command later as an idle event handler.
-Before invoking \fBbgerror\fR, Tcl restores the \fBerrorInfo\fR
-and \fBerrorCode\fR variables to their values at the time the
-error occurred, then it invokes \fBbgerror\fR with
-the error message as its only argument.
-Tcl assumes that the application has implemented the \fBbgerror\fR
-command, and that the command will report the error in a way that
-makes sense for the application. Tcl will ignore any result returned
-by the \fBbgerror\fR command as long as no error is generated.
+error and invokes the \fBbgerror\fR command later as an idle event
+handler. Before invoking \fBbgerror\fR, Tcl restores the
+\fBerrorInfo\fR and \fBerrorCode\fR variables to their values at the
+time the error occurred, then it invokes \fBbgerror\fR with the error
+message as its only argument. Tcl assumes that the application has
+implemented the \fBbgerror\fR command, and that the command will
+report the error in a way that makes sense for the application. Tcl
+will ignore any result returned by the \fBbgerror\fR command as long
+as no error is generated.
.PP
-If another Tcl error occurs within the \fBbgerror\fR command
-(for example, because no \fBbgerror\fR command has been defined)
-then Tcl reports the error itself by writing a message to stderr.
+If another Tcl error occurs within the \fBbgerror\fR command (for
+example, because no \fBbgerror\fR command has been defined) then Tcl
+reports the error itself by writing a message to stderr.
.PP
-If several background errors accumulate before \fBbgerror\fR
-is invoked to process them, \fBbgerror\fR will be invoked once
-for each error, in the order they occurred.
-However, if \fBbgerror\fR returns with a break exception, then
-any remaining errors are skipped without calling \fBbgerror\fR.
+If several background errors accumulate before \fBbgerror\fR is
+invoked to process them, \fBbgerror\fR will be invoked once for each
+error, in the order they occurred. However, if \fBbgerror\fR returns
+with a break exception, then any remaining errors are skipped without
+calling \fBbgerror\fR.
.PP
-Tcl has no default implementation for \fBbgerror\fR.
-However, in applications using Tk there is a default
-\fBbgerror\fR procedure
-which posts a dialog box containing
-the error message and offers the user a chance to see a stack
-trace showing where the error occurred.
+Tcl has no default implementation for \fBbgerror\fR. However, in
+applications using Tk there is a default \fBbgerror\fR procedure which
+posts a dialog box containing the error message and offers the user a
+chance to see a stack trace showing where the error occurred. In
+addition to allowing the user to view the stack trace, the dialog
+provides an additional application configurable button which may be
+used, for example, to save the stack trace to a file. By default,
+this is the behavior associated with that button. This behavior can
+be redefined by setting the option database values
+\fB*ErrorDialog.function.text\fR, to specify the caption for the
+function button, and \fB*ErrorDialog.function.command\fR, to specify
+the command to be run. The text of the stack trace is appended to the
+command when it is evaluated. If either of these options is set to
+the empty string, then the additional button will not be displayed in
+the dialog.
+
+.SH "SEE ALSO"
+after(n), tclvars(n)
.SH KEYWORDS
background error, reporting
.PP
This command provides facilities for manipulating binary data. The
first form, \fBbinary format\fR, creates a binary string from normal
-Tcl values. For example, given the values 16 and 22, it might produce
-an 8-byte binary string consisting of two 4-byte integers, one for
-each of the numbers. The second form of the command,
-\fBbinary scan\fR, does the opposite: it extracts data from a binary
-string and returns it as ordinary Tcl string values.
+Tcl values. For example, given the values 16 and 22, on a 32 bit
+architecture, it might produce an 8-byte binary string consisting of
+two 4-byte integers, one for each of the numbers. The second form of
+the command, \fBbinary scan\fR, does the opposite: it extracts data
+from a binary string and returns it as ordinary Tcl string values.
.SH "BINARY FORMAT"
.PP
arguments does not match the number of fields in the format string
that consume arguments, then an error is generated.
.PP
+Here is a small example to clarify the relation between the field
+specifiers and the arguments:
+.CS
+\fBbinary format d3d {1.0 2.0 3.0 4.0} 0.1\fR
+.CE
+.PP
+The first argument is a list of four numbers, but because of the count
+of 3 for the associated field specifier, only the first three will be
+used. The second argument is associated with the second field
+specifier. The resulting binary string contains the four numbers 10,
+2.0, 3.0 and 0.1.
+.PP
Each type-count pair moves an imaginary cursor through the binary
data, storing bytes at the current position and advancing the cursor
to just after the last byte stored. The cursor is initially at
will return a string equivalent to
\fB\\x00\\x00\\x00\\x03\\xff\\xff\\xff\\xfd\\x00\\x01\\x00\\x00\fR
.RE
+.IP \fBw\fR 5
+.VS 8.4
+This form is the same as \fBw\fR except that it stores one or more
+64-bit integers in little-endian byte order in the output string. The
+low-order 64-bits of each integer are stored as an eight-byte value at
+the cursor position with the least significant byte stored first. For
+example,
+.RS
+.CS
+\fBbinary format w 7810179016327718216\fR
+.CE
+will return the string \fBHelloTcl\fR
+.RE
+.IP \fBW\fR 5
+This form is the same as \fBw\fR except that it stores one or more one
+or more 64-bit integers in big-endian byte order in the output string.
+For example,
+.RS
+.CS
+\fBbinary format W 4785469626960341345\fR
+.CE
+will return the string \fBBigEndian\fR
+.VE
+.RE
.IP \fBf\fR 5
This form is the same as \fBc\fR except that it stores one or more one
or more single-precision floating in the machine's native
Moves the cursor to the absolute location in the output string
specified by \fIcount\fR. Position 0 refers to the first byte in the
output string. If \fIcount\fR refers to a position beyond the last
-byte stored so far, then null bytes will be placed in the unitialized
+byte stored so far, then null bytes will be placed in the uninitialized
locations and the cursor will be placed at the specified location. If
\fIcount\fR is \fB*\fR, then the cursor is moved to the current end of
the output string. If \fIcount\fR is omitted, then an error will be
not enough arguments for all of the fields in the format string that
consume arguments, then an error is generated.
.PP
+A similar example as with \fBbinary format\fR should explain the
+relation between field specifiers and arguments in case of the binary
+scan subcommand:
+.CS
+\fBbinary scan $bytes s3s first second\fR
+.CE
+.PP
+This command (provided the binary string in the variable \fIbytes\fR
+is long enough) assigns a list of three integers to the variable
+\fIfirst\fR and assigns a single value to the variable \fIsecond\fR.
+If \fIbytes\fR contains fewer than 8 bytes (i.e. four 2-byte
+integers), no assignment to \fIsecond\fR will be made, and if
+\fIbytes\fR contains fewer than 6 bytes (i.e. three 2-byte integers),
+no assignment to \fIfirst\fR will be made. Hence:
+.CS
+\fBputs [binary scan abcdefg s3s first second]\fR
+\fBputs $first\fR
+\fBputs $second\fR
+.CE
+will print (assuming neither variable is set previously):
+.CS
+\fB1\fR
+\fB25185 25699 26213\fR
+\fIcan't read "second": no such variable\fR
+.CE
+.PP
It is \fBimportant\fR to note that the \fBc\fR, \fBs\fR, and \fBS\fR
(and \fBi\fR and \fBI\fR on 64bit systems) will be scanned into
long data size values. In doing this, values that have their high
order. For example,
.RS
.CS
-\fBbinary \\x00\\x00\\x00\\x05\\x00\\x00\\x00\\x07\\xff\\xff\\xff\\xf0 I2I* var1 var2\fR
+\fBbinary scan \\x00\\x00\\x00\\x05\\x00\\x00\\x00\\x07\\xff\\xff\\xff\\xf0 I2I* var1 var2\fR
.CE
will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR.
.RE
+.IP \fBw\fR 5
+.VS 8.4
+The data is interpreted as \fIcount\fR 64-bit signed integers
+represented in little-endian byte order. The integers are stored in
+the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
+all of the remaining bytes in \fBstring\fR will be scanned. If
+\fIcount\fR is omitted, then one 64-bit integer will be scanned. For
+example,
+.RS
+.CS
+\fBbinary scan \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff wi* var1 var2\fR
+.CE
+will return \fB2\fR with \fB30064771077\fR stored in \fBvar1\fR and
+\fB-16\fR stored in \fBvar2\fR. Note that the integers returned are
+signed and cannot be represented by Tcl as unsigned values.
+.RE
+.IP \fBW\fR 5
+This form is the same as \fBw\fR except that the data is interpreted
+as \fIcount\fR 64-bit signed integers represented in big-endian byte
+order. For example,
+.RS
+.CS
+\fBbinary scan \\x00\\x00\\x00\\x05\\x00\\x00\\x00\\x07\\xff\\xff\\xff\\xf0 WI* var1 var2\fR
+.CE
+will return \fB2\fR with \fB21474836487\fR stored in \fBvar1\fR and \fB-16\fR
+stored in \fBvar2\fR.
+.VE
+.RE
.IP \fBf\fR 5
The data is interpreted as \fIcount\fR single-precision floating point
numbers in the machine's native representation. The floating point
to use when formatting or scanning integers.
.SH "SEE ALSO"
-format, scan, tclvars
+format(n), scan(n), tclvars(n)
.SH KEYWORDS
binary, format, scan
-
as the \fBcatch\fR command, Tk event bindings, and the outermost
scripts of procedure bodies.
+.SH "SEE ALSO"
+catch(n), continue(n), for(n), foreach(n), while(n)
+
.SH KEYWORDS
abort, break, loop
the behavior of the second form different than the first form in some
cases.
+.SH "SEE ALSO"
+switch(n)
+
.SH KEYWORDS
case, match, regular expression
}
.CE
+.SH "SEE ALSO"
+error(n), break(n), continue(n)
+
.SH KEYWORDS
catch, error
\fIdirName\fR is not given.
Returns an empty string.
+.SH "SEE ALSO"
+filename(n), glob(n), pwd(n)
+
.SH KEYWORDS
working directory
'\" Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
'\" Copyright (c) 1995-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
+'\" Copyright (c) 2002 ActiveState Corporation
'\"
'\" This documentation is derived from the time and date facilities of
'\" TclX, by Mark Diekhans and Karl Lehenbauer.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH clock n 8.3 Tcl "Tcl Built-In Commands"
+.TH clock n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Abbreviated month name (Jan, Feb, etc.).
.IP \fB%B\fR
Full month name.
+.VS 8.4
.IP \fB%c\fR
-Locale specific date and time.
+Locale specific date and time. The format for date and time
+in the default "C" locale on Unix/Mac is "%a %b %d %H:%M:%S %Y".
+On Windows, this value is the locale specific long date and time, as
+specified in the Regional Options control panel settings.
+.IP \fB%C\fR
+First two digits of the four-digit year (19 or 20).
+.VE 8.4
.IP \fB%d\fR
Day of month (01 - 31).
+.VS 8.4
+'\" Since the inclusion of compat/strftime.c, %D, %e, %h should work on all
+'\" platforms.
+.IP \fB%D\fR
+Date as %m/%d/%y.
+.IP \fB%e\fR
+Day of month (1 - 31), no leading zeros.
+.IP \fB%h\fR
+Abbreviated month name.
+.VE 8.4
.IP \fB%H\fR
Hour in 24-hour format (00 - 23).
+.VS 8.4
.IP \fB%I\fR
-Hour in 12-hour format (00 - 12).
+Hour in 12-hour format (01 - 12).
+.VE 8.4
.IP \fB%j\fR
Day of year (001 - 366).
+.VS 8.4
+.IP \fB%k\fR
+Hour in 24-hour format, without leading zeros (0 - 23).
+.IP \fB%l\fR
+Hour in 12-hour format, without leading zeros (1 - 12).
+.VE 8.4
.IP \fB%m\fR
Month number (01 - 12).
.IP \fB%M\fR
Minute (00 - 59).
+.VS 8.4
+.IP \fB%n\fR
+Insert a newline.
+.VE 8.4
.IP \fB%p\fR
AM/PM indicator.
+.VS 8.4
+.IP \fB%r\fR
+Time in a locale-specific "meridian" format. The "meridian"
+format in the default "C" locale is "%I:%M:%S %p".
+.IP \fB%R\fR
+Time as %H:%M.
+.IP \fB%s\fR
+Count of seconds since the epoch, expressed as a decimal integer.
+.VE 8.4
.IP \fB%S\fR
Seconds (00 - 59).
+.VS 8.4
+.IP \fB%t\fR
+Insert a tab.
+.IP \fB%T\fR
+Time as %H:%M:%S.
+.IP \fB%u\fR
+Weekday number (Monday = 1, Sunday = 7).
+.VE 8.4
.IP \fB%U\fR
Week of year (00 - 52), Sunday is the first day of the week.
+.VS 8.4
+.IP \fB%V\fR
+Week of year according to ISO-8601 rules. Week 1 of a given
+year is the week containing 4 January.
.IP \fB%w\fR
-Weekday number (Sunday = 0).
+Weekday number (Sunday = 0, Saturday = 6).
+.VE 8.4
.IP \fB%W\fR
Week of year (00 - 52), Monday is the first day of the week.
+.VS 8.4
.IP \fB%x\fR
-Locale specific date format.
+Locale specific date format. The format for a date in the default "C"
+locale for Unix/Mac is "%m/%d/%y".
+On Windows, this value is the locale specific short date format, as
+specified in the Regional Options control panel settings.
.IP \fB%X\fR
-Locale specific time format.
+Locale specific 24-hour time format. The format for a
+24-hour time in the default "C" locale for Unix/Mac is "%H:%M:%S".
+On Windows, this value is the locale specific time format, as
+specified in the Regional Options control panel settings.
+.VE 8.4
.IP \fB%y\fR
Year without century (00 - 99).
.IP \fB%Y\fR
.IP \fB%Z\fR
Time zone name.
.RE
+.VS 8.4
.sp
-.RS
-In addition, the following field descriptors may be supported on some
-systems (e.g. Unix but not Windows):
-.IP \fB%D\fR
-Date as %m/%d/%y.
-.IP \fB%e\fR
-Day of month (1 - 31), no leading zeros.
-.IP \fB%h\fR
-Abbreviated month name.
-.IP \fB%n\fR
-Insert a newline.
-.IP \fB%r\fR
-Time as %I:%M:%S %p.
-.IP \fB%R\fR
-Time as %H:%M.
-.IP \fB%t\fR
-Insert a tab.
-.IP \fB%T\fR
-Time as %H:%M:%S.
-.RE
-.sp
+'\" All the field descriptors should be portable now that
+'\" compat/strftime.c is in place, with the possible exception
+'\" of the time zone name.
+'\".RS
+'\"In addition, the following field descriptors may be supported on some
+'\"systems (e.g. Unix but not Windows):
+'\".IP \fB%D\fR
+'\"Date as %m/%d/%y.
+'\".IP \fB%e\fR
+'\"Day of month (1 - 31), no leading zeros.
+'\".IP \fB%h\fR
+'\"Abbreviated month name.
+'\".IP \fB%n\fR
+'\"Insert a newline.
+'\".IP \fB%r\fR
+'\"Time as %I:%M:%S %p.
+'\".IP \fB%R\fR
+'\"Time as %H:%M.
+'\".IP \fB%t\fR
+'\"Insert a tab.
+'\".IP \fB%T\fR
+'\"Time as %H:%M:%S.
+'\".RE
+'\".sp
+.VE 8.4
.RS
If the \fB\-format\fR argument is not specified, the format string
-"\fB%a %b %d %H:%M:%S %Z %Y\fR" is used. If the \fB\-gmt\fR argument
+\fB"%a %b %d %H:%M:%S %Z %Y"\fR is used. If the \fB\-gmt\fR argument
is present the next argument must be a boolean which if true specifies
that the time will be formatted as Greenwich Mean Time. If false
then the local timezone will be used as defined by the operating
calculations. The value is usually defined as total elapsed time from
an ``epoch''. You shouldn't assume the value of the epoch.
+.SH "SEE ALSO"
+date(1), time(n)
+
.SH KEYWORDS
clock, date, time
-
.SH DESCRIPTION
.PP
-Closes the channel given by \fIchannelId\fR. \fIChannelId\fR must be a
-channel identifier such as the return value from a previous \fBopen\fR
-or \fBsocket\fR command.
+Closes the channel given by \fIchannelId\fR.
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as a
+Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
+the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
+the result of a channel creation command provided by a Tcl extension.
+.VE
+.PP
All buffered output is flushed to the channel's output device,
any buffered input is discarded, the underlying file or device is closed,
and \fIchannelId\fR becomes unavailable for use.
The command returns an empty string, and may generate an error if
an error occurs while flushing output.
+.SH "SEE ALSO"
+file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3)
+
.SH KEYWORDS
blocking, channel, close, nonblocking
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH concat n "" Tcl "Tcl Built-In Commands"
+.TH concat n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
.SH DESCRIPTION
.PP
-This command treats each argument as a list and concatenates them
+This command joins each of its arguments together with spaces after
+trimming leading and trailing spaces from each of them. If all the
+arguments are lists, this has the same effect as concatenating them
into a single list.
-It also eliminates leading and trailing spaces in the \fIarg\fR's
-and adds a single separator space between \fIarg\fR's.
-It permits any number of arguments. For example,
-the command
+It permits any number of arguments. For example, the command
.CS
\fBconcat a b {c d e} {f {g h}}\fR
.CE
.CS
\fBa b c d e f {g h}\fR
.CE
+as its result, and
+.CS
+\fBconcat " a b {c " d " e} f"\fR
+.CE
+will return
+.CS
+\fBa b {c d e} f\fR
+.CE
as its result.
.PP
If no \fIarg\fRs are supplied, the result is an empty string.
+.SH "SEE ALSO"
+append(n), eval(n)
+
.SH KEYWORDS
concatenate, join, lists
as the \fBcatch\fR command and the outermost scripts of procedure
bodies.
+.SH "SEE ALSO"
+break(n), for(n), foreach(n), while(n)
+
.SH KEYWORDS
continue, iteration, loop
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH dde n 8.1 Tcl "Tcl Built-In Commands"
+.TH dde n 1.2 dde "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
dde \- Execute a Dynamic Data Exchange command
.SH SYNOPSIS
.sp
-\fBpackage require dde 1.1\fR
+\fBpackage require dde 1.2\fR
.sp
-\fBdde \fIservername \fR?\fItopic\fR?
+\fBdde \fIservername\fR ?\fItopic\fR?
.sp
-\fBdde ?\-async?\fR \fIcommand service topic \fR?\fIdata\fR?
+\fBdde \fIexecute\fR ?\fI\-async\fR? \fIservice topic \fR?\fIdata\fR?
+.sp
+\fBdde \fIpoke\fR \fIservice topic item data\fR
+.sp
+\fBdde \fIrequest\fR ?\fI\-binary\fR? \fIservice topic \fR?\fIdata\fR?
+.sp
+\fBdde \fIservices\fR \fIservice topic \fR?\fIdata\fR?
+.sp
+\fBdde \fIeval\fR ?\fI\-async\fR? \fIservice topic \fR?\fIdata\fR?
.BE
.SH DESCRIPTION
own \fIservice names\fR and \fItopics\fR. For instance, Microsoft Excel
has the service name \fBExcel\fR.
.PP
-The only option to the \fBdde\fR command is:
+The \fBeval\fR and \fBexecute\fR commands accept the option \fB\-async\fR:
.TP
-\fB\-async\fR
-Requests asynchronous invocation. This is valid only for the
-\fBexecute\fR subcommand. Normally, the \fBdde execute\fR subcommand
-waits until the command completes, returning appropriate error
-messages. When the \fB\-async\fR option is used, the command returns
-immediately, and no error information is available.
+
.SH "DDE COMMANDS"
.PP
The following commands are a subset of the full Dynamic Data Exchange
If no \fItopic\fR is given, \fBdde servername\fR returns the name
of the current topic or the empty string if it is not registered as a service.
.TP
-\fBdde execute \fIservice topic data\fR
-\fBdde execute\fR takes the \fIdata\fR and sends it to the server
-indicated by \fIservice\fR with the topic indicated by
-\fItopic\fR. Typically, \fIservice\fR is the name of an application,
-and \fItopic\fR is a file to work on. The \fIdata\fR field is given
-to the remote application. Typically, the application treats the
-\fIdata\fR field as a script, and the script is run in the
-application. The command returns an error if the script did not
-run. If the \fB\-async\fR flag was used, the command
-returns immediately with no error.
+\fBdde execute\fR ?\fI\-async\fR? \fIservice topic data\fR
+\fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated
+by \fIservice\fR with the topic indicated by \fItopic\fR. Typically,
+\fIservice\fR is the name of an application, and \fItopic\fR is a file to
+work on. The \fIdata\fR field is given to the remote application.
+Typically, the application treats the \fIdata\fR field as a script, and the
+script is run in the application. The \fI\-async\fR option requests
+asynchronous invocation. The command returns an error message if the
+script did not run, unless the \fB\-async\fR flag was used, in which case
+the command returns immediately with no error.
.TP
\fBdde poke \fIservice topic item data\fR
\fBdde poke\fR passes the \fIdata\fR to the server indicated by
it must always be non-null. The \fIdata\fR field is given to the remote
application.
.TP
-\fBdde request \fIservice topic item\fR
+\fBdde request\fR ?\fI\-binary\fR? \fIservice topic item\fR
\fBdde request\fR is typically used to get the value of something; the
value of a cell in Microsoft Excel or the text of a selection in
Microsoft Word. \fIservice\fR is typically the name of an application,
\fItopic\fR is typically the name of the file, and \fIitem\fR is
application-specific. The command returns the value of \fIitem\fR as
-defined in the application.
+defined in the application. Normally this is interpreted to be a
+string with terminating null. If \fI\-binary\fR is specified, the
+result is returned as a byte array.
.TP
\fBdde services \fIservice topic\fR
\fBdde services\fR returns a list of service-topic pairs that
service-topic pair currently exists, it is returned; otherwise, null
is returned.
.TP
-\fBdde eval \fItopic cmd \fR?\fIarg arg ...\fR?
-\fBdde eval\fR evaluates a command and its arguments using the
-interpreter specified by \fItopic\fR. The DDE service must be the
-\fBTclEval\fR service. This command can be used to replace send on
-Windows.
+\fBdde eval\fR ?\fI\-async\fR? \fItopic cmd \fR?\fIarg arg ...\fR?
+\fBdde eval\fR evaluates a command and its arguments using the interpreter
+specified by \fItopic\fR. The DDE service must be the \fBTclEval\fR
+service. The \fI\-async\fR option requests asynchronous invocation. The
+command returns an error message if the script did not run, unless the
+\fB\-async\fR flag was used, in which case the command returns immediately
+with no error. This command can be used to replace send on Windows.
+
.SH "DDE AND TCL"
A Tcl interpreter always has a service name of \fBTclEval\fR. Each
different interpreter of all running Tcl applications must be
If for any reason the event queue is not flushed, DDE commands may
hang until the event queue is flushed. This can create a deadlock
situation.
+
.SH "SEE ALSO"
-tk, winfo, send
+tk(n), winfo(n), send(n)
+
.SH KEYWORDS
application, dde, name, remote execution
-
letter HA.
.SH "SEE ALSO"
-Tcl_GetEncoding
+Tcl_GetEncoding(3)
.SH KEYWORDS
encoding
Returns 1 if an end of file condition occurred during the most
recent input operation on \fIchannelId\fR (such as \fBgets\fR),
0 otherwise.
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as a
+Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
+the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
+the result of a channel creation command provided by a Tcl extension.
+.VE
+
+.SH "SEE ALSO"
+file(n), open(n), close(n), fblocked(n), Tcl_StandardChannels(3)
.SH KEYWORDS
channel, end of file
``NONE'' by the Tcl interpreter as part of processing the
error generated by the command.
+.SH "SEE ALSO"
+catch(n), tclvars(n)
+
.SH KEYWORDS
error, errorCode, errorInfo
fashion as the \fBconcat\fR command, passes the concatenated string to the
Tcl interpreter recursively, and returns the result of that
evaluation (or any error generated by it).
+Note that the \fBlist\fR command quotes sequences of words in such a
+way that they are not further expanded by the \fBeval\fR command.
.SH KEYWORDS
concatenate, evaluate, script
+
+.SH "SEE ALSO"
+catch(n), concat(n), error(n), list(n), subst(n), tclvars(n)
.sp
Additionally, when calling a 16-bit DOS or Windows 3.X application, all path
names must use the short, cryptic, path format (e.g., using ``applba~1.def''
-instead of ``applbakery.default'').
+instead of ``applbakery.default''), which can be obtained with the
+\fBfile attributes $fileName -shortname\fR command.
.sp
Two or more forward or backward slashes in a row in a path refer to a
network path. For example, a simple concatenation of the root directory
\fBc:/\fR is ignored), and is not equivalent to \fBc:/windows/system\fR,
which describes a directory on the current computer. The \fBfile join\fR
command should be used to concatenate path components.
+.sp
+.RS
+Note that there are two general types of Win32 console applications:
+.RS
+1) CLI -- CommandLine Interface, simple stdio exchange. \fBnetstat.exe\fR for
+example.
+.br
+2) TUI -- Textmode User Interface, any application that accesses the console
+API for doing such things as cursor movement, setting text color, detecting
+key presses and mouse movement, etc... An example would be \fBtelnet.exe\fR
+from Windows 2000. These types of applications are not common in a windows
+environment, but do exist.
+.RE
+\fBexec\fR will not work well with TUI applications when a console is not
+present, as is done when launching applications under wish. It is desirable
+to have console applications hidden and detached. This is a designed-in
+limitation as \fBexec\fR wants to communicate over pipes. The Expect
+extension addresses this issue when communication between a TUI application
+is desired.
+.sp
+.RE
.TP
\fBWindows NT\fR
.
-When attempting to execute an application, \fBexec\fR first searches for the
-name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and \fB.bat\fR
-are appended to the end of the specified name and it searches for
-the longer name. If a directory name was not specified as part of the
+When attempting to execute an application, \fBexec\fR first searches for
+the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and
+\fB.bat\fR are appended to the end of the specified name and it searches
+for the longer name. If a directory name was not specified as part of the
application name, the following directories are automatically searched in
order when attempting to locate the application:
.sp
.RE
.sp
In order to execute the shell builtin commands like \fBdir\fR and \fBcopy\fR,
-the caller must prepend ``\fBcmd.exe /c\0\fR'' to the desired command.
+the caller must prepend ``\fBcmd.exe /c\0\fR'' to the desired command.
.sp
.RE
.TP
\fBWindows 95\fR
.
-When attempting to execute an application, \fBexec\fR first searches for the
-name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and \fB.bat\fR
-are appended to the end of the specified name and it searches for
-the longer name. If a directory name was not specified as part of the
+When attempting to execute an application, \fBexec\fR first searches for
+the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and
+\fB.bat\fR are appended to the end of the specified name and it searches
+for the longer name. If a directory name was not specified as part of the
application name, the following directories are automatically searched in
order when attempting to locate the application:
.sp
The \fBexec\fR command is fully functional and works as described.
.SH "SEE ALSO"
-open(n)
-.VE
+error(n), open(n)
.SH KEYWORDS
execute, pipeline, redirection, subprocess
-
If \fIreturnCode\fR isn't specified then it defaults
to 0.
+.SH "SEE ALSO"
+exec(n), tclvars(n)
+
.SH KEYWORDS
exit, process
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH expr n 8.3 Tcl "Tcl Built-In Commands"
+.TH expr n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
as a string (and only a limited set of operators may be applied to
it).
.PP
+.VS 8.4
+On 32-bit systems, integer values MAX_INT (0x7FFFFFFF) and MIN_INT
+(-0x80000000) will be represented as 32-bit values, and integer values
+outside that range will be represented as 64-bit values (if that is
+possible at all.)
+.VE 8.4
+.PP
Operands may be specified in any of the following ways:
.IP [1]
As an numeric value, either integer or floating-point.
\fB==\0\0!=\fR
Boolean equal and not equal. Each operator produces a zero/one result.
Valid for all operand types.
+.VS 8.4
+.TP 20
+\fBeq\0\0ne\fR
+Boolean string equal and string not equal. Each operator produces a
+zero/one result. The operand types are interpreted only as strings.
+.VE 8.4
.TP 20
\fB&\fR
Bit-wise AND. Valid for integer operands only.
integer or floating-point, and the result is returned in the same form.
.TP
\fBacos(\fIarg\fB)\fR
-Returns the arc cosine of \fIarg\fR, in the range [0,pi]
-radians. \fIArg\fR should be in the range [-1,1].
+Returns the arc cosine of \fIarg\fR, in the range [\fI0\fR,\fIpi\fR]
+radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBasin(\fIarg\fB)\fR
-Returns the arc sine of \fIarg\fR, in the range [-pi/2,pi/2] radians.
-\fIArg\fR should be in the range [-1,1].
+Returns the arc sine of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
+radians. \fIArg\fR should be in the range [\fI-1\fR,\fI1\fR].
.TP
\fBatan(\fIarg\fB)\fR
-Returns the arc tangent of \fIarg\fR, in the range [-pi/2,pi/2] radians.
+Returns the arc tangent of \fIarg\fR, in the range [\fI-pi/2\fR,\fIpi/2\fR]
+radians.
.TP
-\fBatan2(\fIx, y\fB)\fR
-Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [-pi,pi]
-radians. \fIx\fR and \fIy\fR cannot both be 0.
+\fBatan2(\fIy, x\fB)\fR
+Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR]
+radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater
+than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR.
.TP
\fBceil(\fIarg\fB)\fR
-Returns the smallest integer value not less than \fIarg\fR.
+Returns the smallest integral floating point value (i.e. with a zero
+fractional part) not less than \fIarg\fR.
.TP
\fBcos(\fIarg\fB)\fR
Returns the cosine of \fIarg\fR, measured in radians.
\fIarg\fR to floating and returns the converted value.
.TP
\fBexp(\fIarg\fB)\fR
-Returns the exponential of \fIarg\fR, defined as e**\fIarg\fR. If the
-result would cause an overflow, an error is returned.
+Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR.
+If the result would cause an overflow, an error is returned.
.TP
\fBfloor(\fIarg\fB)\fR
-Returns the largest integral value not greater than \fIarg\fR.
+Returns the largest integral floating point value (i.e. with a zero
+fractional part) not greater than \fIarg\fR.
.TP
\fBfmod(\fIx, y\fB)\fR
Returns the floating-point remainder of the division of \fIx\fR by
.TP
\fBhypot(\fIx, y\fB)\fR
Computes the length of the hypotenuse of a right-angled triangle
-(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fR).
+\fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR.
.TP
\fBint(\fIarg\fB)\fR
-If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts
-\fIarg\fR to integer by truncation and returns the converted value.
+.VS 8.4
+If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise
+converts \fIarg\fR to an integer (of the same size as a machine word,
+i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by
+truncation and returns the converted value.
+.VE 8.4
.TP
\fBlog(\fIarg\fB)\fR
Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a
is negative, \fIy\fR must be an integer value.
.TP
\fBrand()\fR
-Returns a floating point number from zero to just less than one or,
-in mathematical terms, the range [0,1). The seed comes from the
-internal clock of the machine or may be set manual with the srand
-function.
+Returns a floating point number from zero to just less than one or, in
+mathematical terms, the range [\fI0\fR,\fI1\fR). The seed comes from
+the internal clock of the machine or may be set manual with the
+\fBsrand\fR function.
.TP
\fBround(\fIarg\fB)\fR
If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts
\fBsrand(\fIarg\fB)\fR
The \fIarg\fR, which must be an integer, is used to reset the seed for
the random number generator. Returns the first random number from
-that seed. Each interpreter has it's own seed.
+that seed. Each interpreter has its own seed.
.TP
\fBtan(\fIarg\fB)\fR
Returns the tangent of \fIarg\fR, measured in radians.
.TP
\fBtanh(\fIarg\fB)\fR
Returns the hyperbolic tangent of \fIarg\fR.
+.TP
+\fBwide(\fIarg\fB)\fR
+.VS 8.4
+Converts \fIarg\fR to a value at least 64-bits wide (by sign-extension
+if \fIarg\fR is a 32-bit number.)
+.VE 8.4
.PP
In addition to these predefined functions, applications may
define additional functions using \fBTcl_CreateMathFunc\fR().
.PP
String values may be used as operands of the comparison operators,
although the expression evaluator tries to do comparisons as integer
-or floating-point when it can.
+or floating-point when it can,
+.VS 8.4
+except in the case of the \fBeq\fR and \fBne\fR operators.
+.VE 8.4
If one of the operands of a comparison is a string and the other
has a numeric value, the numeric operand is converted back to
a string using the C \fIsprintf\fR format specifier
possible, it isn't generally a good idea to use operators like \fB==\fR
when you really want string comparison and the values of the
operands could be arbitrary; it's better in these cases to use
+.VS 8.4
+the \fBeq\fR or \fBne\fR operators, or
+.VE 8.4
the \fBstring\fR command instead.
.SH "PERFORMANCE CONSIDERATIONS"
These expressions must be implemented by generating new code
each time the expression is executed.
+.SH "SEE ALSO"
+array(n), string(n), Tcl(n)
+
.SH KEYWORDS
arithmetic, boolean, compare, expression, fuzzy comparison
-
returns an empty string and a subsequent call to \fBfblocked\fR will
return 1.
.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as a
+Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
+the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
+the result of a channel creation command provided by a Tcl extension.
+.VE
+
.SH "SEE ALSO"
-gets(n), read(n)
+gets(n), open(n), read(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, nonblocking
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH fconfigure n 8.1 Tcl "Tcl Built-In Commands"
+.TH fconfigure n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
\fBfconfigure \fIchannelId\fR \fIname value \fR?\fIname value ...\fR?
.fi
.BE
-
.SH DESCRIPTION
.PP
The \fBfconfigure\fR command sets and retrieves options for channels.
-\fIChannelId\fR identifies the channel for which to set or query an option.
+.PP
+\fIChannelId\fR identifies the channel for which to set or query an
+option and must refer to an open channel such as a Tcl standard
+channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return
+value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
+of a channel creation command provided by a Tcl extension.
+.PP
If no \fIname\fR or \fIvalue\fR arguments are supplied, the command
returns a list containing alternating option names and values for the channel.
If \fIname\fR is supplied but no \fIvalue\fR then the command returns
\fB\-buffering\fR to be set to \fBfull\fR except for channels that
connect to terminal-like devices; for these channels the initial setting
is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are
-intially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR.
+initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR.
.TP
\fB\-buffersize\fR \fInewSize\fR
.
buffers, in bytes, subsequently allocated for this channel to store input
or output. \fINewvalue\fR must be between ten and one million, allowing
buffers of ten to one million bytes in size.
-.VS 8.1 br
.TP
\fB\-encoding\fR \fIname\fR
.
locale-dependent system encoding used for interfacing with the operating
system.
.RE
-.VE
.TP
\fB\-eofchar\fR \fIchar\fR
.TP
Macintosh platform it chooses \fBcr\fR and for the various flavors of
Windows it chooses \fBcrlf\fR. The default setting for
\fB\-translation\fR is \fBauto\fR for both input and output.
-.VS 8.1 br
.TP
\fBbinary\fR
.
end-of-file character to the empty string (which disables it) and sets the
encoding to \fBbinary\fR (which disables encoding filtering). See the
description of \fB\-eofchar\fR and \fB\-encoding\fR for more information.
-.VE
.TP
\fBcr\fR
.
.RE
.PP
+.SH "STANDARD CHANNELS"
+.PP
+The Tcl standard channels (\fBstdin\fR, \fBstdout\fR, and \fBstderr\fR)
+can be configured through this command like every other channel opened
+by the Tcl library. Beyond the standard options described above they
+will also support any special option according to their current type.
+If, for example, a Tcl application is started by the \fBinet\fR
+super-server common on Unix system its Tcl standard channels will be
+sockets and thus support the socket options.
+
+.VS 8.4
+.SH "SERIAL PORT CONFIGURATION OPTIONS"
+.PP
+If \fIchannelId\fR refers to a serial port, then the following
+additional configuration options are available on Windows and
+Unix systems with a POSIX serial interface:
+
+.TP
+\fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR
+.
+This option is a set of 4 comma-separated values: the baud rate, parity,
+number of data bits, and number of stop bits for this serial port. The
+\fIbaud\fR rate is a simple integer that specifies the connection speed.
+\fIParity\fR is one of the following letters: \fBn\fR, \fBo\fR, \fBe\fR,
+\fBm\fR, \fBs\fR; respectively signifying the parity options of ``none'',
+``odd'', ``even'', ``mark'', or ``space''. \fIData\fR is the number of
+data bits and should be an integer from 5 to 8, while \fIstop\fR is the
+number of stop bits and should be the integer 1 or 2.
+
+.TP
+\fB\-handshake\fR \fItype\fR
+.
+(Windows and Unix). This option is used to setup automatic handshake
+control. Note that not all handshake types maybe supported by your operating
+system. The \fItype\fR parameter is case-independent.
+
+If \fItype\fR is \fBnone\fR then any handshake is switched off.
+\fBrtscts\fR activates hardware handshake. Hardware handshake signals
+are described below.
+For software handshake \fBxonxoff\fR the handshake characters can be redefined
+with \fB-xchar\fR.
+An additional hardware handshake \fBdtrdsr\fR is available only under Windows.
+There is no default handshake configuration, the initial value depends
+on your operating system settings.
+The \fB-handshake\fR option cannot be queried.
+
+.TP
+\fB\-queue\fR
+.
+(Windows and Unix). The \fB-queue\fR option can only be queried.
+It returns a list of two integers representing the current number
+of bytes in the input and output queue respectively.
+
+.TP
+\fB\-timeout\fR \fImsec\fR
+.
+(Windows and Unix). This option is used to set the timeout for blocking
+read operations. It specifies the maximum interval between the
+reception of two bytes in milliseconds.
+For Unix systems the granularity is 100 milliseconds.
+The \fB-timeout\fR option does not affect write operations or
+nonblocking reads.
+This option cannot be queried.
+
+.TP
+\fB\-ttycontrol\fR \fI{signal boolean signal boolean ...}\fR
+.
+(Windows and Unix). This option is used to setup the handshake
+output lines (see below) permanently or to send a BREAK over the serial line.
+The \fIsignal\fR names are case-independent.
+\fB{RTS 1 DTR 0}\fR sets the RTS output to high and the DTR output to low.
+The BREAK condition (see below) is enabled and disabled with \fB{BREAK 1}\fR and
+\fB{BREAK 0}\fR respectively.
+It's not a good idea to change the \fBRTS\fR (or \fBDTR\fR) signal
+with active hardware handshake \fBrtscts\fR (or \fBdtrdsr\fR).
+The result is unpredictable.
+The \fB-ttycontrol\fR option cannot be queried.
+
+.TP
+\fB\-ttystatus\fR
+.
+(Windows and Unix). The \fB-ttystatus\fR option can only be
+queried. It returns the current modem status and handshake input signals
+(see below).
+The result is a list of signal,value pairs with a fixed order,
+e.g. \fB{CTS 1 DSR 0 RING 1 DCD 0}\fR.
+The \fIsignal\fR names are returned upper case.
+
+.TP
+\fB\-xchar\fR \fI{xonChar xoffChar}\fR
+.
+(Windows and Unix). This option is used to query or change the software
+handshake characters. Normally the operating system default should be
+DC1 (0x11) and DC3 (0x13) representing the ASCII standard
+XON and XOFF characters.
+
+.TP
+\fB\-pollinterval\fR \fImsec\fR
+.
+(Windows only). This option is used to set the maximum time between
+polling for fileevents.
+This affects the time interval between checking for events throughout the Tcl
+interpreter (the smallest value always wins). Use this option only if
+you want to poll the serial port more or less often than 10 msec
+(the default).
+
+.TP
+\fB\-sysbuffer\fR \fIinSize\fR
+.TP
+\fB\-sysbuffer\fR \fI{inSize outSize}\fR
+.
+(Windows only). This option is used to change the size of Windows
+system buffers for a serial channel. Especially at higher communication
+rates the default input buffer size of 4096 bytes can overrun
+for latent systems. The first form specifies the input buffer size,
+in the second form both input and output buffers are defined.
+
+.TP
+\fB\-lasterror\fR
+.
+(Windows only). This option is query only.
+In case of a serial communication error, \fBread\fR or \fBputs\fR
+returns a general Tcl file I/O error.
+\fBfconfigure -lasterror\fR can be called to get a list of error details.
+See below for an explanation of the various error codes.
+
+.SH "SERIAL PORT SIGNALS"
+.PP
+RS-232 is the most commonly used standard electrical interface for serial
+communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and
+a positive voltage (+3..+12V) define a space (off=0) bit (RS-232C). The
+following signals are specified for incoming and outgoing data, status
+lines and handshaking. Here we are using the terms \fIworkstation\fR for
+your computer and \fImodem\fR for the external device, because some signal
+names (DCD, RI) come from modems. Of course your external device may use
+these signal lines for other purposes.
+.RS
+.IP \fBTXD(output)\fR
+\fBTransmitted Data:\fR Outgoing serial data.
+.IP \fBRXD(input)\fR
+\fBReceived Data:\fRIncoming serial data.
+.IP \fBRTS(output)\fR
+\fBRequest To Send:\fR This hardware handshake line informs the modem that
+your workstation is ready to receive data. Your workstation may
+automatically reset this signal to indicate that the input buffer is full.
+.IP \fBCTS(input)\fR
+\fBClear To Send:\fR The complement to RTS. Indicates that the modem is
+ready to receive data.
+.IP \fBDTR(output)\fR
+\fBData Terminal Ready:\fR This signal tells the modem that the workstation
+is ready to establish a link. DTR is often enabled automatically whenever a
+serial port is opened.
+.IP \fBDSR(input)\fR
+\fBData Set Ready:\fR The complement to DTR. Tells the workstation that the
+modem is ready to establish a link.
+.IP \fBDCD(input)\fR
+\fBData Carrier Detect:\fR This line becomes active when a modem detects
+a "Carrier" signal.
+.IP \fBRI(input)\fR
+\fBRing Indicator:\fR Goes active when the modem detects an incoming call.
+.IP \fBBREAK\fR
+A BREAK condition is not a hardware signal line, but a logical zero on the
+TXD or RXD lines for a long period of time, usually 250 to 500
+milliseconds. Normally a receive or transmit data signal stays at the mark
+(on=1) voltage until the next character is transferred. A BREAK is sometimes
+used to reset the communications line or change the operating mode of
+communications hardware.
+.RE
+
+.SH "ERROR CODES (Windows only)"
+.PP
+A lot of different errors may occur during serial read operations or during
+event polling in background. The external device may have been switched
+off, the data lines may be noisy, system buffers may overrun or your mode
+settings may be wrong. That's why a reliable software should always
+\fBcatch\fR serial read operations. In cases of an error Tcl returns a
+general file I/O error. Then \fBfconfigure -lasterror\fR may help to
+locate the problem. The following error codes may be returned.
+.RS
+.IP \fBRXOVER:\fR
+Windows input buffer overrun. The data comes faster than your scripts reads
+it or your system is overloaded. Use \fBfconfigure -sysbuffer\fR to avoid a
+temporary bottleneck and/or make your script faster.
+.IP \fBTXFULL\fR
+Windows output buffer overrun. Complement to RXOVER. This error should
+practically not happen, because Tcl cares about the output buffer status.
+.IP \fBOVERRUN\fR
+UART buffer overrun (hardware) with data lost.
+The data comes faster than the system driver receives it.
+Check your advanced serial port settings to enable the FIFO (16550) buffer
+and/or setup a lower(1) interrupt threshold value.
+.IP \fBRXPARITY\fR
+A parity error has been detected by your UART.
+Wrong parity settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
+may cause this error.
+.IP \fBFRAME\fR
+A stop-bit error has been detected by your UART.
+Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
+may cause this error.
+.IP \fBBREAK\fR
+A BREAK condition has been detected by your UART (see above).
+.RE
+.VE
+
.SH "SEE ALSO"
-close(n), flush(n), gets(n), puts(n), read(n), socket(n)
+close(n), flush(n), gets(n), puts(n), read(n), socket(n),
+Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, buffering, carriage return, end of line, flushing, linemode,
Only the number of bytes written to \fIoutchan\fR is reported,
either as the return value of a synchronous \fBfcopy\fP or
as the argument to the callback for an asynchronous \fBfcopy\fP.
+.PP
+\fBFcopy\fR obeys the encodings configured for the channels. This
+means that the incoming characters are converted internally first
+UTF-8 and then into the encoding of the channel \fBfcopy\fR writes
+to. See the manual entry for \fBfconfigure\fR for details on the
+\fB\-encoding\fR option. No conversion is done if both channels are
+set to encoding "binary". If only the output channel is set to
+encoding "binary" the system will write the internal UTF-8
+representation of the incoming characters. If only the input channel
+is set to encoding "binary" the system will assume that the incoming
+bytes are valid UTF-8 characters and convert them according to the
+output encoding. The behaviour of the system for bytes which are not
+valid UTF-8 characters is undefined in this case.
.SH EXAMPLE
.PP
generated. On Windows, FAT file systems do not support access time.
.TP
\fBfile attributes \fIname\fR
-.br
+.TP
\fBfile attributes \fIname\fR ?\fBoption\fR?
-.br
+.TP
\fBfile attributes \fIname\fR ?\fBoption value option value...\fR?
.RS
This subcommand returns or sets platform specific values associated
.VE
.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
-.br
+.TP
\fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form makes a copy of the file or directory \fIsource\fR under
-the pathname \fItarget\fR. If \fItarget\fR is an existing directory,
+the pathname \fItarget\fR. If \fItarget\fR is an existing directory,
then the second form is used. The second form makes a copy inside
\fItargetDir\fR of each \fIsource\fR file listed. If a directory is
specified as a \fIsource\fR, then the contents of the directory will be
-recursively copied into \fItargetDir\fR. Existing files will not be
-overwritten unless the \fB\-force\fR option is specified. Trying to
-overwrite a non-empty directory, overwrite a directory with a file, or a
-file with a directory will all result in errors even if \fI\-force\fR was
-specified. Arguments are processed in the order specified, halting at the
-first error, if any. A \fB\-\|\-\fR marks the end of switches; the argument
-following the \fB\-\|\-\fR will be treated as a \fIsource\fR even if it
-starts with a \fB\-\fR.
+recursively copied into \fItargetDir\fR. Existing files will not be
+overwritten unless the \fB\-force\fR option is specified. When copying
+within a single filesystem, \fIfile copy\fR will copy soft links (i.e.
+the links themselves are copied, not the things they point to). Trying
+to overwrite a non-empty directory, overwrite a directory with a file,
+or a file with a directory will all result in errors even if
+\fI\-force\fR was specified. Arguments are processed in the order
+specified, halting at the first error, if any. A \fB\-\|\-\fR marks
+the end of switches; the argument following the \fB\-\|\-\fR will be
+treated as a \fIsource\fR even if it starts with a \fB\-\fR.
.RE
.TP
\fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIpathname\fR ?\fIpathname\fR ... ?
.
-Removes the file or directory specified by each \fIpathname\fR argument.
-Non-empty directories will be removed only if the \fB\-force\fR option is
-specified. Trying to delete a non-existant file is not considered an
-error. Trying to delete a read-only file will cause the file to be deleted,
-even if the \fB\-force\fR flags is not specified. Arguments are processed
-in the order specified, halting at the first error, if any. A \fB\-\|\-\fR
-marks the end of switches; the argument following the \fB\-\|\-\fR will be
-treated as a \fIpathname\fR even if it starts with a \fB\-\fR.
+Removes the file or directory specified by each \fIpathname\fR
+argument. Non-empty directories will be removed only if the
+\fB\-force\fR option is specified. When operating on symbolic links,
+the links themselves will be deleted, not the objects they point to.
+Trying to delete a non-existent file is not considered an error.
+Trying to delete a read-only file will cause the file to be deleted,
+even if the \fB\-force\fR flags is not specified. If the \fB\-force\fR
+option is specified on a directory, Tcl will attempt both to change
+permissions and move the current directory 'pwd' out of the given path
+if that is necessary to allow the deletion to proceed. Arguments are
+processed in the order specified, halting at the first error, if any.
+A \fB\-\|\-\fR marks the end of switches; the argument following the
+\fB\-\|\-\fR will be treated as a \fIpathname\fR even if it starts with
+a \fB\-\fR.
.TP
\fBfile dirname \fIname\fR
Returns a name comprised of all of the path components in \fIname\fR
Windows, and \fB:\fR for Macintosh.
.RE
.TP
+\fBfile link ?\fI-linktype\fR? \fIlinkName\fR ?\fItarget\fR?
+.
+If only one argument is given, that argument is assumed to be
+\fIlinkName\fR, and this command returns the value of the link given by
+\fIlinkName\fR (i.e. the name of the file it points to). If
+\fIlinkName\fR isn't a link or its value cannot be read (as, for example,
+seems to be the case with hard links, which look just like ordinary
+files), then an error is returned.
+.
+If 2 arguments are given, then these are assumed to be \fIlinkName\fR and
+\fItarget\fR. If \fIlinkName\fR already exists, or if \fItarget\fR
+doesn't exist, an error will be returned. Otherwise, Tcl creates a new
+link called \fIlinkName\fR which points to the existing filesystem object
+at \fItarget\fR, where the type of the link is platform-specific (on Unix
+a symbolic link will be the default). This is useful for the case where
+the user wishes to create a link in a cross-platform way, and doesn't
+care what type of link is created.
+.
+If the user wishes to make a link of a specific type only, (and signal an
+error if for some reason that is not possible), then the optional
+\fI-linktype\fR argument should be given. Accepted values for
+\fI-linktype\fR are "-symbolic" and "-hard".
+.
+When creating links on filesystems that either do not support any links,
+or do not support the specific type requested, an error message will be
+returned. In particular Windows 95, 98 and ME do not support any links
+at present, but most Unix platforms support both symbolic and hard links
+(the latter for files only), MacOS supports symbolic links and Windows
+NT/2000/XP (on NTFS drives) support symbolic directory links and hard
+file links.
+.TP
\fBfile lstat \fIname varName\fR
.
Same as \fBstat\fR option (see below) except uses the \fIlstat\fR
filename is needed to pass to a platform-specific call, such as exec
under Windows or AppleScript on the Macintosh.
.TP
+\fBfile normalize \fIname\fR
+.
+.RS
+Returns a unique normalised path representation for the file-system
+object (file, directory, link, etc), whose string value can be used as a
+unique identifier for it. A normalized path is an absolute path which has
+all '../', './' removed. Also it is one which is in the ``standard''
+format for the native platform. On MacOS, Unix, this means the segments
+leading up to the path must be free of symbolic links/aliases (but the
+very last path component may be a symbolic link), and on Windows it also
+means means we want the long form with that form's case-dependence (which
+gives us a unique, case-dependent path). The one exception concerning the
+last link in the path is necessary, because Tcl or the user may wish to
+operate on the actual symbolic link itself (for example 'file delete', 'file
+rename', 'file copy' are defined to operate on symbolic links, not on the
+things that they point to).
+.RE
+.TP
\fBfile owned \fIname\fR
.
Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR
of the file it points to). If \fIname\fR isn't a symbolic link or its
value cannot be read, then an error is returned. On systems that don't
support symbolic links this option is undefined.
-.PP
+.TP
\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR
-.br
+.TP
\fBfile rename \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR
.RS
The first form takes the file or directory specified by pathname
\fIsource\fR and renames it to \fItarget\fR, moving the file if the
pathname \fItarget\fR specifies a name in a different directory. If
-\fItarget\fR is an existing directory, then the second form is used. The
-second form moves each \fIsource\fR file or directory into the directory
-\fItargetDir\fR. Existing files will not be overwritten unless the
-\fB\-force\fR option is specified. Trying to overwrite a non-empty
-directory, overwrite a directory with a file, or a file with a directory
-will all result in errors. Arguments are processed in the order specified,
+\fItarget\fR is an existing directory, then the second form is used.
+The second form moves each \fIsource\fR file or directory into the
+directory \fItargetDir\fR. Existing files will not be overwritten
+unless the \fB\-force\fR option is specified. When operating inside a
+single filesystem, Tcl will rename symbolic links rather than the
+things that they point to. Trying to overwrite a non-empty directory,
+overwrite a directory with a file, or a file with a directory will all
+result in errors. Arguments are processed in the order specified,
halting at the first error, if any. A \fB\-\|\-\fR marks the end of
switches; the argument following the \fB\-\|\-\fR will be treated as a
\fIsource\fR even if it starts with a \fB\-\fR.
last ``.'' character in the last component of name. If the last
component of \fIname\fR doesn't contain a dot, then returns \fIname\fR.
.TP
+\fBfile separator\fR ?\fIname\fR?
+.
+If no argument is given, returns the character which is used to separate
+path segments for native files on this platform. If a path is given,
+the filesystem responsible for that path is asked to return its
+separator character. If no file system accepts \fIname\fR, an error
+is generated.
+.TP
\fBfile size \fIname\fR
.
Returns a decimal string giving the size of file \fIname\fR in bytes. If
For example, under Unix
.RS
.CS
-\fBfile split /foo/~bar/baz\fR
+file split /foo/~bar/baz
.CE
returns \fB/\0\0foo\0\0./~bar\0\0baz\fR to ensure that later commands
that use the third component do not attempt to perform tilde
form returned by the command \fBfile type\fR. This command returns an
empty string.
.TP
+\fBfile system \fIname\fR
+.
+Returns a list of two elements, the first of which is the name of the
+filesystem to use for the file, and the second an arbitrary string
+representing the filesystem-specific nature or type of the location
+within that filesystem. If a filesystem only supports one type of file,
+the second element may be null. For example the native files have a
+first element 'native', and a second element which is a platform-specific
+type name for the file's system (e.g. 'NTFS', 'FAT', etc), or possibly
+the empty string if no further information is available or if this
+is not implemented. A generic virtual file system might return the
+list 'vfs ftp' to represent a file on a remote ftp site mounted as a
+virtual filesystem through an extension called 'vfs'. If the file does
+not belong to any filesystem, an error is generated.
+.TP
\fBfile tail \fIname\fR
.
Returns all of the characters in \fIname\fR after the last directory
not the effective ones.
.SH "SEE ALSO"
-filename
+filename(n), open(n), close(n), eof(n), gets(n), tell(n), seek(n),
+fblocked(n), flush(n)
.SH KEYWORDS
attributes, copy files, delete files, directory, file, move files, name, rename files, stat
tell when data is present and only invoke \fBgets\fR or \fBread\fR when
they won't block.
.PP
-The \fIchannelId\fR argument to \fBfileevent\fR refers to an open channel,
-such as the return value from a previous \fBopen\fR or \fBsocket\fR
-command.
+.VS
+The \fIchannelId\fR argument to \fBfileevent\fR refers to an open
+channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR,
+or \fBstderr\fR), the return value from an invocation of \fBopen\fR
+or \fBsocket\fR, or the result of a channel creation command provided
+by a Tcl extension.
+.VE
+.PP
If the \fIscript\fR argument is specified, then \fBfileevent\fR
creates a new event handler: \fIscript\fR will be evaluated
whenever the channel becomes readable or writable (depending on the
an error; this is done in order to prevent infinite loops due to
buggy handlers.
+.SH EXAMPLE
+.PP
+.CS
+ proc GetData {chan} {
+ if {![eof $chan]} {
+ puts [gets $chan]
+ }
+ }
+
+ fileevent $chan readable [list GetData $chan]
+
+.CE
+In this setup \fBGetData\fR will be called with the channel as an
+argument whenever $chan becomes readable.
+
.SH CREDITS
.PP
\fBfileevent\fR is based on the \fBaddinput\fR command created
by Mark Diekhans.
.SH "SEE ALSO"
-bgerror, fconfigure, gets, puts, read
+bgerror(n), fconfigure(n), gets(n), puts(n), read(n), Tcl_StandardChannels(3)
.SH KEYWORDS
asynchronous I/O, blocking, channel, event handler, nonblocking, readable,
style names. Both \fB/\fR and \fB\e\fR may be used as directory separators
in either type of name. Drive-relative names consist of an optional drive
specifier followed by an absolute or relative path. UNC paths follow the
-general form \fB\e\eservername\esharename\epath\efile\fR. In both forms,
+general form \fB\e\eservername\esharename\epath\efile\fR, but must at
+the very least contain the server and share components, i.e.
+\fB\e\eservername\esharename\fR. In both forms,
the file names \fB.\fR and \fB..\fR are special and refer to the current
directory and the parent of the current directory respectively. The
following examples illustrate various forms of path names:
.TP 15
\fB\&\e\eHost\eshare/file\fR
Absolute UNC path to a file called \fBfile\fR in the root directory of
-the export point \fBshare\fR on the host \fBHost\fR.
+the export point \fBshare\fR on the host \fBHost\fR. Note that
+repeated use of \fBfile dirname\fR on this path will give
+\fB//Host/share\fR, and will never give just /fB//Host/fR.
.TP 15
\fBc:foo\fR
Volume-relative path to a file \fBfoo\fR in the current directory on drive
\fB\&\efoo\fR
Volume-relative path to a file \fBfoo\fR in the root directory of the current
volume.
+.TP 15
+\fB\&\e\efoo\fR
+Volume-relative path to a file \fBfoo\fR in the root directory of the current
+volume. This is not a valid UNC path, so the assumption is that the
+extra backslashes are superfluous.
.RE
.SH "TILDE SUBSTITUTION"
.PP
The Macintosh and Windows platforms do not support tilde substitution
when a user name follows the tilde. On these platforms, attempts to
-use a tilde followed by a user name will generate an error. File
-names that have a tilde without a user name will be substituted using
-the \fB$HOME\fR environment variable, just like for Unix.
+use a tilde followed by a user name will generate an error that the
+user does not exist when Tcl attempts to interpret that part of the
+path or otherwise access the file. The behaviour of these paths
+when not trying to interpret them is the same as on Unix. File
+names that have a tilde without a user name will be correctly
+substituted using the \fB$HOME\fR environment variable, just like
+for Unix.
.SH "PORTABILITY ISSUES"
.PP
alphanumeric characters only. Also Windows 3.1 only supports file
names with a root of no more than 8 characters and an extension of no
more than 3 characters.
+.PP
+On Windows platforms there are file and path length restrictions.
+Complete paths or filenames longer than about 260 characters will lead
+to errors in most file operations.
.SH KEYWORDS
current directory, absolute file name, relative file name,
volume-relative file name, portability
+
+.SH "SEE ALSO"
+file(n), glob(n)
.SH DESCRIPTION
.PP
Flushes any output that has been buffered for \fIchannelId\fR.
-\fIChannelId\fR must be a channel identifier such as returned by a previous
-\fBopen\fR or \fBsocket\fR command, and it must have been opened for writing.
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as a
+Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
+value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
+of a channel creation command provided by a Tcl extension. The
+channel must have been opened for writing.
+.VE
+.PP
If the channel is in blocking mode the command does not return until all the
buffered output has been flushed to the channel. If the channel is in
nonblocking mode, the command may return before all buffered output has been
underlying file or device is able to absorb it.
.SH "SEE ALSO"
-open(n), socket(n)
+file(n), open(n), socket(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, buffer, channel, flush, nonblocking, output
}
.CE
+.SH "SEE ALSO"
+break, continue, foreach, while
+
.SH KEYWORDS
for, iteration, looping
# The value of x is "a d e b f g c {} {}"
# There are 3 iterations of the loop.
.DE
+
+.SH "SEE ALSO"
+for(n), while(n), break(n), continue(n)
+
.SH KEYWORDS
foreach, iteration, list, looping
If it is \fBh\fR it specifies that the numeric value should be
truncated to a 16-bit value before converting.
This option is rarely useful.
-The \fBl\fR modifier is ignored.
+.VS 8.4
+If it is \fBl\fR it specifies that the numeric value should be (at
+least) a 64-bit value. If neither \fBh\fR or \fBl\fR are present,
+numeric values are interpreted as being values of the width of the
+native machine word, as described by \fBtcl_platform(wordSize)\fR.
+.VE
.PP
The last thing in a conversion specifier is an alphabetic character
that determines what kind of conversion to perform.
For \fB%c\fR conversions the argument must be a decimal string,
which will then be converted to the corresponding character value.
.IP [3]
-The \fBl\fR modifier is ignored; integer values are always converted
-as if there were no modifier present and real values are always
-converted as if the \fBl\fR modifier were present (i.e. type
-\fBdouble\fR is used for the internal representation).
+The \fBl\fR modifier
+.VS 8.4
+is ignored for real values and on 64-bit platforms, which are always
+converted as if the \fBl\fR modifier were present (i.e. the types
+\fBdouble\fR and \fBlong\fR are used for the internal representation
+of real and integer values, respectively).
+.VE 8.4
If the \fBh\fR modifier is specified then integer values are truncated
-to \fBshort\fR before conversion.
+to \fBshort\fR before conversion. Both \fBh\fR and \fBl\fR modifiers
+are ignored on all other conversions.
+
+.SH "SEE ALSO"
+sprintf(3), string(n)
.SH KEYWORDS
conversion specifier, format, sprintf, string, substitution
This command reads the next line from \fIchannelId\fR, returns everything
in the line up to (but not including) the end-of-line character(s), and
discards the end-of-line character(s).
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as the
+Tcl standard input channel (\fBstdin\fR), the return value from an
+invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
+creation command provided by a Tcl extension. The channel must have
+been opened for input.
+.VE
+.PP
If \fIvarName\fR is omitted the line is returned as the result of the
command.
If \fIvarName\fR is specified then the line is placed in the variable by
these three cases.
.SH "SEE ALSO"
-eof(n), fblocked(n)
+file(n), eof(n), fblocked(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, end of file, end of line, line, nonblocking, read
\fIdirectory\fR. This allows searching of directories whose name
contains glob-sensitive characters without the need to quote such
characters explicitly. This option may not be used in conjunction with
-\fB\-path\fR.
+\fB\-path\fR, which is used to allow searching for complete file paths
+whose names may contain glob-sensitive characters.
.TP
\fB\-join\fR
The remaining pattern arguments are treated as a single pattern
\fB\-path\fR \fIpathPrefix\fR
Search for files with the given \fIpathPrefix\fR where the rest of the name
matches the given patterns. This allows searching for files with names
-similar to a given file even when the names contain glob-sensitive
+similar to a given file (as opposed to a directory) even when the names
+contain glob-sensitive
characters. This option may not be used in conjunction with
-\fB\-directory\fR.
+\fB\-directory\fR. For example, to find all files with the same root name
+as $path, but differing extensions, you should use \fBglob
+-path [file rootname $path] .*\fR which will work even if $path contains
+numerous glob-sensitive characters.
+.TP
+\fB\-tails\fR
+Only return the part of each file found which follows the last directory
+named in any \fB\-directory\fR or \fB\-path\fR path specification.
+Thus \fBglob -tails -directory $dir *\fR is equivalent to
+\fBset pwd [pwd] ; cd $dir ; glob *; cd $pwd\fR. For
+\fB\-path\fR specifications, the returned names will include the last
+path segment, so \fBglob -tails -path [file rootname ~/foo.tex] .*\fR
+will return paths like \fBfoo.aux foo.bib foo.tex\fR etc.
.TP
\fB\-types\fR \fItypeList\fR
Only list files or directories which match \fItypeList\fR, where the items
which is four characters long is assumed to be a MacOS type
(e.g. \fBTEXT\fR). Items which are of the form \fI{macintosh type XXXX}\fR
or \fI{macintosh creator XXXX}\fR will match types or creators
-respectively. Unrecognised types, or specifications of multiple MacOS
+respectively. Unrecognized types, or specifications of multiple MacOS
types/creators will signal an error.
.PP
The two forms may be mixed, so \fB\-types {d f r w}\fR will find all
\fB{\fIa\fB,\fIb\fB,\fI...\fR}
Matches any of the strings \fIa\fR, \fIb\fR, etc.
.LP
-As with csh, a ``.'' at the beginning of a file's name or just
-after a ``/'' must be matched explicitly or with a {} construct.
+On Unix, as with csh, a ``.'' at the beginning of a file's name or just
+after a ``/'' must be matched explicitly or with a {} construct,
+unless the ``-types hidden'' flag is given (since ``.'' at the beginning
+of a file's name indicates that it is hidden). On other platforms,
+files beginning with a ``.'' are handled no differently to any others,
+except the special directories ``.'' and ``..'' which must be matched
+explicitly (this is to avoid a recursive pattern like ``glob -join * *
+* *'' from recursing up the directory hierarchy as well as down).
In addition, all ``/'' characters must be matched explicitly.
.LP
If the first character in a \fIpattern\fR is ``~'' then it refers
domain server. Otherwise, user account information is obtained from
the local computer. On Windows 95 and 98, \fBglob\fR accepts patterns
like ``.../'' and ``..../'' for successively higher up parent directories.
+
+.
+Since the backslash character has a special meaning to the glob
+command, glob patterns containing Windows style path separators need
+special care. The pattern \fIC:\e\efoo\e\e*\fR is interpreted as
+\fIC:\efoo\e*\fR where \fI\ef\fR will match the single character \fIf\fR
+and \fI\e*\fR will match the single character \fI*\fR and will not be
+interpreted as a wildcard character. One solution to this problem is
+to use the Unix style forward slash as a path separator. Windows style
+paths can be converted to Unix style paths with the command \fBfile
+join $path\fR (or \fBfile normalize $path\fR in Tcl 8.4).
.TP
\fBMacintosh\fR
.
-When using the options, \fB\-dir\fR, \fB\-join\fR or \fB\-path\fR, glob
+When using the options, \fB\-directory\fR, \fB\-join\fR or \fB\-path\fR, glob
assumes the directory separator for the entire pattern is the standard
``:''. When not using these options, glob examines each pattern argument
and uses ``/'' unless the pattern contains a ``:''.
+.SH "SEE ALSO"
+file(n)
.SH KEYWORDS
exist, file, glob, pattern
(and only while executing in the current procedure),
any reference to any of the \fIvarname\fRs
will refer to the global variable by the same name.
+.PP
.SH "SEE ALSO"
-namespace(n), variable(n)
+namespace(n), upvar(n), variable(n)
.SH KEYWORDS
global, namespace, procedure, variable
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH "Http" n 8.3 Tcl "Tcl Built-In Commands"
+.TH "http" n 2.4 http "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Http \- Client-side implementation of the HTTP/1.0 protocol.
+http \- Client-side implementation of the HTTP/1.0 protocol.
.SH SYNOPSIS
-\fBpackage require http ?2.3?\fP
+\fBpackage require http ?2.4?\fR
.sp
\fB::http::config \fI?options?\fR
.sp
of HTTP/1.0. It allows configuration of a proxy host to get through
firewalls. The package is compatible with the \fBSafesock\fR security
policy, so it can be used by untrusted applets to do URL fetching from
-a restricted set of hosts. This package can be extened to support
+a restricted set of hosts. This package can be extended to support
additional HTTP transport protocols, such as HTTPS, by providing
a custom \fBsocket\fR command, via \fBhttp::register\fR.
.PP
.TP
\fB\-useragent\fP \fIstring\fP
The value of the User-Agent header in the HTTP request. The default
-is \fB"Tcl http client package 2.2."\fR
+is \fB"Tcl http client package 2.4."\fR
.RE
.TP
\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP?
-The \fB::http::geturl \fR command is the main procedure in the package.
+The \fB::http::geturl\fR command is the main procedure in the package.
The \fB\-query\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
otherwise, a GET operation is performed. The \fB::http::geturl\fR command
\fB::http::geturl\fR takes several options:
.RS
.TP
+\fB\-binary\fP \fIboolean\fP
+Specifies whether to force interpreting the url data as binary. Normally
+this is auto-detected (anything not beginning with a \fBtext\fR content
+type or whose content encoding is \fBgzip\fR or \fBcompress\fR is
+considered binary data).
+.TP
\fB\-blocksize\fP \fIsize\fP
The blocksize used when reading the URL.
-At most
-\fIsize\fR
-bytes are read at once. After each block, a call to the
-\fB\-progress\fR
-callback is made (if that option is specified).
+At most \fIsize\fR bytes are read at once. After each block, a call to the
+\fB\-progress\fR callback is made (if that option is specified).
.TP
\fB\-channel\fP \fIname\fP
Copy the URL contents to channel \fIname\fR instead of saving it in
after writing the HTTP headers, \fB::http::geturl\fP returns, and the
rest of the HTTP transaction occurs in the background. The command
callback can check if any error occurred during the read by calling
-\fB::http::status\fP to check the status and if it's \fIerror\fP,
+\fB::http::status\fP to check the status and if its \fIerror\fP,
calling \fB::http::error\fP to get the error message.
.PP
Alternatively, if the main program flow reaches a point where it needs
The contents of the URL. This will be empty if the \fB\-channel\fR
option has been specified. This value is returned by the \fB::http::data\fP command.
.TP
+\fBcharset\fR
+The value of the charset attribute from the \fBContent-Type\fR meta-data
+value. If none was specified, this defaults to the RFC standard
+\fBiso8859-1\fR, or the value of \fB$::http::defaultCharset\fR. Incoming
+text data will be automatically converted from this charset to utf-8.
+.TP
+\fBcoding\fR
+A copy of the \fBContent-Encoding\fR meta-data value.
+.TP
\fBcurrentsize\fR
The current number of bytes fetched from the URL.
This value is returned by the \fB::http::size\fP command.
proc ::http::Progress {args} {
puts -nonewline stderr . ; flush stderr
}
-
.DE
+
.SH "SEE ALSO"
safe(n), socket(n), safesock(n)
+
.SH KEYWORDS
security policy, socket
-
-
-
that was executed, or an empty string
if none of the expressions was non-zero and there was no \fIbodyN\fR.
+.SH "SEE ALSO"
+expr(n), for(n), foreach(n)
+
.SH KEYWORDS
boolean, conditional, else, false, if, true
The new value is stored as a decimal string in variable \fIvarName\fR
and also returned as result.
+.SH "SEE ALSO"
+expr(n)
+
.SH KEYWORDS
add, increment, variable, value
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
+'\" Copyright (c) 1998-2000 Ajuba Solutions
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH info n 7.5 Tcl "Tcl Built-In Commands"
+.TH info n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Returns \fB1\fR if the variable named \fIvarName\fR exists in the
current context (either as a global or local variable) and has been
defined by being given a value, returns \fB0\fR otherwise.
+.VS 8.4
+.TP
+\fBinfo functions \fR?\fIpattern\fR?
+If \fIpattern\fR isn't specified, returns a list of all the math
+functions currently defined.
+If \fIpattern\fR is specified, only those functions whose name matches
+\fIpattern\fR are returned. Matching is determined using the same
+rules as for \fBstring match\fR.
+.VE
.TP
\fBinfo globals \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified, returns a list of all the names
\fBinfo hostname\fR
Returns the name of the computer on which this invocation is being
executed.
+.VS
+Note that this name is not guaranteed to be the fully qualified domain
+name of the host. Where machines have several different names (as is
+common on systems with both TCP/IP (DNS) and NetBIOS-based networking
+installed,) it is the name that is suitable for TCP/IP networking that
+is returned.
+.VE
.TP
\fBinfo level\fR ?\fInumber\fR?
If \fInumber\fR is not specified, this command returns a number
If \fIpattern\fR isn't specified, returns a list of all the names
of currently-defined local variables, including arguments to the
current procedure, if any.
-Variables defined with the \fBglobal\fR and \fBupvar\fR commands
-will not be returned.
+Variables defined with the \fBglobal\fR, \fBupvar\fR and
+\fBvariable\fR commands will not be returned.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned. Matching is determined using the same rules as for
\fBstring match\fR.
Matching is determined using the same rules as for
\fBstring match\fR.
.TP
-\fBinfo script\fR
+\fBinfo script\fR ?\fIfilename\fR?
If a Tcl script file is currently being evaluated (i.e. there is a
call to \fBTcl_EvalFile\fR active or there is an active invocation
of the \fBsource\fR command), then this command returns the name
-of the innermost file being processed. Otherwise the command returns an
-empty string.
+of the innermost file being processed. If \fIfilename\fR is specified,
+then the return value of this command will be modified for the
+duration of the active invocation to return that name. This is
+useful in virtual file system applications.
+Otherwise the command returns an empty string.
.TP
\fBinfo sharedlibextension\fR
Returns the extension used on this platform for the names of files
has each matching namespace variable qualified with the name
of its namespace.
+.SH "SEE ALSO"
+global(n), proc(n)
+
.SH KEYWORDS
command, information, interpreter, level, namespace, procedure, variable
+
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
new interpreter. The name of a slave interpreter must be unique among all
the slaves for its master; an error occurs if a slave interpreter by the
given name already exists in this master.
+The initial recursion limit of the slave interpreter is set to the
+current recursion limit of its parent interpreter.
.TP
\fBinterp\fR \fBdelete \fR?\fIpath ...?\fR
Deletes zero or more interpreters given by the optional \fIpath\fR
accepted only if it is a valid global name space name without any ::),
in the interpreter
denoted by \fIpath\fR.
-If an exposed command with the targetted name already exists, this command
+If an exposed command with the targeted name already exists, this command
fails.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.TP
it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if
\fIhiddenCmdName\fR is not given, in the interpreter denoted
by \fIpath\fR.
-If a hidden command with the targetted name already exists, this command
+If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
not contain namespace qualifiers, or an error is raised.
already trusted.
.VE
.TP
+\fBinterp\fR \fBrecursionlimit\fR \fIpath\fR ?\fInewlimit\fR?
+Returns the maximum allowable nesting depth for the interpreter
+specified by \fIpath\fR. If \fInewlimit\fR is specified,
+the interpreter recursion limit will be set so that nesting
+of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
+and related procedures in that interpreter will return an error.
+The \fInewlimit\fR value is also returned.
+The \fInewlimit\fR value must be a positive integer between 1 and the
+maximum value of a non-long integer on the platform.
+.sp
+The command sets the maximum size of the Tcl call stack only. It cannot
+by itself prevent stack overflows on the C stack being used by the
+application. If your machine has a limit on the size of the C stack, you
+may get stack overflows before reaching the limit set by the command. If
+this happens, see if there is a mechanism in your system for increasing
+the maximum size of the C stack.
+.TP
\fBinterp\fR \fBshare\fR \fIsrcPath channelId destPath\fR
Causes the IO channel identified by \fIchannelId\fR to become shared
between the interpreter identified by \fIsrcPath\fR and the interpreter
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in \fIslave\fR.
-If an exposed command with the targetted name already exists, this command
+If an exposed command with the targeted name already exists, this command
fails.
For more details on hidden commands, see HIDDEN COMMANDS, below.
.TP
This command hides the exposed command \fIexposedCmdName\fR, renaming it to
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
the argument is not given, in the \fIslave\fR interpreter.
-If a hidden command with the targetted name already exists, this command
+If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
not contain namespace qualifiers, or an error is raised.
commands in the slave interpreter. The command has no effect if the slave
is already trusted.
.VE
-
+.TP
+\fIslave\fR \fBrecursionlimit\fR ?\fInewlimit\fR?
+Returns the maximum allowable nesting depth for the \fIslave\fR interpreter.
+If \fInewlimit\fR is specified, the recursion limit in \fIslave\fR will be
+set so that nesting of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
+and related procedures in \fIslave\fR will return an error.
+The \fInewlimit\fR value is also returned.
+The \fInewlimit\fR value must be a positive integer between 1 and the
+maximum value of a non-long integer on the platform.
+.sp
+The command sets the maximum size of the Tcl call stack only. It cannot
+by itself prevent stack overflows on the C stack being used by the
+application. If your machine has a limit on the size of the C stack, you
+may get stack overflows before reaching the limit set by the command. If
+this happens, see if there is a mechanism in your system for increasing
+the maximum size of the C stack.
.SH "SAFE INTERPRETERS"
.PP
A safe interpreter is one with restricted functionality, so that
error eval expr fblocked
fcopy fileevent flush for
foreach format gets global
-history if incr info
-interp join lappend lindex
-linsert list llength lrange
-lreplace lsearch lsort namespace
-package pid proc puts
-read regexp regsub rename
-return scan seek set
-split string subst switch
-tell trace unset update
+if incr info interp
+join lappend lindex linsert
+list llength lrange lreplace
+lsearch lsort namespace package
+pid proc puts read
+regexp regsub rename return
+scan seek set split
+string subst switch tell
+time trace unset update
uplevel upvar variable vwait
while\fR
.DE
creates a safe interpreter:
.DS
.ta 1.2i 2.4i 3.6i
-\fBcd exec exit fconfigure
-file glob load open
-pwd socket source vwait\fR
+\fBcd encoding exec exit
+fconfigure file glob load
+open pwd socket source\fR
.DE
These commands can be recreated later as Tcl procedures or aliases, or
re-exposed by \fBinterp expose\fR.
+.PP
+The following commands from Tcl's library of support procedures are
+not present in a safe interpreter:
+.DS
+.ta 1.6i 3.2i
+\fBauto_exec_ok auto_import auto_load
+auto_load_index auto_qualify unknown\fR
+.DE
+Note in particular that safe interpreters have no default \fBunknown\fR
+command, so Tcl's default autoloading facilities are not available.
+Autoload access to Tcl's commands that are normally autoloaded:
+.DS
+.ta 2.1i
+\fB
+auto_mkindex auto_mkindex_old
+auto_reset history
+parray pkg_mkIndex
+::pkg::create ::safe::interpAddToAccessPath
+::safe::interpCreate ::safe::interpConfigure
+::safe::interpDelete ::safe::interpFindInAccessPath
+::safe::interpInit ::safe::setLogCmd
+tcl_endOfWord tcl_findLibrary
+tcl_startOfNextWord tcl_startOfPreviousWord
+tcl_wordBreakAfter tcl_wordBreakBefore\fR
+.DE
+can only be provided by explicit definition of an \fBunknown\fR command
+in the safe interpreter. This will involve exposing the \fBsource\fR
+command. This is most easily accomplished by creating the safe interpreter
+with Tcl's \fBSafe\-Tcl\fR mechanism. \fBSafe\-Tcl\fR provides safe
+versions of \fBsource\fR, \fBload\fR, and other Tcl commands needed
+to support autoloading of commands and the loading of packages.
.VE
.PP
In addition, the \fBenv\fR variable is not present in a safe interpreter,
their own functionality to eliminate unsafe commands. For a discussion of
management of extensions for safety see the manual entries for
\fBSafe\-Tcl\fR and the \fBload\fR Tcl command.
+.PP
+A safe interpreter may not alter the recursion limit of any interpreter,
+including itself.
.SH "ALIAS INVOCATION"
.PP
expose\fR command moves a hidden command to the
set of exposed commands in the interpreter identified by \fIpath\fR,
potentially renaming the command in the process. If an exposed command by
-the targetted name already exists, the operation fails. Similarly,
+the targeted name already exists, the operation fails. Similarly,
\fBinterp hide\fR moves an exposed command to the set of hidden commands in
that interpreter. Safe interpreters are not allowed to move commands
between the set of hidden and exposed commands, in either themselves or
\fIjoinString\fR separating each adjacent pair of elements.
The \fIjoinString\fR argument defaults to a space character.
+.SH "SEE ALSO"
+list(n), lappend(n)
+
.SH KEYWORDS
element, join, list, separator
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
more efficient than ``\fBset a [concat $a [list $b]]\fR'' when
\fB$a\fR is long.
+.SH "SEE ALSO"
+list(n), lindex(n), linsert(n), llength(n),
+.VS 8.4
+lset(n)
+.VE
+lsort(n), lrange(n)
+
.SH KEYWORDS
append, element, list, variable
autoloaded library. If so, the commands are loaded so that they will
be available to the interpreter for creating the import links. If the
commands do not reside in an autoloaded library, \fBauto_import\fR
-does nothing.
+does nothing. The pattern matching is performed according to the
+matching rules of \fBnamespace import\fR.
.TP
\fBauto_load \fIcmd\fR
This command attempts to load the definition for a Tcl command named
The variable is unset before \fBunknown\fR returns.
.SH "SEE ALSO"
-re_syntax(n)
+info(n), re_syntax(n)
.SH KEYWORDS
auto-exec, auto-load, library, unknown, word, whitespace
-
This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation and other parties. The following terms apply to all files
+associated with the software unless explicitly disclaimed in
+individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH lindex n 8.2 Tcl "Tcl Built-In Commands"
+.TH lindex n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lindex \- Retrieve an element from a list
.SH SYNOPSIS
-\fBlindex \fIlist index\fR
+\fBlindex \fIlist ?index...?\fR
.BE
-
.SH DESCRIPTION
.PP
-This command treats \fIlist\fR as a Tcl list and returns the
+.VS 8.4
+The \fBlindex\fP command accepts a parameter, \fIlist\fP, which
+it treats as a Tcl list. It also accepts zero or more \fIindices\fP into
+the list. The indices may be presented either consecutively on the
+command line, or grouped in a
+Tcl list and presented as a single argument.
+.PP
+If no indices are presented, the command takes the form:
+.CS
+lindex list
+.CE
+or
+.CS
+lindex list {}
+.CE
+In this case, the return value of \fBlindex\fR is simply the value of the
+\fIlist\fR parameter.
+.PP
+When presented with a single index, the \fBlindex\fR command
+treats \fIlist\fR as a Tcl list and returns the
+.VE
\fIindex\fR'th element from it (0 refers to the first element of the list).
-In extracting the element, \fIlindex\fR observes the same rules
+In extracting the element, \fBlindex\fR observes the same rules
concerning braces and quotes and backslashes as the Tcl command
interpreter; however, variable
substitution and command substitution do not occur.
If \fIindex\fR has the value \fBend\fR, it refers to the last element
in the list, and \fBend\-\fIinteger\fR refers to the last element in
the list minus the specified integer offset.
-
+.PP
+.VS 8.4
+If additional \fIindex\fR arguments are supplied, then each argument is
+used in turn to select an element from the previous indexing operation,
+allowing the script to select elements from sublists. The command,
+.CS
+lindex $a 1 2 3
+.CE
+or
+.CS
+lindex $a {1 2 3}
+.CE
+is synonymous with
+.CS
+lindex [lindex [lindex $a 1] 2] 3
+.CE
+.SH EXAMPLES
+.CS
+lindex {a b c} => a b c
+lindex {a b c} {} => a b c
+lindex {a b c} 0 => a
+lindex {a b c} 2 => c
+lindex {a b c} end => c
+lindex {a b c} end-1 => b
+lindex {{a b c} {d e f} {g h i}} 2 1 => h
+lindex {{a b c} {d e f} {g h i}} {2 1} => h
+lindex {{{a b} {c d}} {{e f} {g h}}} 1 1 0 => g
+lindex {{{a b} {c d}} {{e f} {g h}}} {1 1 0} => g
+.CE
+.VE
+.SH "SEE ALSO"
+list(n), lappend(n), linsert(n), llength(n), lsearch(n),
+.VS 8.4
+lset(n),
+.VE
+lsort(n),
+lrange(n), lreplace(n)
.SH KEYWORDS
element, index, list
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
\fBend\-\fIinteger\fR refers to the last element in the list minus the
specified integer offset.
+
+.SH "SEE ALSO"
+.VS 8.4
+list(n), lappend(n), lindex(n), llength(n), lsearch(n),
+lset(n), lsort(n), lrange(n), lreplace(n)
+.VE
+
.SH KEYWORDS
element, insert, list
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.PP
This command returns a list comprised of all the \fIarg\fRs,
or an empty string if no \fIarg\fRs are specified.
-Braces and backslashes get added as necessary, so that the \fBindex\fR command
+Braces and backslashes get added as necessary, so that the \fBlindex\fR command
may be used on the result to re-extract the original arguments, and also
so that \fBeval\fR may be used to execute the resulting list, with
\fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising
\fBa b c d e f {g h}\fR
.CE
+.SH "SEE ALSO"
+lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
+.VS 8.4
+lset(n),
+.VE
+lsort(n),
+lrange(n), lreplace(n)
+
.SH KEYWORDS
element, list
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
Treats \fIlist\fR as a list and returns a decimal string giving
the number of elements in it.
+.SH "SEE ALSO"
+.VS 8.4
+list(n), lappend(n), lindex(n), linsert(n), lsearch(n),
+lset(n), lsort(n), lrange(n), lreplace(n)
+.VE
+
.SH KEYWORDS
element, list, length
detect the redundant loads, others may not).
.SH "SEE ALSO"
-\fBinfo sharedlibextension\fR, Tcl_StaticPackage, safe(n)
+info sharedlibextension, Tcl_StaticPackage(3), safe(n)
.SH KEYWORDS
binary code, loading, safe interpreter, shared library
-
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
for simple fields that aren't enclosed in braces); it does, however,
produce exactly the same results as ``\fBlist [lindex \fIlist first\fB]\fR''
+.SH "SEE ALSO"
+.VS 8.4
+list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
+lset(n), lreplace(n), lsort(n)
+.VE
+
.SH KEYWORDS
element, list, range, sublist
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
between \fIfirst\fR and \fIlast\fR are simply deleted. If \fIlist\fR
is empty, any \fIelement\fR arguments are added to the end of the list.
+.SH "SEE ALSO"
+.VS 8.4
+list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
+lset(n), lrange(n), lsort(n)
+.VE
+
.SH KEYWORDS
element, list, replace
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH lsearch n 7.0 Tcl "Tcl Built-In Commands"
+.TH lsearch n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
lsearch \- See if a list contains a particular element
.SH SYNOPSIS
-\fBlsearch \fR?\fImode\fR? \fIlist pattern\fR
+\fBlsearch \fR?\fIoptions\fR? \fIlist pattern\fR
.BE
.SH DESCRIPTION
.PP
This command searches the elements of \fIlist\fR to see if one
-of them matches \fIpattern\fR.
-If so, the command returns the index of the first matching
-element.
-If not, the command returns \fB\-1\fR.
-The \fImode\fR argument indicates how the elements of the list are to
-be matched against \fIpattern\fR and it must have one of the following
-values:
+of them matches \fIpattern\fR. If so, the command returns the index
+of the first matching element
+.VS 8.4
+(unless the options \fB\-all\fR or \fB\-inline\fR are specified.)
+.VE 8.4
+If not, the command returns \fB\-1\fR. The \fIoption\fR arguments
+indicates how the elements of the list are to be matched against
+\fIpattern\fR and it must have one of the following values:
+.TP
+\fB\-all\fR
+.VS 8.4
+Changes the result to be the list of all matching indices (or all
+matching values if \fB\-inline\fR is specified as well.)
+.VE 8.4
+.TP
+\fB\-ascii\fR
+The list elements are to be examined as ASCII strings. This option is only
+meaningful when used with \fB\-exact\fR or \fB\-sorted\fR.
+.TP
+\fB\-decreasing\fR
+The list elements are sorted in decreasing order. This option is only
+meaningful when used with \fB\-sorted\fR.
+.TP
+\fB\-dictionary\fR
+The list elements are to be compared using dictionary-style
+comparisons. This option is only meaningful when used with
+\fB\-exact\fR or \fB\-sorted\fR.
.TP
\fB\-exact\fR
The list element must contain exactly the same string as \fIpattern\fR.
\fIPattern\fR is a glob-style pattern which is matched against each list
element using the same rules as the \fBstring match\fR command.
.TP
+\fB\-increasing\fR
+The list elements are sorted in increasing order. This option is only
+meaningful when used with \fB\-sorted\fR.
+.TP
+\fB\-inline\fR
+.VS 8.4
+The matching value is returned instead of its index (or an empty
+string if no value matches.) If \fB\-all\fR is also specified, then
+the result of the command is the list of all values that matched.
+.VE 8.4
+.TP
+\fB\-integer\fR
+The list elements are to be compared as integers. This option is only
+meaningful when used with \fB\-exact\fR or \fB\-sorted\fR.
+.TP
+\fB\-not\fR
+.VS 8.4
+This negates the sense of the match, returning the index of the first
+non-matching value in the list.
+.VE 8.4
+.TP
+\fB\-real\fR
+The list elements are to be compared as floating-point values. This
+option is only meaningful when used with \fB\-exact\fR or \fB\-sorted\fR.
+.TP
\fB\-regexp\fR
\fIPattern\fR is treated as a regular expression and matched against
each list element using the rules described in the \fBre_syntax\fR
reference page.
+.TP
+\fB\-sorted\fR
+The list elements are in sorted order. If this option is specified,
+\fBlsearch\fR will use a more efficient searching algorithm to search
+\fIlist\fR. If no other options are specified, \fIlist\fR is assumed
+to be sorted in increasing order, and to contain ASCII strings. This
+option is mutually exclusive with \fB\-glob\fR and \fB\-regexp\fR, and
+is treated exactly like \fB-exact\fR when either \fB\-all\fR, or
+\fB\-not\fR is specified.
+.TP
+\fB\-start\fR \fIindex\fR
+.VS 8.4
+The list is searched starting at position \fIindex\fR. If \fIindex\fR
+has the value \fBend\fR, it refers to the last element in the list,
+and \fBend\-\fIinteger\fR refers to the last element in the list minus
+the specified integer offset.
+.VE 8.4
.PP
-If \fImode\fR is omitted then it defaults to \fB\-glob\fR.
+If \fIoption\fR is omitted then it defaults to \fB\-glob\fR. If more
+than one of \fB\-exact\fR, \fB\-glob\fR, \fB\-regexp\fR, and
+\fB\-sorted\fR is specified, whichever option is specified last takes
+precedence. If more than one of \fB\-ascii\fR, \fB\-dictionary\fR,
+\fB\-integer\fR and \fB\-real\fR is specified, the option specified
+last takes precedence. If more than one of \fB\-increasing\fR and
+\fB\-decreasing\fR is specified, the option specified last takes
+precedence.
+
+.VS 8.4
+.SH EXAMPLES
+.CS
+lsearch {a b c d e} c => 2
+lsearch -all {a b c a b c} c => 2 5
+lsearch -inline {a20 b35 c47} b* => b35
+lsearch -inline -not {a20 b35 c47} b* => a20
+lsearch -all -inline -not {a20 b35 c47} b* => a20 c47
+lsearch -all -not {a20 b35 c47} b* => 0 2
+lsearch -start 3 {a b c a b c} c => 5
+.CE
+.VE 8.4
+
+.SH "SEE ALSO"
+.VS 8.4
+foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n),
+lset(n), lsort(n), lrange(n), lreplace(n)
+.VE
.SH KEYWORDS
list, match, pattern, regular expression, search, string
.SH NAME
lset \- Change an element in a list
.SH SYNOPSIS
-\fBlset \fIlist ?index...? newValue\fR
+\fBlset \fIvarName ?index...? newValue\fR
.BE
.SH DESCRIPTION
.PP
-The \fBlset\fP command accepts a parameter, \fIlist\fP, which
+The \fBlset\fP command accepts a parameter, \fIvarName\fP, which
it interprets as the name of a variable containing a Tcl list.
It also accepts zero or more \fIindices\fP into
the list. The indices may be presented either consecutively on the
command line, or grouped in a
Tcl list and presented as a single argument.
-Finally, it accepts a new value for an element of \fIlist\fP.
+Finally, it accepts a new value for an element of \fIvarName\fP.
.PP
If no indices are presented, the command takes the form:
.CS
-lset list newValue
+lset varName newValue
.CE
or
.CS
-lset list {} newValue
+lset varName {} newValue
.CE
-In this case, \fInewValue\fP replaces the old value of the variable \fIlist\fP.
+In this case, \fInewValue\fP replaces the old value of the variable
+\fIvarName\fP.
.PP
When presented with a single index, the \fBlset\fR command
-treats the content of the \fIlist\fR variable as a Tcl list.
+treats the content of the \fIvarBane\fR variable as a Tcl list.
It addresses the \fIindex\fR'th element in it
(0 refers to the first element of the list).
When interpreting the list, \fBlset\fR observes the same rules
substitution and command substitution do not occur.
The command constructs a new list in which the designated element is
replaced with \fInewValue\fP. This new list is stored in the
-variable \fIlist\fP, and is also the return value from the \fBlset\fP
+variable \fIvarName\fP, and is also the return value from the \fBlset\fP
command.
.PP
If \fIindex\fR is negative or greater than or equal to the number
-of elements in \fI$list\fR, then an error occurs.
+of elements in \fI$varName\fR, then an error occurs.
.PP
If \fIindex\fR has the value \fBend\fR, it refers to the last element
in the list, and \fBend\-\fIinteger\fR refers to the last element in
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 1999 Scriptics Corporation
+'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
.TP 20
\fB\-index\0\fIindex\fR
If this option is specified, each of the elements of \fIlist\fR must
-itself be a proper Tcl sublist. Instead of sorting based on whole sublists,
-\fBlsort\fR will extract the \fIindex\fR'th element from each sublist
-and sort based on the given element. The keyword \fBend\fP is allowed
-for the \fIindex\fP to sort on the last sublist element. For example,
+itself be a proper Tcl sublist. Instead of sorting based on whole
+sublists, \fBlsort\fR will extract the \fIindex\fR'th element from
+each sublist and sort based on the given element. The keyword
+\fBend\fP is allowed for the \fIindex\fP to sort on the last sublist
+element,
+.VS 8.4
+and \fBend-\fIindex\fR sorts on a sublist element offset from
+the end.
+.VE
+For example,
.RS
.CS
lsort -integer -index 1 {{First 24} {Second 18} {Third 30}}
.CE
-returns \fB{Second 18} {First 24} {Third 30}\fR.
+returns \fB{Second 18} {First 24} {Third 30}\fR, and
+.VS 8.4
+'\"
+'\" This example is from the test suite!
+'\"
+.CS
+lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
+.CE
+returns \fB{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}\fR.
+.VE
This option is much more efficient than using \fB\-command\fR
to achieve the same effect.
.RE
-.VS 8.3
.TP 20
\fB\-unique\fR
If this option is specified, then only the last set of duplicate
\fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
considered duplicates and only the second element, \fB{1 b}\fR, would
be retained.
+
+.SH "NOTES"
+.PP
+The options to \fBlsort\fR only control what sort of comparison is
+used, and do not necessarily constrain what the values themselves
+actually are. This distinction is only noticeable when the list to be
+sorted has fewer than two elements.
+.PP
+The \fBlsort\fR command is reentrant, meaning it is safe to use as
+part of the implementation of a command used in the \fB\-command\fR
+option.
+
+.SH "EXAMPLES"
+
+.PP
+Sorting a list using ASCII sorting:
+.CS
+% lsort {a10 B2 b1 a1 a2}
+B2 a1 a10 a2 b1
+.CE
+
+.PP
+Sorting a list using Dictionary sorting:
+.CS
+% lsort -dictionary {a10 B2 b1 a1 a2}
+a1 a2 a10 b1 B2
+.CE
+
+.PP
+Sorting lists of integers:
+.CS
+% lsort -integer {5 3 1 2 11 4}
+1 2 3 4 5 11
+% lsort -integer {1 2 0x5 7 0 4 -1}
+-1 0 1 2 4 0x5 7
+.CE
+
+.PP
+Sorting lists of floating-point numbers:
+.CS
+% lsort -real {5 3 1 2 11 4}
+1 2 3 4 5 11
+% lsort -real {.5 0.07e1 0.4 6e-1}
+0.4 .5 6e-1 0.07e1
+.CE
+
+.PP
+Sorting using indices:
+.CS
+% # Note the space character before the c
+% lsort {{a 5} { c 3} {b 4} {e 1} {d 2}}
+{ c 3} {a 5} {b 4} {d 2} {e 1}
+% lsort -index 0 {{a 5} { c 3} {b 4} {e 1} {d 2}}
+{a 5} {b 4} { c 3} {d 2} {e 1}
+% lsort -index 1 {{a 5} { c 3} {b 4} {e 1} {d 2}}
+{e 1} {d 2} { c 3} {b 4} {a 5}
+.CE
+
+.PP
+Stripping duplicate values using sorting:
+.CS
+% lsort -unique {a b c a b c a b c}
+a b c
+.CE
+
+.PP
+More complex sorting using a comparison function:
+.CS
+% proc compare {a b} {
+ set a0 [lindex $a 0]
+ set b0 [lindex $b 0]
+ if {$a0 < $b0} {
+ return -1
+ } elseif {$a0 > $b0} {
+ return 1
+ }
+ return [string compare [lindex $a 1] [lindex $b 1]]
+}
+% lsort -command compare \\
+ {{3 apple} {0x2 carrot} {1 dingo} {2 banana}}
+{1 dingo} {2 banana} {0x2 carrot} {3 apple}
+.CE
+
+.SH "SEE ALSO"
+.VS 8.4
+list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
+lset(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
.SH "STANDARD OPTIONS"
.LP
.nf
-.ta 4c 8c 12c
+.ta 5.5c 11c
.ft B
..
'\" # SE - end of list of standard options
debugging capabilities. The memory command has several suboptions, which are
described below. It is only available when Tcl has been compiled with
memory debugging enabled (when \fBTCL_MEM_DEBUG\fR is defined at
-compile time).
+compile time), and after \fBTcl_InitMemory\fR has been called.
+.TP
+\fBmemory active\fR \fIfile\fR
+Write a list of all currently allocated memory to the specified \fIfile\fR.
+.TP
+\fBmemory break_on_malloc\fR \fIcount\fR
+After the \fIcount\fR allocations have been performed, \fBckalloc\fR
+outputs a message to this effect and that it is now attempting to enter
+the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself.
+If you are running Tcl under a C debugger, it should then enter the debugger
+command mode.
.TP
\fBmemory info\fR
-Produces a report containing the total allocations and frees since
+Returns a report containing the total allocations and frees since
Tcl began, the current packets allocated (the current
number of calls to \fBckalloc\fR not met by a corresponding call
to \fBckfree\fR), the current bytes allocated, and the maximum number
of packets and bytes allocated.
.TP
+\fB memory init [on|off]\fR
+Turn on or off the pre-initialization of all allocated memory
+with bogus bytes. Useful for detecting the use of uninitialized values.
+.TP
+\fBmemory onexit\fR \fIfile\fR
+Causes a list of all allocated memory to be written to the specified \fIfile\fR
+during the finalization of Tcl's memory subsystem. Useful for checking
+that memory is properly cleaned up during process exit.
+.TP
+\fBmemory tag\fR \fIstring\fR
+Each packet of memory allocated by \fBckalloc\fR can have associated
+with it a string-valued tag. In the lists of allocated memory generated
+by \fBmemory active\fR and \fBmemory onexit\fR, the tag for each packet
+is printed along with other information about the packet. The
+\fBmemory tag\fR command sets the tag value for subsequent calls
+to \fBckalloc\fR to be \fIstring\fR.
+.TP
\fBmemory trace [on|off]\fR
.br
Turns memory tracing on or off. When memory tracing is on, every call
\fIstderr\fR, consisting of the word \fIckalloc\fR, followed by the
address returned, the amount of memory allocated, and the C filename
and line number of the code performing the allocation. For example:
+.RS
.CS
ckalloc 40e478 98 tclProc.c 1406
.CE
Calls to \fBckfree\fR are traced in the same manner.
-.TP
-\fBmemory validate [on|off]\fR
-Turns memory validation on or off. When memory validation is enabled,
-on every call to \fBckalloc\fR or \fBckfree\fR, the guard zones are
-checked for every piece of memory currently in existence that was
-allocated by \fBckalloc\fR. This has a large performance impact and
-should only be used when overwrite problems are strongly suspected.
-The advantage of enabling memory validation is that a guard zone
-overwrite can be detected on the first call to \fBckalloc\fR or
-\fBckfree\fR after the overwrite occurred, rather than when the
-specific memory with the overwritten guard zone(s) is freed, which may
-occur long after the overwrite occurred.
+.RE
.TP
\fBmemory trace_on_at_malloc\fR \fIcount\fR
Enable memory tracing after \fIcount\fR \fBckalloc\fR's have been performed.
the problem sets in. The current number of memory allocations that have
occurred since Tcl started is printed on a guard zone failure.
.TP
-\fBmemory break_on_malloc\fR \fIcount\fR
-After the \fBcount\fR allocations have been performed, \fBckalloc\fR's
-output a message to this effect and that it is now attempting to enter
-the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself.
-If you are running Tcl under a C debugger, it should then enter the debugger
-command mode.
-.TP
-\fB memory display\fR \fIfile\fR
-Write a list of all currently allocated memory to the specified file.
+\fBmemory validate [on|off]\fR
+Turns memory validation on or off. When memory validation is enabled,
+on every call to \fBckalloc\fR or \fBckfree\fR, the guard zones are
+checked for every piece of memory currently in existence that was
+allocated by \fBckalloc\fR. This has a large performance impact and
+should only be used when overwrite problems are strongly suspected.
+The advantage of enabling memory validation is that a guard zone
+overwrite can be detected on the first call to \fBckalloc\fR or
+\fBckfree\fR after the overwrite occurred, rather than when the
+specific memory with the overwritten guard zone(s) is freed, which may
+occur long after the overwrite occurred.
.SH "SEE ALSO"
ckalloc, ckfree, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG
.SH KEYWORDS
memory, debug
-
-
'\" SCCS: @(#) msgcat.n
'\"
.so man.macros
-.TH "msgcat" n 8.1 Tcl "Tcl Built-In Commands"
+.TH "msgcat" n 1.3 msgcat "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
-\fB::msgcat::mc \fIsrc-string\fR
+\fBpackage require Tcl 8.2\fR
+.sp
+\fBpackage require msgcat 1.3\fR
+.sp
+\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
+.sp
+\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp
.sp
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
.sp
+\fB::msgcat::mcmset \fIlocale src-trans-list\fR
+.sp
\fB::msgcat::mcunknown \fIlocale src-string\fR
.BE
.PP
\fB::msgcat::mc\fR is the main function used to localize an
application. Instead of using an English string directly, an
-applicaton can pass the English string through \fB::msgcat::mc\fR and
+application can pass the English string through \fB::msgcat::mc\fR and
use the result. If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.TP
+\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
+Given several source strings, \fB::msgcat::mcmax\fR returns the length
+of the longest translated string. This is useful when designing
+localized GUIs, which may require that all buttons, for example, be a
+fixed width (which will be the width of the widest button).
+.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR
is omitted, the current locale is returned, otherwise the current locale
-is set to \fInewLocale\fR.
-The initial locale defaults to the locale specified in
-the user's environment. See \fBLOCALE AND SUBLOCALE SPECIFICATION\fR
+is set to \fInewLocale\fR. msgcat stores and compares the locale in a
+case-insensitive manner, and returns locales in lowercase.
+The initial locale is determined by the locale specified in
+the user's environment. See \fBLOCALE SPECIFICATION\fR
below for a description of the locale string format.
.TP
\fB::msgcat::mcpreferences\fR
Returns an ordered list of the locales preferred by
the user, based on the user's language specification.
The list is ordered from most specific to least
-preference. If the user has specified LANG=en_US_funky,
-this procedure would return {en_US_funky en_US en}.
+preference. The list is derived from the current
+locale set in msgcat by \fBmsgcat::mclocale\fR, and
+cannot be set independently. For example, if the
+current locale is en_US_funky, then \fBmsgcat::mcpreferences\fR
+returns {en_US_funky en_US en}.
.TP
\fB::msgcat::mcload \fIdirname\fR
Searches the specified directory for files that match
-the language specifications returned by \fB::msgcat::mcpreferences\fR.
-Each file located is sourced. The file extension is ``.msg''.
-The number of message files which matched the specification
+the language specifications returned by \fB::msgcat::mcpreferences\fR
+(note that these are all lowercase), extended by the file
+extension ``.msg''. Each matching file is
+read in order, assuming a UTF-8 encoding. The file contents are
+then evaluated as a Tcl script. This means that non-Latin characters
+may be present in the message file either directly in their UTF-8
+encoded form, or by use of the backslash-u quoting recognized by Tcl
+evaluation. The number of message files which matched the specification
and were loaded is returned.
.TP
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR
-in the specified \fIlocale\fR. If \fItranslate-string\fR is not
-specified, \fIsrc-string\fR is used for both. The function
-returns \fItranslate-string\fR.
+in the specified \fIlocale\fR and the current namespace. If
+\fItranslate-string\fR is not specified, \fIsrc-string\fR is used
+for both. The function returns \fItranslate-string\fR.
+.TP
+\fB::msgcat::mcmset \fIlocale src-trans-list\fR
+Sets the translation for multiple source strings in
+\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
+namespace.
+\fIsrc-trans-list\fR must have an even number of elements and is in
+the form {\fIsrc-string translate-string\fR ?\fIsrc-string
+translate-string ...\fR?} \fBmsgcat::mcmset\fR can be significantly
+faster than multiple invocations of \fBmsgcat::mcset\fR. The function
+returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
This routine is called by \fB::msgcat::mc\fR in the case when
\fIsrc-string\fR. This procedure can be redefined by the
application, for example to log error messages for each unknown
string. The \fB::msgcat::mcunknown\fR procedure is invoked at the
-same stack context as the call to \fB::msgcat::mc\fR. The return vaue
-of \fB::msgcat::mcunknown\fR is used as the return vaue for the call
+same stack context as the call to \fB::msgcat::mc\fR. The return value
+of \fB::msgcat::mcunknown\fR is used as the return value for the call
to \fB::msgcat::mc\fR.
-.SH "LOCALE AND SUBLOCALE SPECIFICATION"
+.SH "LOCALE SPECIFICATION"
.PP
-The locale is specified by a locale string.
+The locale is specified to \fBmsgcat\fR by a locale string
+passed to \fB::msgcat::mclocale\fR.
The locale string consists of
a language code, an optional country code, and an optional
system-specific code, each separated by ``_''. The country and language
codes are specified in standards ISO-639 and ISO-3166.
-For example, the locale ``en'' specifies English and
- ``en_US'' specifes U.S. English.
+For example, the locale ``en'' specifies English and ``en_US'' specifies
+U.S. English.
.PP
-The locale defaults to the value in \fBenv(LANG)\fR at the time the
-\fBmsgcat\fR package is loaded. If \fBenv(LANG)\fR is not defined, then the
-locale defaults to ``C''.
+When the msgcat package is first loaded, the locale is initialized
+according to the user's environment. The variables \fBenv(LC_ALL)\fR,
+\fBenv(LC_MESSAGES)\fR, and \fBenv(LANG)\fR are examined in order.
+The first of them to have a non-empty value is used to determine the
+initial locale. The value is parsed according to the XPG4 pattern
+.CS
+language[_country][.codeset][@modifier]
+.CE
+to extract its parts. The initial locale is then set by calling
+\fBmsgcat::mclocale\fR with the argument
+.CS
+language[_country][_modifier]
+.CE
+On Windows, if none of those environment variables is set, msgcat will
+attempt to extract locale information from the
+registry. If all these attempts to discover an initial locale
+from the user's environment fail, msgcat defaults to an initial
+locale of ``C''.
.PP
When a locale is specified by the user, a ``best match'' search is
performed during string translation. For example, if a user specifies
-en_UK_Funky, the locales ``en_UK_Funky'', ``en_UK'', and ``en'' are
+en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', and ``en'' are
searched in order until a matching translation string is found. If no
translation string is available, then \fB::msgcat::unknown\fR is
called.
the global namespace is reached. This allows child namespaces
to "inherit" messages from their parent namespace.
.PP
-For example, executing the code
+For example, executing (in the ``en'' locale) the code
.CS
mcset en m1 ":: message1"
mcset en m2 ":: message2"
.IP [1]
All message files for a package are in the same directory.
.IP [2]
-The message file name is a locale specifier followed
-by ``.msg''. For example:
+The message file name is a msgcat locale specifier (all lowercase)
+followed by ``.msg''. For example:
.CS
es.msg -- spanish
-en_UK.msg -- UK English
+en_gb.msg -- United Kingdom English
.CE
.IP [3]
-The file contains a series of calls to mcset, setting the
-necessary translation strings for the language. For example:
+The file contains a series of calls to \fBmcset\fR and
+\fBmcmset\fR, setting the necessary translation strings
+for the language, likely enclosed in a \fBnamespace eval\fR
+so that all source strings are tied to the namespace of
+the package. For example, a short \fBes.msg\fR might contain:
.CS
-::msgcat::mcset es "Free Beer!" "Cerveza Gracias!"
+namespace eval ::mypackage {
+ ::msgcat::mcset es "Free Beer!" "Cerveza Gracias!"
+}
.CE
.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
::msgcat::mcload [file join [file dirname [info script]] msgs]
.CE
-.SH "POSTITIONAL CODES FOR FORMAT AND SCAN COMMANDS"
+.SH "POSITIONAL CODES FOR FORMAT AND SCAN COMMANDS"
.PP
It is possible that a message string used as an argument
to \fBformat\fR might have positionally dependent parameters that
.SH "SEE ALSO"
format(n), scan(n), namespace(n), package(n)
+
.SH KEYWORDS
internationalization, i18n, localization, l10n, message, text, translation
'\"
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
+'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
can be executed in any namespace (assuming the value of
\fBscript\fR has been passed in properly)
and will have the same effect as the command
-\fBnamespace eval ::a::b {foo bar x y}\fR.
+\fB::namespace eval ::a::b {foo bar x y}\fR.
This command is needed because
extensions like Tk normally execute callback scripts
in the global namespace.
and any leading namespaces do not exist,
they are automatically created.
.TP
+\fBnamespace exists\fR \fInamespace\fR
+Returns \fB1\fR if \fInamespace\fR is a valid namespace in the current
+context, returns \fB0\fR otherwise.
+.TP
\fBnamespace export \fR?\-\fBclear\fR? ?\fIpattern pattern ...\fR?
Specifies which commands are exported from a namespace.
The exported commands are those that can be later imported
.TP
\fBnamespace forget \fR?\fIpattern pattern ...\fR?
Removes previously imported commands from a namespace.
-Each \fIpattern\fR is a qualified name such as
-\fBfoo::x\fR or \fBa::b::p*\fR.
+Each \fIpattern\fR is a simple or qualified name such as
+\fBx\fR, \fBfoo::x\fR or \fBa::b::p*\fR.
Qualified names contain \fB::\fRs and qualify a name
with the name of one or more namespaces.
-Each \fIpattern\fR is qualified with the name of an exporting namespace
+Each \fIqualified pattern\fR is qualified with the name of an
+exporting namespace
and may have glob-style special characters in the command name
at the end of the qualified name.
Glob characters may not appear in a namespace name.
-This command first finds the matching exported commands.
-It then checks whether any of those those commands
+For each \fIsimple pattern\fR this command deletes the matching
+commands of the
+current namespace that were imported from a different namespace.
+For \fIqualified patterns\fR, this command first finds the matching
+exported commands.
+It then checks whether any of those commands
were previously imported by the current namespace.
If so, this command deletes the corresponding imported commands.
In effect, this un-does the action of a \fBnamespace import\fR command.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH open n 7.6 Tcl "Tcl Built-In Commands"
+.TH open n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
.SH DESCRIPTION
.PP
-.VS
This command opens a file, serial port, or command pipeline and returns a
-.VE
channel identifier that may be used in future invocations of commands like
\fBread\fR, \fBputs\fR, and \fBclose\fR.
If the first character of \fIfileName\fR is not \fB|\fR then
(an integer) is used to set the permissions for the new file in
conjunction with the process's file mode creation mask.
\fIPermissions\fR defaults to 0666.
+.PP
+Note that if you are going to be reading or writing binary data from
+the channel created by this command, you should use the
+\fBfconfigure\fR command to change the \fB-translation\fR option of
+the channel to \fBbinary\fR before transferring any binary data. This
+is in contrast to the ``b'' character passed as part of the equivalent
+of the \fIaccess\fR parameter to some versions of the C library
+\fIfopen()\fR function.
+
.SH "COMMAND PIPELINES"
.PP
If the first character of \fIfileName\fR is ``|'' then the
If read-only access is used (e.g. \fIaccess\fR is \fBr\fR),
standard input for the pipeline is taken from the current standard
input unless overridden by the command.
+The id of the spawned process is accessible through the \fBpid\fR
+command, using the channel id returned by \fBopen\fR as argument.
+
+.VS 8.4
.SH "SERIAL COMMUNICATIONS"
-.VS
.PP
If \fIfileName\fR refers to a serial port, then the specified serial port
is opened and initialized in a platform-dependent manner. Acceptable
values for the \fIfileName\fR to use to open a serial port are described in
the PORTABILITY ISSUES section.
-
-.SH "CONFIGURATION OPTIONS"
-The \fBfconfigure\fR command can be used to query and set the following
-configuration option for open serial ports:
-.TP
-\fB\-mode \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR
-.
-This option is a set of 4 comma-separated values: the baud rate, parity,
-number of data bits, and number of stop bits for this serial port. The
-\fIbaud\fR rate is a simple integer that specifies the connection speed.
-\fIParity\fR is one of the following letters: \fBn\fR, \fBo\fR, \fBe\fR,
-\fBm\fR, \fBs\fR; respectively signifying the parity options of ``none'',
-``odd'', ``even'', ``mark'', or ``space''. \fIData\fR is the number of
-data bits and should be an integer from 5 to 8, while \fIstop\fR is the
-number of stop bits and should be the integer 1 or 2.
-.TP
-\fB\-pollinterval \fImsec\fR
-.
-This option, available only on Windows for serial ports, is used to
-set the maximum time between polling for fileevents. This affects the
-time interval between checking for events throughout the Tcl
-interpreter (the smallest value always wins). Use this option only if
-you want to poll the serial port more often than 10 msec (the default).
-.TP
-\fB\-lasterror\fR
-.
-This option is available only on Windows for serial ports, and is
-query only (will only be reported when directly requested).
-In case of a serial communication error, \fBread\fR or \fBputs\fR
-returns a general Tcl file I/O error.
-\fBfconfigure -lasterror\fR can be called to get a list
-of error details (e.g. FRAME RXOVER).
+.PP
+The \fBfconfigure\fR command can be used to query and set additional
+configuration options specific to serial ports.
.VE
-.VS
.SH "PORTABILITY ISSUES"
-.sp
.TP
\fBWindows \fR(all versions)
.
See the PORTABILITY ISSUES section of the \fBexec\fR command for additional
information not specific to command pipelines about executing
applications on the various platforms
+
.SH "SEE ALSO"
-close(n), filename(n), gets(n), read(n), puts(n), exec(n)
-.VE
+file(n), close(n), filename(n), fconfigure(n), gets(n), read(n),
+puts(n), exec(n), pid(n), fopen(3)
+
.SH KEYWORDS
access mode, append, create, file, non-blocking, open, permissions,
pipeline, process, serial
Otherwise, the command searches the database of information provided by
previous \fBpackage ifneeded\fR commands to see if an acceptable
version of the package is available.
-If so, the script for the highest acceptable version number is invoked;
+If so, the script for the highest acceptable version number is evaluated
+in the global namespace;
it must do whatever is necessary to load the package,
including calling \fBpackage provide\fR for the package.
If the \fBpackage ifneeded\fR database does not contain an acceptable
version of the package and a \fBpackage unknown\fR command has been
-specified for the interpreter then that command is invoked; when
+specified for the interpreter then that command is evaluated in the
+global namespace; when
it completes, Tcl checks again to see if the package is now provided
or if there is a \fBpackage ifneeded\fR script for it.
If all of these steps fail to provide an acceptable version of the
in response to \fBpackage require\fR commands.
See the documentation for \fBpkg_mkIndex\fR for details.
+.SH "SEE ALSO"
+msgcat(n), packagens(n), pkgMkIndex(n)
+
.SH KEYWORDS
package, version
-
\fBsource\fR command. Any number of \fB\-source\fR parameters may be
specified.
.PP
-At least one \fB\-load\fR or \fB\-source\fR paramter must be given.
+At least one \fB\-load\fR or \fB\-source\fR parameter must be given.
+
+.SH "SEE ALSO"
+package(n)
.SH KEYWORDS
auto-load, index, package, version
-
identifier of the current process.
All process identifiers are returned as decimal strings.
+.SH "SEE ALSO"
+exec(n), open(n)
+
.SH KEYWORDS
file, pipeline, process identifier
.SH SYNOPSIS
.nf
.VS 8.3.0
-\fBpkg_mkIndex ?\fI\-lazy\fR? ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR?
+\fBpkg_mkIndex ?\fI\-direct\fR? ?\fI\-lazy\fR? ?\fI\-load pkgPat\fR? ?\fI\-verbose\fR? \fIdir\fR ?\fIpattern pattern ...\fR?
.VE
.fi
.BE
.SH OPTIONS
The optional switches are:
.TP 15
+\fB\-direct\fR
+The generated index will implement direct loading of the package
+upon \fBpackage require\fR. This is the default.
+.TP 15
\fB\-lazy\fR
The generated index will manage to delay loading the package until the
use of one of the commands provided by the package, instead of loading
.PP
If binary files have dependencies on other packages, things
can become tricky because it is not possible to stub out
-C-level API's such as \fBTcl_PkgRequire\fP API
+C-level APIs such as \fBTcl_PkgRequire\fP API
when loading a binary file.
For example, suppose the BLT package requires Tk, and expresses
this with a call to \fBTcl_PkgRequire\fP in its \fBBlt_Init\fP routine.
then you must specify the scripts first; otherwise the package loaded from
the binary file may mask the package defined by the scripts.
+.SH "SEE ALSO"
+package(n)
+
.SH KEYWORDS
auto-load, index, package, version
If an error occurs while executing the procedure
body, then the procedure-as-a-whole will return that same error.
+.SH "SEE ALSO"
+info(n), unknown(n)
+
.SH KEYWORDS
argument, procedure
.PP
Writes the characters given by \fIstring\fR to the channel given
by \fIchannelId\fR.
-\fIChannelId\fR must be a channel identifier such as returned from a
-previous invocation of \fBopen\fR or \fBsocket\fR. It must have been opened
-for output. If no \fIchannelId\fR is specified then it defaults to
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as a
+Tcl standard channel (\fBstdout\fR or \fBstderr\fR), the return
+value from an invocation of \fBopen\fR or \fBsocket\fR, or the result
+of a channel creation command provided by a Tcl extension. The channel
+must have been opened for output.
+.VE
+.PP
+If no \fIchannelId\fR is specified then it defaults to
\fBstdout\fR. \fBPuts\fR normally outputs a newline character after
\fIstring\fR, but this feature may be suppressed by specifying the
\fB\-nonewline\fR switch.
via a file event that the channel is ready for more output data).
.SH "SEE ALSO"
-fileevent(n)
+file(n), fileevent(n), Tcl_StandardChannels(3)
.SH KEYWORDS
channel, newline, output, write
.PP
Returns the path name of the current working directory.
+.SH "SEE ALSO"
+file(n), cd(n), glob(n), filename(n)
+
.SH KEYWORDS
working directory
.SH DESCRIPTION
.PP
In the first form, the \fBread\fR command reads all of the data from
-\fIchannelId\fR up to the end of the file.
-If the \fB\-nonewline\fR switch is specified then the last character
-of the file is discarded if it is a newline.
-.VS 8.1
-In the second form, the extra argument specifies how many characters to
-read. Exactly that many characters will be read and returned, unless
-there are fewer than \fInumChars\fR left in the file; in this case
-all the remaining characters are returned. If the channel is
-configured to use a multi-byte encoding, then the number of characters
-read may not be the same as the number of bytes read.
+\fIchannelId\fR up to the end of the file. If the \fB\-nonewline\fR
+switch is specified then the last character of the file is discarded
+if it is a newline. In the second form, the extra argument specifies
+how many characters to read. Exactly that many characters will be
+read and returned, unless there are fewer than \fInumChars\fR left in
+the file; in this case all the remaining characters are returned. If
+the channel is configured to use a multi-byte encoding, then the
+number of characters read may not be the same as the number of bytes
+read.
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as the
+Tcl standard input channel (\fBstdin\fR), the return value from an
+invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel
+creation command provided by a Tcl extension. The channel must have
+been opened for input.
+.VE
.PP
If \fIchannelId\fR is in nonblocking mode, the command may not read as
many characters as requested: once all available input has been read,
multi-byte encoding, then there may actually be some bytes remaining
in the internal buffers that do not form a complete character. These
bytes will not be returned until a complete character is available or
-end-of-file is reached.
-.VE 8.1
-The \fB\-nonewline\fR switch is ignored if the command returns
-before reaching the end of the file.
+end-of-file is reached. The \fB\-nonewline\fR switch is ignored if
+the command returns before reaching the end of the file.
.PP
\fBRead\fR translates end-of-line sequences in the input into
newline characters according to the \fB\-translation\fR option
See the \fBfconfigure\fR manual entry for a discussion on ways in
which \fBfconfigure\fR will alter input.
+.SH "USE WITH SERIAL PORTS"
+'\" Note: this advice actually applies to many versions of Tcl
+
+For most applications a channel connected to a serial port should be
+configured to be nonblocking: \fBfconfigure \fIchannelId \fB\-blocking
+\fI0\fR. Then \fBread\fR behaves much like described above. Care
+must be taken when using \fBread\fR on blocking serial ports:
+.TP
+\fBread \fIchannelId numChars\fR
+In this form \fBread\fR blocks until \fInumChars\fR have been received
+from the serial port.
+.TP
+\fBread \fIchannelId\fR
+In this form \fBread\fR blocks until the reception of the end-of-file
+character, see \fBfconfigure -eofchar\fR. If there no end-of-file
+character has been configured for the channel, then \fBread\fR will
+block forever.
+
+
.SH "SEE ALSO"
-eof(n), fblocked(n), fconfigure(n)
+file(n), eof(n), fblocked(n), fconfigure(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, end of line, end of file, nonblocking, read, translation, encoding
\fB\-expanded\fR
Enables use of the expanded regular expression syntax where
whitespace and comments are ignored. This is the same as specifying
-the \fB(?x)\fR embedded option (see METASYNTAX, below).
+the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-indices\fR
Changes what is stored in the \fIsubMatchVar\fRs.
function, and `$' matches an empty string before any newline in
addition to its normal function. This flag is equivalent to
specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the
-\fB(?n)\fR embedded option (see METASYNTAX, below).
+\fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-linestop\fR
Changes the behavior of `[^' bracket expressions and `.' so that they
stop at newlines. This is the same as specifying the \fB(?p)\fR
-embedded option (see METASYNTAX, below).
+embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-lineanchor\fR
Changes the behavior of `^' and `$' (the ``anchors'') so they match the
beginning and end of a line respectively. This is the same as
-specifying the \fB(?w)\fR embedded option (see METASYNTAX, below).
+specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR
+manual page).
.TP 15
\fB\-nocase\fR
Causes upper-case characters in \fIstring\fR to be treated as
\fB\-all\fR
Causes the regular expression to be matched as many times as possible
in the string, returning the total number of matches found. If this
-is specified with match variables, they will continue information for
+is specified with match variables, they will contain information for
the last match only.
.TP 15
\fB\-inline\fR
has been specified or to an empty string otherwise.
.SH "SEE ALSO"
-re_syntax(n)
+re_syntax(n), regsub(n)
.SH KEYWORDS
match, regular expression, string
-
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
+'\" Copyright (c) 2002 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH registry n 8.0 Tcl "Tcl Built-In Commands"
+.TH registry n 1.1 registry "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
registry \- Manipulate the Windows registry
.SH SYNOPSIS
.sp
-\fBpackage require registry 1.0\fR
+\fBpackage require registry 1.1\fR
.sp
\fBregistry \fIoption\fR \fIkeyName\fR ?\fIarg arg ...\fR?
.BE
unique abbreviation for \fIoption\fR is acceptable. The valid options
are:
.TP
+.VS 8.4
+\fBregistry broadcast \fIkeyName\fR ?\fI-timeout milliseconds\fR?
+.
+Sends a broadcast message to the system and running programs to notify them
+of certain updates. This is necessary to propagate changes to key registry
+keys like Environment. The timeout specifies the amount of time, in
+milliseconds, to wait for applications to respond to the broadcast message.
+It defaults to 3000. The following example demonstrates how to add a path
+to the global Environment and notify applications of the change without
+reguiring a logoff/logon step (assumes admin privileges):
+.CS
+set regPath {HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment}
+set curPath [registry get $regPath "Path"]
+registry set $regPath "Path" "$curPath;$addPath"
+registry broadcast "Environment"
+.CE
+.VE 8.4
+.TP
\fBregistry delete \fIkeyName\fR ?\fIvalueName\fR?
.
If the optional \fIvalueName\fR argument is present, the specified
value under \fIkeyName\fR will be deleted from the registry. If the
optional \fIvalueName\fR is omitted, the specified key and any subkeys
-or values beneath it in the registry heirarchy will be deleted. If
+or values beneath it in the registry hierarchy will be deleted. If
the key could not be deleted then an error is generated. If the key
did not exist, the command has no effect.
.TP
.SH NAME
regsub \- Perform substitutions based on regular expression pattern matching
.SH SYNOPSIS
-\fBregsub \fR?\fIswitches\fR? \fIexp string subSpec varName\fR
+.VS 8.4
+\fBregsub \fR?\fIswitches\fR? \fIexp string subSpec \fR?\fIvarName\fR?
+.VE 8.4
.BE
.SH DESCRIPTION
.PP
This command matches the regular expression \fIexp\fR against
\fIstring\fR,
-and it copies \fIstring\fR to the variable whose name is
-given by \fIvarName\fR.
+.VS 8.4
+and either copies \fIstring\fR to the variable whose name is
+given by \fIvarName\fR or returns \fIstring\fR if \fIvarName\fR is not
+present.
+.VE 8.4
(Regular expression matching is described in the \fBre_syntax\fR
reference page.)
If there is a match, then while copying \fIstring\fR to \fIvarName\fR
+.VS 8.4
+(or to the result of this command if \fIvarName\fR is not present)
+.VE 8.4
the portion of \fIstring\fR that
matched \fIexp\fR is replaced with \fIsubSpec\fR.
If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced
\fB\-expanded\fR
Enables use of the expanded regular expression syntax where
whitespace and comments are ignored. This is the same as specifying
-the \fB(?x)\fR embedded option (see METASYNTAX, below).
+the \fB(?x)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-line\fR
Enables newline-sensitive matching. By default, newline is a
function, and `$' matches an empty string before any newline in
addition to its normal function. This flag is equivalent to
specifying both \fB\-linestop\fR and \fB\-lineanchor\fR, or the
-\fB(?n)\fR embedded option (see METASYNTAX, below).
+\fB(?n)\fR embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-linestop\fR
Changes the behavior of `[^' bracket expressions and `.' so that they
stop at newlines. This is the same as specifying the \fB(?p)\fR
-embedded option (see METASYNTAX, below).
+embedded option (see the \fBre_syntax\fR manual page).
.TP 15
\fB\-lineanchor\fR
Changes the behavior of `^' and `$' (the ``anchors'') so they match the
beginning and end of a line respectively. This is the same as
-specifying the \fB(?w)\fR embedded option (see METASYNTAX, below).
+specifying the \fB(?w)\fR embedded option (see the \fBre_syntax\fR
+manual page).
.TP 10
\fB\-nocase\fR
Upper-case characters in \fIstring\fR will be converted to lower-case
before matching against \fIexp\fR; however, substitutions specified
by \fIsubSpec\fR use the original unconverted form of \fIstring\fR.
-.VS 8.3
.TP 10
\fB\-start\fR \fIindex\fR
Specifies a character index offset into the string to start
will not match the beginning of the line, and \\A will still
match the start of the string at \fIindex\fR.
\fIindex\fR will be constrained to the bounds of the input string.
-.VE 8.3
.TP 10
\fB\-\|\-\fR
Marks the end of switches. The argument following this one will
be treated as \fIexp\fR even if it starts with a \fB\-\fR.
.PP
-The command returns a count of the number of matching ranges that
-were found and replaced.
+.VS 8.4
+If \fIvarName\fR is supplied, the command returns a count of the
+number of matching ranges that were found and replaced, otherwise the
+string after replacement is returned.
+.VE 8.4
See the manual entry for \fBregexp\fR for details on the interpretation
of regular expressions.
+.SH "SEE ALSO"
+regexp(n), re_syntax(n)
+
.SH KEYWORDS
match, pattern, regular expression, substitute
-
future invocations of it will execute in the new namespace.
The \fBrename\fR command returns an empty string as result.
+.SH "SEE ALSO"
+namespace(n), proc(n)
+
.SH KEYWORDS
command, delete, namespace, rename
\fB\-file\fR \fIresourceRef\fR
If the \fB-file\fR option is specified then the resource will be
written in the file pointed to by \fIresourceRef\fR, otherwise the
-most resently open resource will be used.
+most recently open resource will be used.
.TP
\fB\-force\fR
If the target resource already exists, then by default Tcl will not
The resource command is only available on Macintosh.
.SH "SEE ALSO"
-open
+open(n)
.SH KEYWORDS
open, resource
If the option is not specified then \fBerrorCode\fR will
default to \fBNONE\fR.
+.SH "SEE ALSO"
+break(n), continue(n), error(n), proc(n)
+
.SH KEYWORDS
break, continue, error, procedure, return
page for the \fBfile\fR command.
.TP
\fBencoding\fR ?\fIsubCmd args...\fR?
-The \fBenconding\fR alias provides access to a safe subset of the
+The \fBencoding\fR alias provides access to a safe subset of the
subcommands of the \fBencoding\fR command; it disallows setting of
the system encoding, but allows all other subcommands including
\fBsystem\fR to check the current encoding.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH scan n 8.3 Tcl "Tcl Built-In Commands"
+.TH scan n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
conversion specifiers as in \fBsscanf\fR. Each \fIvarName\fR gives the
name of a variable; when a field is scanned from \fIstring\fR the result is
converted back into a string and assigned to the corresponding variable.
-.VS 8.3
If no \fIvarName\fR variables are specified, then \fBscan\fR works in an
inline manner, returning the data that would otherwise be stored in the
variables as a list. In the inline case, an empty string is returned when
the end of the input string is reached before any conversions have been
performed.
-.VE 8.3
.SH "DETAILS ON SCANNING"
.PP
must match the next character of \fIstring\fR.
When a \fB%\fR is encountered in \fIformat\fR, it indicates
the start of a conversion specifier.
+.VS 8.4
A conversion specifier contains up to four fields after the \fB%\fR:
a \fB*\fR, which indicates that the converted value is to be discarded
-.VS 8.1
instead of assigned to a variable; a XPG3 position specifier; a number
-.VE 8.1
-indicating a maximum field width; and a conversion character.
+indicating a maximum field width; a field size modifier; and a
+conversion character.
+.VE 8.4
All of these fields are optional except for the conversion character.
The fields that are present must appear in the order given above.
.PP
Then it converts the next input characters according to the
conversion specifier and stores the result in the variable given
by the next argument to \fBscan\fR.
-.VS 8.1
.PP
If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in
``\fB%2$d\fR'', then the variable to use is not taken from the next
list must correspond to exactly one conversion specifier or an error
is generated, or in the inline case, any position can be specified
at most once and the empty positions will be filled in with empty strings.
-.VE 8.1
.PP
The following conversion characters are supported:
.TP 10
\fBd\fR
The input field must be a decimal integer.
It is read in and the value is stored in the variable as a decimal string.
+.VS 8.4
+If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
+value will have an internal representation that is at least 64-bits in
+size.
+.VE 8.4
.TP 10
\fBo\fR
The input field must be an octal integer. It is read in and the
value is stored in the variable as a decimal string.
+.VS 8.4
+If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
+value will have an internal representation that is at least 64-bits in
+size.
+If the value exceeds MAX_INT (017777777777 on platforms using 32-bit
+integers when the \fBl\fR and \fBL\fR modifiers are not given), it
+will be truncated to a signed integer. Hence, 037777777777 will
+appear as -1 on a 32-bit machine by default.
+.VE 8.4
.TP 10
\fBx\fR
The input field must be a hexadecimal integer. It is read in
and the value is stored in the variable as a decimal string.
-.VS 8.1
+.VS 8.4
+If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
+value will have an internal representation that is at least 64-bits in
+size.
+If the value exceeds MAX_INT (0x7FFFFFFF on platforms using 32-bit
+integers when the \fBl\fR and \fBL\fR modifiers are not given), it
+will be truncated to a signed integer. Hence, 0xFFFFFFFF will appear
+as -1 on a 32-bit machine.
+.VE 8.4
.TP 10
\fBu\fR
The input field must be a decimal integer. The value is stored in the
variable as an unsigned decimal integer string.
+.VS 8.4
+If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
+value will have an internal representation that is at least 64-bits in
+size.
+.VE 8.4
.TP 10
\fBi\fR
The input field must be an integer. The base (i.e. decimal, octal, or
hexadecimal) is determined in the same fashion as described in
\fBexpr\fR. The value is stored in the variable as a decimal string.
-.VE 8.1
+.VS 8.4
+If the \fBl\fR or \fBL\fR field size modifier is given, the scanned
+value will have an internal representation that is at least 64-bits in
+size.
+.VE 8.4
.TP 10
\fBc\fR
A single character is read in and its binary value is stored in
If the first character between the brackets is a \fB]\fR then
it is treated as part of \fIchars\fR rather than the closing
bracket for the set.
-.VS 8.1
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will match.
If the first or last character between the brackets is a \fB\-\fR, then
it is treated as part of \fIchars\fR rather than indicating a range.
-.VE 8.1
.TP 10
\fB[^\fIchars\fB]\fR
The input field consists of any number of characters not in
If the character immediately following the \fB^\fR is a \fB]\fR then it is
treated as part of the set rather than the closing bracket for
the set.
-.VS 8.1
If \fIchars\fR
contains a sequence of the form \fIa\fB\-\fIb\fR then any
character between \fIa\fR and \fIb\fR (inclusive) will be excluded
.TP 10
\fBn\fR
No input is consumed from the input string. Instead, the total number
-of chacters scanned from the input string so far is stored in the variable.
-.VE 8.1
+of characters scanned from the input string so far is stored in the variable.
.LP
The number of characters read from the input for a conversion is the
largest number that makes sense for that particular conversion (e.g.
.PP
The behavior of the \fBscan\fR command is the same as the behavior of
the ANSI C \fBsscanf\fR procedure except for the following differences:
-.VS 8.1
.IP [1]
\fB%p\fR conversion specifier is not currently supported.
-.VE 8.1
.IP [2]
For \fB%c\fR conversions a single character value is
converted to a decimal string, which is then assigned to the
corresponding \fIvarName\fR;
no field width may be specified for this conversion.
.IP [3]
-The \fBl\fR, \fBh\fR, and \fBL\fR modifiers are ignored; integer
-values are always converted as if there were no modifier present
-and real values are always converted as if the \fBl\fR modifier
-were present (i.e. type \fBdouble\fR is used for the internal
-representation).
-.VS 8.3
+.VS 8.4
+The \fBh\fR modifier is always ignored and the \fBl\fR and \fBL\fR
+modifiers are ignored when converting real values (i.e. type
+\fBdouble\fR is used for the internal representation).
+.VE 8.4
.IP [4]
If the end of the input string is reached before any conversions have been
-performed and no variables are given, and empty string is returned.
-.VE 8.3
+performed and no variables are given, an empty string is returned.
+
+.SH "SEE ALSO"
+format(n), sscanf(3)
.SH KEYWORDS
conversion specifier, parse, scan
-
.SH DESCRIPTION
.PP
Changes the current access position for \fIchannelId\fR.
-\fIChannelId\fR must be a channel identifier such as returned from a
-previous invocation of \fBopen\fR or \fBsocket\fR.
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as a
+Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
+the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
+the result of a channel creation command provided by a Tcl extension.
+.VE
+.PP
The \fIoffset\fR and \fIorigin\fR
arguments specify the position at which the next read or write will occur
for \fIchannelId\fR. \fIOffset\fR must be an integer (which may be
not characters, unlike \fBread\fR.
.VE 8.1
+.SH "SEE ALSO"
+file(n), open(n), close(n), gets(n), tell(n), Tcl_StandardChannels(3)
+
.SH KEYWORDS
access position, file, seek
or unless a \fBvariable\fR command
was invoked to declare \fIvarName\fR to be a namespace variable.
+.SH "SEE ALSO"
+expr(n), proc(n), trace(n), unset(n)
+
.SH KEYWORDS
read, write, variable
that can be used for both reading and writing.
\fIPort\fR and \fIhost\fR specify a port
to connect to; there must be a server accepting connections on
-this port. \fIPort\fR is an integer port number and \fIhost\fR
+this port. \fIPort\fR is an integer port number
+(or service name, where supported and understood by the host operating
+system) and \fIhost\fR
is either a domain-style name such as \fBwww.sunlabs.com\fR or
a numerical IP address such as \fB127.0.0.1\fR.
Use \fIlocalhost\fR to refer to the host on which the command is invoked.
will be chosen by the system software.
.TP
\fB\-myport\fI port\fR
-\fIPort\fR specifies an integer port number to use for the client's
+\fIPort\fR specifies an integer port number (or service name, where
+supported and understood by the host operating system) to use for the
+client's
side of the connection. If this option is omitted, the client's
port number will be chosen at random by the system software.
.TP
.SH "SERVER SOCKETS"
.PP
If the \fB\-server\fR option is specified then the new socket
-will be a server for the port given by \fIport\fR.
+will be a server for the port given by \fIport\fR (either an integer
+or a service name, where supported and understood by the host
+operating system).
Tcl will automatically accept connections to the given port.
For each connection Tcl will create a new channel that may be used to
communicate with the client. Tcl then invokes \fIcommand\fR
event loop, for example by invoking the \fBvwait\fR command or
calling the C procedure \fBTcl_DoOneEvent\fR, then no connections
will be accepted.
+.PP
+If \fIport\fR is specified as zero, the operating system will allocate
+an unused port for use as a server socket. The port number actually
+allocated my be retrieved from the created server socket using the
+\fBfconfigure\fR command to retrieve the \fB\-sockname\fR option as
+described below.
.SH "CONFIGURATION OPTIONS"
The \fBfconfigure\fR command can be used to query several readonly
configuration options for socket channels:
-.VS 8.0.5
.TP
\fB\-error\fR
This option gets the current error status of the given socket. This
is useful when you need to determine if an asynchronous connect
operation succeeded. If there was an error, the error message is
returned. If there was no error, an empty string is returned.
-.VE 8.0.5
.TP
\fB\-sockname\fR
This option returns a list of three elements, the address, the host name
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2000 Scriptics Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
If a \fBreturn\fR command is invoked from within the script then the
remainder of the file will be skipped and the \fBsource\fR command
will return normally with the result from the \fBreturn\fR command.
-
+.PP
+.VS 8.4
+The end-of-file character for files is '\\32' (^Z) for all platforms.
+The source command will read files up to this character. This
+restriction does not exist for the \fBread\fR or \fBgets\fR commands,
+allowing for files containing code and data segments (scripted documents).
+If you require a ``^Z'' in code for string comparison, you can use
+``\\032'' or ``\\u001a'', which will be safely substituted by the Tcl
+interpreter into ``^Z''.
+.VE 8.4
+.PP
The \fI\-rsrc\fR and \fI\-rsrcid\fR forms of this command are only
available on Macintosh computers. These versions of the command
allow you to source a script from a \fBTEXT\fR resource. You may specify
application and any loaded C extensions. Alternatively, you may
specify the \fIfileName\fR where the \fBTEXT\fR resource can be found.
+.SH "SEE ALSO"
+file(n), cd(n)
+
.SH KEYWORDS
file, script
.CE
returns \fB"H e l l o { } w o r l d"\fR.
+.SH "SEE ALSO"
+join(n), list(n), string(n)
+
.SH KEYWORDS
list, split, string
.PP
Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
-.VS 8.1
.TP
\fBstring bytelength \fIstring\fR
Returns a decimal string giving the number of bytes used to represent
represent Unicode characters, the byte length will not be the same as
the character length in general. The cases where a script cares about
the byte length are rare. In almost all cases, you should use the
-\fBstring length\fR operation. Refer to the \fBTcl_NumUtfChars\fR
-manual entry for more details on the UTF\-8 representation.
+\fBstring length\fR operation (including determining the length of a
+Tcl ByteArray object). Refer to the \fBTcl_NumUtfChars\fR manual
+entry for more details on the UTF\-8 representation.
.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR
-.VE 8.1
-Perform a character-by-character comparison of strings \fIstring1\fR and
-\fIstring2\fR. Returns
-\-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically
-less than, equal to, or greater than \fIstring2\fR.
-.VS 8.1
-If \fB\-length\fR is specified, then only the first \fIlength\fR characters
-are used in the comparison. If \fB\-length\fR is negative, it is
-ignored. If \fB\-nocase\fR is specified, then the strings are
-compared in a case-insensitive manner.
+Perform a character-by-character comparison of strings \fIstring1\fR
+and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether
+\fIstring1\fR is lexicographically less than, equal to, or greater
+than \fIstring2\fR. If \fB\-length\fR is specified, then only the
+first \fIlength\fR characters are used in the comparison. If
+\fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is
+specified, then the strings are compared in a case-insensitive manner.
.TP
\fBstring equal\fR ?\fB\-nocase\fR? ?\fB-length int\fR? \fIstring1 string2\fR
-Perform a character-by-character comparison of strings
-\fIstring1\fR and \fIstring2\fR. Returns 1 if \fIstring1\fR and
-\fIstring2\fR are identical, or 0 when not. If \fB\-length\fR is
-specified, then only the first \fIlength\fR characters are used in the
-comparison. If \fB\-length\fR is negative, it is ignored. If
-\fB\-nocase\fR is specified, then the strings are compared in a
-case-insensitive manner.
+Perform a character-by-character comparison of strings \fIstring1\fR
+and \fIstring2\fR. Returns 1 if \fIstring1\fR and \fIstring2\fR are
+identical, or 0 when not. If \fB\-length\fR is specified, then only
+the first \fIlength\fR characters are used in the comparison. If
+\fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is
+specified, then the strings are compared in a case-insensitive manner.
.TP
\fBstring first \fIstring1 string2\fR ?\fIstartIndex\fR?
-.VE 8.1
Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR. If found, return the index of the
first character in the first such match within \fIstring2\fR. If not
-found, return \-1.
-.VS 8.1
-If \fIstartIndex\fR is specified (in any of the forms accepted by the
-\fBindex\fR method), then the search is constrained to start with the
-character in \fIstring2\fR specified by the index. For example,
+found, return \-1. If \fIstartIndex\fR is specified (in any of the
+forms accepted by the \fBindex\fR method), then the search is
+constrained to start with the character in \fIstring2\fR specified by
+the index. For example,
.RS
.CS
\fBstring first a 0a23456789abcdef 5\fR
.CE
will return \fB\-1\fR.
.RE
-.VE 8.1
.TP
\fBstring index \fIstring charIndex\fR
-Returns the \fIcharIndex\fR'th character of the \fIstring\fR
-argument. A \fIcharIndex\fR of 0 corresponds to the first
-character of the string.
-.VS 8.1
-\fIcharIndex\fR may be specified as
-follows:
+Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument.
+A \fIcharIndex\fR of 0 corresponds to the first character of the
+string. \fIcharIndex\fR may be specified as follows:
.RS
.IP \fIinteger\fR 10
-The char specified at this integral index
+The char specified at this integral index.
.IP \fBend\fR 10
The last char of the string.
.IP \fBend\-\fIinteger\fR 10
-The last char of the string minus the specified integer
-offset (e.g. \fBend\-1\fR would refer to the "c" in "abcd").
+The last char of the string minus the specified integer offset
+(e.g. \fBend\-1\fR would refer to the "c" in "abcd").
.PP
-.VE 8.1
-If \fIcharIndex\fR is less than 0 or greater than
-or equal to the length of the string then an empty string is
-returned.
-.VS 8.1
+If \fIcharIndex\fR is less than 0 or greater than or equal to the
+length of the string then an empty string is returned.
.RE
.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
any class. If \fB\-failindex\fR is specified, then if the function
returns 0, the index in the string where the class was no longer valid
will be stored in the variable named \fIvarname\fR. The \fIvarname\fR
-will not be set if the function returns 1. The following character classes
-are recognized (the class name can be abbreviated):
+will not be set if the function returns 1. The following character
+classes are recognized (the class name can be abbreviated):
.RS
.IP \fBalnum\fR 10
Any Unicode alphabet or digit character.
.IP \fBalpha\fR 10
Any Unicode alphabet character.
.IP \fBascii\fR 10
-Any character with a value less than \\u0080 (those that
-are in the 7\-bit ascii range).
+Any character with a value less than \\u0080 (those that are in the
+7\-bit ascii range).
.IP \fBboolean\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 10
outside of the [0\-9] range.
.IP \fBdouble\fR 10
Any of the valid forms for a double in Tcl, with optional surrounding
-whitespace. In case of under/overflow in the value, 0 is returned
-and the \fIvarname\fR will contain \-1.
+whitespace. In case of under/overflow in the value, 0 is returned and
+the \fIvarname\fR will contain \-1.
.IP \fBfalse\fR 10
-Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false.
+Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
+false.
.IP \fBgraph\fR 10
Any Unicode printing character, except space.
.IP \fBinteger\fR 10
-Any of the valid forms for an integer in Tcl, with optional surrounding
-whitespace. In case of under/overflow in the value, 0 is returned
-and the \fIvarname\fR will contain \-1.
+Any of the valid forms for an integer in Tcl, with optional
+surrounding whitespace. In case of under/overflow in the value, 0 is
+returned and the \fIvarname\fR will contain \-1.
.IP \fBlower\fR 10
Any Unicode lower case alphabet character.
.IP \fBprint\fR 10
.IP \fBspace\fR 10
Any Unicode space character.
.IP \fBtrue\fR 10
-Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true.
+Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
+true.
.IP \fBupper\fR 10
Any upper case alphabet character in the Unicode character set.
.IP \fBwordchar\fR 10
-Any Unicode word character. That is any alphanumeric character,
-and any Unicode connector punctuation characters (e.g. underscore).
+Any Unicode word character. That is any alphanumeric character, and
+any Unicode connector punctuation characters (e.g. underscore).
.IP \fBxdigit\fR 10
Any hexadecimal digit character ([0\-9A\-Fa\-f]).
.PP
In the case of \fBboolean\fR, \fBtrue\fR and \fBfalse\fR, if the
-function will return 0, then the \fIvarname\fR will always be set to 0,
-due to the varied nature of a valid boolean value.
+function will return 0, then the \fIvarname\fR will always be set to
+0, due to the varied nature of a valid boolean value.
.RE
.TP
-\fBstring last \fIstring1 string2\fR ?\fIstartIndex\fR?
-.VE 8.1
+\fBstring last \fIstring1 string2\fR ?\fIlastIndex\fR?
Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR. If found, return the index of the
first character in the last such match within \fIstring2\fR. If there
-is no match, then return \-1.
-.VS 8.1
-If \fIstartIndex\fR is specified (in any of the forms accepted by the
-\fBindex\fR method), then only the characters in \fIstring2\fR at or before the
-specified \fIstartIndex\fR will be considered by the search. For example,
+is no match, then return \-1. If \fIlastIndex\fR is specified (in any
+of the forms accepted by the \fBindex\fR method), then only the
+characters in \fIstring2\fR at or before the specified \fIlastIndex\fR
+will be considered by the search. For example,
.RS
.CS
\fBstring last a 0a23456789abcdef 15\fR
.CE
will return \fB1\fR.
.RE
-.VE 8.1
.TP
\fBstring length \fIstring\fR
Returns a decimal string giving the number of characters in
\fIstring\fR. Note that this is not necessarily the same as the
-number of bytes used to store the string.
-.VS 8.1
+number of bytes used to store the string. If the object is a
+ByteArray object (such as those returned from reading a binary encoded
+channel), then this will return the actual byte length of the object.
.TP
\fBstring map\fR ?\fB\-nocase\fR? \fIcharMap string\fR
Replaces characters in \fIstring\fR based on the key-value pairs in
-\fIcharMap\fR. \fIcharMap\fR is a list of \fIkey value key value\fR ...
+\fIcharMap\fR. \fIcharMap\fR is a list of \fIkey value key value ...\fR
as in the form returned by \fBarray get\fR. Each instance of a
key in the string will be replaced with its corresponding value. If
\fB\-nocase\fR is specified, then matching is done without regard to
case differences. Both \fIkey\fR and \fIvalue\fR may be multiple
-characters. Replacement is done in an ordered manner, so the key appearing
-first in the list will be checked first, and so on. \fIstring\fR is
-only iterated over once, so earlier key replacements will have no
-affect for later key matches. For example,
+characters. Replacement is done in an ordered manner, so the key
+appearing first in the list will be checked first, and so on.
+\fIstring\fR is only iterated over once, so earlier key replacements
+will have no affect for later key matches. For example,
.RS
.CS
\fBstring map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc\fR
.RE
.TP
\fBstring match\fR ?\fB\-nocase\fR? \fIpattern\fR \fIstring\fR
-.VE 8.1
-See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0
-if it doesn't.
-.VS 8.1
-If \fB\-nocase\fR is specified, then the pattern attempts to match
-against the string in a case insensitive manner.
-.VE 8.1
-For the two strings to match, their contents
-must be identical except that the following special sequences
-may appear in \fIpattern\fR:
+See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 if
+it doesn't. If \fB\-nocase\fR is specified, then the pattern attempts
+to match against the string in a case insensitive manner. For the two
+strings to match, their contents must be identical except that the
+following special sequences may appear in \fIpattern\fR:
.RS
.IP \fB*\fR 10
-Matches any sequence of characters in \fIstring\fR,
-including a null string.
+Matches any sequence of characters in \fIstring\fR, including a null
+string.
.IP \fB?\fR 10
Matches any single character in \fIstring\fR.
.IP \fB[\fIchars\fB]\fR 10
Matches any character in the set given by \fIchars\fR. If a sequence
-of the form
-\fIx\fB\-\fIy\fR appears in \fIchars\fR, then any character
-between \fIx\fR and \fIy\fR, inclusive, will match.
-.VS 8.1
-When used with \fB\-nocase\fR, the end points of the range are converted
-to lower case first. Whereas {[A\-z]} matches '_' when matching
-case-sensitively ('_' falls between the 'Z' and 'a'), with \fB\-nocase\fR
-this is considered like {[A\-Za\-z]} (and probably what was meant in the
-first place).
-.VE 8.1
+of the form \fIx\fB\-\fIy\fR appears in \fIchars\fR, then any
+character between \fIx\fR and \fIy\fR, inclusive, will match. When
+used with \fB\-nocase\fR, the end points of the range are converted to
+lower case first. Whereas {[A\-z]} matches '_' when matching
+case-sensitively ('_' falls between the 'Z' and 'a'), with
+\fB\-nocase\fR this is considered like {[A\-Za\-z]} (and probably what
+was meant in the first place).
.IP \fB\e\fIx\fR 10
-Matches the single character \fIx\fR. This provides a way of
-avoiding the special interpretation of the characters
-\fB*?[]\e\fR in \fIpattern\fR.
+Matches the single character \fIx\fR. This provides a way of avoiding
+the special interpretation of the characters \fB*?[]\e\fR in
+\fIpattern\fR.
.RE
.TP
\fBstring range \fIstring first last\fR
Returns a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
-character whose index is \fIlast\fR. An index of 0 refers to the
-.VS 8.1
-first character of the string. \fIfirst\fR and \fIlast\fR may be
-specified as for the \fBindex\fR method.
-.VE 8.1
-If \fIfirst\fR is less than zero then it is treated as if it were zero, and
-if \fIlast\fR is greater than or equal to the length of the string then
-it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than
-\fIlast\fR then an empty string is returned.
-.VS 8.1
+character whose index is \fIlast\fR. An index of 0 refers to the first
+character of the string. \fIfirst\fR and \fIlast\fR may be specified
+as for the \fBindex\fR method. If \fIfirst\fR is less than zero then
+it is treated as if it were zero, and if \fIlast\fR is greater than or
+equal to the length of the string then it is treated as if it were
+\fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty
+string is returned.
.TP
\fBstring repeat \fIstring count\fR
Returns \fIstring\fR repeated \fIcount\fR number of times.
character whose index is \fIlast\fR. An index of 0 refers to the
first character of the string. \fIFirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method. If \fInewstring\fR is
-specified, then it is placed in the removed character range.
-If \fIfirst\fR is less than zero then it is treated as if it were zero, and
-if \fIlast\fR is greater than or equal to the length of the string then
-it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than
-\fIlast\fR or the length of the initial string, or \fIlast\fR is less
-than 0, then the initial string is returned untouched.
+specified, then it is placed in the removed character range. If
+\fIfirst\fR is less than zero then it is treated as if it were zero,
+and if \fIlast\fR is greater than or equal to the length of the string
+then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater
+than \fIlast\fR or the length of the initial string, or \fIlast\fR is
+less than 0, then the initial string is returned untouched.
.TP
\fBstring tolower \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
-Returns a value equal to \fIstring\fR except that all upper (or title) case
-letters have been converted to lower case. If \fIfirst\fR is specified, it
-refers to the first char index in the string to start modifying. If
-\fIlast\fR is specified, it refers to the char index in the string to stop
-at (inclusive). \fIfirst\fR and \fIlast\fR may be
+Returns a value equal to \fIstring\fR except that all upper (or title)
+case letters have been converted to lower case. If \fIfirst\fR is
+specified, it refers to the first char index in the string to start
+modifying. If \fIlast\fR is specified, it refers to the char index in
+the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring totitle \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that the first character
-in \fIstring\fR is converted to its Unicode title case variant (or upper
-case if there is no title case variant) and the rest of the string is
-converted to lower case. If \fIfirst\fR is specified, it
+in \fIstring\fR is converted to its Unicode title case variant (or
+upper case if there is no title case variant) and the rest of the
+string is converted to lower case. If \fIfirst\fR is specified, it
refers to the first char index in the string to start modifying. If
-\fIlast\fR is specified, it refers to the char index in the string to stop
-at (inclusive). \fIfirst\fR and \fIlast\fR may be
-specified as for the \fBindex\fR method.
+\fIlast\fR is specified, it refers to the char index in the string to
+stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified as
+for the \fBindex\fR method.
.TP
\fBstring toupper \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
-Returns a value equal to \fIstring\fR except that all lower (or title) case
-letters have been converted to upper case. If \fIfirst\fR is specified, it
-refers to the first char index in the string to start modifying. If
-\fIlast\fR is specified, it refers to the char index in the string to stop
-at (inclusive). \fIfirst\fR and \fIlast\fR may be specified as for the
-\fBindex\fR method.
-.VE 8.1
+Returns a value equal to \fIstring\fR except that all lower (or title)
+case letters have been converted to upper case. If \fIfirst\fR is
+specified, it refers to the first char index in the string to start
+modifying. If \fIlast\fR is specified, it refers to the char index in
+the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be
+specified as for the \fBindex\fR method.
.TP
\fBstring trim \fIstring\fR ?\fIchars\fR?
-Returns a value equal to \fIstring\fR except that any leading
-or trailing characters from the set given by \fIchars\fR are
-removed.
-If \fIchars\fR is not specified then white space is removed
-(spaces, tabs, newlines, and carriage returns).
+Returns a value equal to \fIstring\fR except that any leading or
+trailing characters from the set given by \fIchars\fR are removed. If
+\fIchars\fR is not specified then white space is removed (spaces,
+tabs, newlines, and carriage returns).
.TP
\fBstring trimleft \fIstring\fR ?\fIchars\fR?
-Returns a value equal to \fIstring\fR except that any
-leading characters from the set given by \fIchars\fR are
-removed.
-If \fIchars\fR is not specified then white space is removed
-(spaces, tabs, newlines, and carriage returns).
+Returns a value equal to \fIstring\fR except that any leading
+characters from the set given by \fIchars\fR are removed. If
+\fIchars\fR is not specified then white space is removed (spaces,
+tabs, newlines, and carriage returns).
.TP
\fBstring trimright \fIstring\fR ?\fIchars\fR?
-Returns a value equal to \fIstring\fR except that any
-trailing characters from the set given by \fIchars\fR are
-removed.
-If \fIchars\fR is not specified then white space is removed
-(spaces, tabs, newlines, and carriage returns).
-.VS 8.1
+Returns a value equal to \fIstring\fR except that any trailing
+characters from the set given by \fIchars\fR are removed. If
+\fIchars\fR is not specified then white space is removed (spaces,
+tabs, newlines, and carriage returns).
.TP
\fBstring wordend \fIstring charIndex\fR
Returns the index of the character just after the last one in the word
contiguous range of alphanumeric (Unicode letters or decimal digits)
or underscore (Unicode connector punctuation) characters, or any
single character other than these.
-.VE 8.1
+
+.SH "SEE ALSO"
+expr(n), list(n)
.SH KEYWORDS
case conversion, compare, index, match, pattern, string, word, equal, ctype
'\"
'\" Copyright (c) 1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2001 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or
\fB\-novariables\fR are specified, then the corresponding substitutions
are not performed.
-For example, if \fB\-nocommands\fR is specified, no command substitution
-is performed: open and close brackets are treated as ordinary characters
+For example, if \fB\-nocommands\fR is specified, command substitution
+is not performed: open and close brackets are treated as ordinary characters
with no special interpretation.
.PP
-Note: when it performs its substitutions, \fIsubst\fR does not
-give any special treatment to double quotes or curly braces. For
-example, the script
+.VS 8.4
+Note that the substitution of one kind can include substitution of
+other kinds. For example, even when the \fB-novariables\fR option
+is specified, command substitution is performed without restriction.
+This means that any variable substitution necessary to complete the
+command substitution will still take place. Likewise, any command
+substitution necessary to complete a variable substitution will
+take place, even when \fB-nocommands\fR is specified. See the
+EXAMPLES below.
+.PP
+If an error occurs during substitution, then \fBsubst\fR will return
+that error. If a break exception occurs during command or variable
+substitution, the result of the whole substitution will be the
+string (as substituted) up to the start of the substitution that
+raised the exception. If a continue exception occurs during the
+evaluation of a command or variable substitution, an empty string
+will be substituted for that entire command or variable substitution
+(as long as it is well-formed Tcl.) If a return exception occurs,
+or any other return code is returned during command or variable
+substitution, then the returned value is substituted for that
+substitution. See the EXAMPLES below. In this way, all exceptional
+return codes are ``caught'' by \fBsubst\fR. The \fBsubst\fR command
+itself will either return an error, or will complete successfully.
+.VE
+.SH EXAMPLES
+.PP
+When it performs its substitutions, \fIsubst\fR does not give any
+special treatment to double quotes or curly braces (except within
+command substitutions) so the script
.CS
\fBset a 44
subst {xyz {$a}}\fR
.CE
-returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''.
+returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''
+.VS 8.4
+and the script
+.CS
+\fBset a "p\\} q \\{r"
+subst {xyz {$a}}\fR
+.CE
+return ``\fBxyz {p} q {r}\fR'', not ``\fBxyz {p\\} q \\{r}\fR''.
+.PP
+When command substitution is performed, it includes any variable
+substitution necessary to evaluate the script.
+.CS
+\fBset a 44
+subst -novariables {$a [format $a]}\fR
+.CE
+returns ``\fB$a 44\fR'', not ``\fB$a $a\fR''. Similarly, when
+variable substitution is performed, it includes any command
+substitution necessary to retrieve the value of the variable.
+.CS
+\fBproc b {} {return c}
+array set a {c c [b] tricky}
+subst -nocommands {[b] $a([b])}\fR
+.CE
+returns ``\fB[b] c\fR'', not ``\fB[b] tricky\fR''.
+.PP
+The continue and break exceptions allow command substitutions to
+prevent substitution of the rest of the command substitution and the
+rest of \fIstring\fR respectively, giving script authors more options
+when processing text using \fIsubst\fR. For example, the script
+.CS
+\fBsubst {abc,[break],def}\fR
+.CE
+returns ``\fBabc,\fR'', not ``\fBabc,,def\fR'' and the script
+.CS
+\fBsubst {abc,[continue;expr 1+2],def}\fR
+.CE
+returns ``\fBabc,,def\fR'', not ``\fBabc,3,def\fR''.
+.PP
+Other exceptional return codes substitute the returned value
+.CS
+\fBsubst {abc,[return foo;expr 1+2],def}\fR
+.CE
+returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and
+.CS
+\fBsubst {abc,[return -code 10 foo;expr 1+2],def}\fR
+.CE
+also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''.
+.VE
+
+.SH "SEE ALSO"
+Tcl(n), eval(n), break(n), continue(n)
.SH KEYWORDS
backslash substitution, command substitution, variable substitution
.CE
will return \fB3\fR.
+.SH "SEE ALSO"
+for(n), if(n), regexp(n)
+
.SH KEYWORDS
switch, match, regular expression
When \fBtclsh\fR starts up, it treats all three lines as comments,
since the backslash at the end of the second line causes the third
line to be treated as part of the comment on the second line.
+.PP
+.VS
+You should note that it is also common practise to install tclsh with
+its version number as part of the name. This has the advantage of
+allowing multiple versions of Tcl to exist on the same system at once,
+but also the disadvantage of making it harder to write scripts that
+start up uniformly across different versions of Tcl.
+.VE
.SH "VARIABLES"
.PP
if \fBtcl_prompt2\fR isn't set then no prompt is output for
incomplete commands.
+.SH "STANDARD CHANNELS"
+.PP
+See \fBTcl_StandardChannels\fR for more explanations.
+
+.SH "SEE ALSO"
+fconfigure(n), tclvars(n)
+
.SH KEYWORDS
argument, interpreter, prompt, script file, shell
'\" Copyright (c) 1990-1994 The Regents of the University of California
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\" Copyright (c) 1998-1999 Scriptics Corporation
+'\" Copyright (c) 2000 Ajuba Solutions
+'\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH "Tcltest" n 8.2 Tcl "Tcl Built-In Commands"
+.TH "tcltest" n 2.1 tcltest "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Tcltest \- Test harness support code and utilities
+tcltest \- Test harness support code and utilities
.SH SYNOPSIS
-\fBpackage require tcltest ?1.0?\fP
+.nf
+\fBpackage require tcltest ?2.1?\fR
.sp
-\fB::tcltest::test \fIname desc ?constraint? script expectedAnswer\fR
+\fBtcltest::test \fIname description ?option value ...?\fR
+\fBtcltest::test \fIname description ?constraints? body result\fR
.sp
-\fB::tcltest::cleanupTests \fI?runningMultipleTests?\fR
+\fBtcltest::loadTestedCommands\fR
+\fBtcltest::makeDirectory \fIname ?directory?\fR
+\fBtcltest::removeDirectory \fIname ?directory?\fR
+\fBtcltest::makeFile \fIcontents name ?directory?\fR
+\fBtcltest::removeFile \fIname ?directory?\fR
+\fBtcltest::viewFile \fIname ?directory?\fR
+\fBtcltest::cleanupTests \fI?runningMultipleTests?\fR
+\fBtcltest::runAllTests\fR
.sp
-\fB::tcltest::getMatchingTestFiles\fR
+.VS 2.1
+\fBtcltest::configure\fR
+\fBtcltest::configure \fIoption\fR
+\fBtcltest::configure \fIoption value ?option value ...?\fR
+\fBtcltest::customMatch \fImode command\fR
+.VE
+\fBtcltest::testConstraint \fIconstraint ?value?\fR
+\fBtcltest::outputChannel \fI?channelID?\fR
+\fBtcltest::errorChannel \fI?channelID?\fR
+\fBtcltest::interpreter \fI?interp?\fR
.sp
-\fB::tcltest::loadTestedCommands\fR
+\fBtcltest::debug \fI?level?\fR
+\fBtcltest::errorFile \fI?filename?\fR
+\fBtcltest::limitConstraints \fI?boolean?\fR
+\fBtcltest::loadFile \fI?filename?\fR
+\fBtcltest::loadScript \fI?script?\fR
+\fBtcltest::match \fI?patternList?\fR
+\fBtcltest::matchDirectories \fI?patternList?\fR
+\fBtcltest::matchFiles \fI?patternList?\fR
+\fBtcltest::outputFile \fI?filename?\fR
+\fBtcltest::preserveCore \fI?level?\fR
+\fBtcltest::singleProcess \fI?boolean?\fR
+\fBtcltest::skip \fI?patternList?\fR
+\fBtcltest::skipDirectories \fI?patternList?\fR
+\fBtcltest::skipFiles \fI?patternList?\fR
+\fBtcltest::temporaryDirectory \fI?directory?\fR
+\fBtcltest::testsDirectory \fI?directory?\fR
+\fBtcltest::verbose \fI?level?\fR
.sp
-\fB::tcltest::makeFile \fIcontents name\fR
-.sp
-\fB::tcltest::removeFile \fIname\fR
-.sp
-\fB::tcltest::makeDirectory \fIname\fR
-.sp
-\fB::tcltest::removeDirectory \fIname\fR
-.sp
-\fB::tcltest::viewFile \fIname\fR
-.sp
-\fB::tcltest::normalizeMsg \fImsg\fR
-.sp
-\fB::tcltest::bytestring \fIstring\fR
-.sp
-\fB::tcltest::saveState\fR
-.sp
-\fB::tcltest::restoreState\fR
-.sp
-\fB::tcltest::threadReap\fR
+\fBtcltest::test \fIname description optionList\fR
+\fBtcltest::bytestring \fIstring\fR
+\fBtcltest::normalizeMsg \fImsg\fR
+\fBtcltest::normalizePath \fIpathVar\fR
+\fBtcltest::workingDirectory \fI?dir?\fR
+.fi
.BE
.SH DESCRIPTION
.PP
-The \fBtcltest\fR package provides the user with utility tools for
-writing and running tests in the Tcl test suite. It can also be used
-to create a customized test harness for an extension.
+The \fBtcltest\fR package provides several utility commands useful
+in the construction of test suites for code instrumented to be
+run by evaluation of Tcl commands. Notably the built-in commands
+of the Tcl library itself are tested by a test suite using the
+tcltest package.
.PP
-The Tcl test suite consists of multiple .test files, each of which
-contains multiple test cases. Each test case consists of a call to
-the test command, which specifies the name of test, a short
-description, any constraints that apply to the test case, the script
-to be run, and expected results. See the sections \fI"Tests,"\fR
-\fI"Test Constraints,"\fR and \fI"Test Files and How to Run Them"\fR
-for more details.
+All the commands provided by the \fBtcltest\fR package are defined
+in and exported from the \fB::tcltest\fR namespace, as indicated in
+the \fBSYNOPSIS\fR above. In the following sections, all commands
+will be described by their simple names, in the interest of brevity.
.PP
-It is also possible to add to this test harness to create your own
-customized test harness implementation. For more defails, see the
-section \fI"How to Customize the Test Harness"\fR.
+The central command of \fBtcltest\fR is [\fBtest\fR] that defines
+and runs a test. Testing with [\fBtest\fR] involves evaluation
+of a Tcl script and comparing the result to an expected result, as
+configured and controlled by a number of options. Several other
+commands provided by \fBtcltest\fR govern the configuration of
+[\fBtest\fR] and the collection of many [\fBtest\fR] commands into
+test suites.
.PP
-This approach to testing was designed and initially implemented by
-Mary Ann May-Pumphrey of Sun Microsystems in the early 1990's. Many
-thanks to her for donating her work back to the public Tcl release.
+See \fBCREATING TEST SUITES WITH TCLTEST\fR below for an extended example
+of how to use the commands of \fBtcltest\fR to produce test suites
+for your Tcl-enabled code.
.SH COMMANDS
.TP
-\fB::tcltest::test\fP \fIname desc ?constraints? script expectedAnswer\fR
-The \fB::tcltest::test\fR command runs\fIscript\fR and compares
-its result to \fIexpectedAnswer\fR. It prints an error message if the two do
-not match. If \fB::tcltest::verbose\fR contains "p" or "s", it also prints
-out a message if the test passed or was skipped. The test will be
-skipped if it doesn't match the \fB::tcltest::match\fR variable, if it
-matches an element in \fB::tcltest::skip\fR, or if one of the elements
-of \fIconstraint\fR turns out not to be true. The
-\fB::tcltest::test\fR command has no defined return values. See the
-\fI"Writing a new test"\fR section for more details on this command.
-.TP
-\fB::tcltest::cleanupTests\fP \fI?runningMultipleTests?\fR
-This command should be called at the end of a test file. It prints
-statistics about the tests run and removes files that were created by
-\fB::tcltest::makeDirectory\fR and \fB::tcltest::makeFile\fR. Names
-of files and directories created outside of
-\fB::tcltest::makeFile\fR and \fB::tcltest::makeDirectory\fR and
-never deleted are printed to \fB::tcltest::outputChannel\fR. This command
-also restores the original shell environment, as described by the ::env
-array. \fIcalledFromAll\fR should be specified when
-\fB::tcltest::cleanupTests\fR is called from an "all.tcl" file. Tcl files
-files are generally used to run multiple tests. For more details on how to
-run multiple tests, please see the section \fI"Running test files"\fR.
-This proc has no defined return value.
-.TP
-\fB::tcltest::getMatchingTestFiles\fP
-This command is used when you want to run multiple test files. It returns
-the list of tests that should be sourced in an 'all.tcl' file. See the
-section \fI"Running test files"\fR for more information.
-.TP
-\fB::tcltest::loadTestedCommands\fP
-This command uses the script specified via the \fI-load\fR or
-\fI-loadfile\fR to load the commands checked by the test suite.
-Allowed to be empty, as the tested commands could have been compiled
-into the interpreter running the test suite.
-.TP
-\fB::tcltest::makeFile\fP \fIcontents name\fR
-Create a file that will be automatically be removed by
-\fB::tcltest::cleanupTests\fR at the end of a test file.
-This proc has no defined return value.
-.TP
-\fB::tcltest::removeFile\fP \fIname\fR
-Force the file referenced by \fIname\fR to be removed. This file name
-should be relative to \fI::tcltest::temporaryDirectory\fR. This proc has no
-defined return values.
-.TP
-\fB::tcltest::makeDirectory\fP \fIname\fR
-Create a directory named \fIname\fR that will automatically be removed
-by \fB::tcltest::cleanupTests\fR at the end of a test file. This proc
-has no defined return value.
-.TP
-\fB::tcltest::removeDirectory\fP \fIname\fR
-Force the directory referenced by \fIname\fR to be removed. This proc
-has no defined return value.
-.TP
-\fB::tcltest::viewFile\fP \fIfile\fR
-Returns the contents of \fIfile\fR.
-.TP
-\fB::tcltest::normalizeMsg\fP \fImsg\fR
-Remove extra newlines from \fImsg\fR.
-.TP
-\fB::tcltest::bytestring\fP \fIstring\fR
+\fBtest\fR \fIname description ?option value ...?\fR
+Defines and possibly runs a test with the name \fIname\fR and
+description \fIdescription\fR. The name and description of a test
+are used in messages reported by [\fBtest\fR] during the
+test, as configured by the options of \fBtcltest\fR. The
+remaining \fIoption value\fR arguments to [\fBtest\fR]
+define the test, including the scripts to run, the conditions
+under which to run them, the expected result, and the means
+by which the expected and actual results should be compared.
+See \fBTESTS\fR below for a complete description of the valid
+options and how they define a test. The [\fBtest\fR] command
+returns an empty string.
+.TP
+\fBtest\fR \fIname description ?constraints? body result\fR
+This form of [\fBtest\fR] is provided to support test suites written
+for version 1 of the \fBtcltest\fR package, and also a simpler
+interface for a common usage. It is the same as
+[\fBtest\fR \fIname description\fB -constraints \fIconstraints\fB -body
+\fIbody\fB -result \fIresult\fR]. All other options to [\fBtest\fR]
+take their default values. When \fIconstraints\fR is omitted, this
+form of [\fBtest\fR] can be distinguished from the first because
+all \fIoption\fRs begin with ``-''.
+.TP
+\fBloadTestedCommands\fR
+Evaluates in the caller's context the script specified by
+[\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR].
+Returns the result of that script evaluation, including any error
+raised by the script. Use this command and the related
+configuration options to provide the commands to be tested to
+the interpreter running the test suite.
+.TP
+\fBmakeFile\fR \fIcontents name ?directory?\fR
+Creates a file named \fIname\fR relative to
+directory \fIdirectory\fR and write \fIcontents\fR
+to that file using the encoding [\fBencoding system\fR].
+If \fIcontents\fR does not end with a newline, a newline
+will be appended so that the file named \fIname\fR
+does end with a newline. Because the system encoding is used,
+this command is only suitable for making text files.
+The file will be removed by the next evaluation
+of [\fBcleanupTests\fR], unless it is removed by
+[\fBremoveFile\fR] first. The default value of
+\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
+Returns the full path of the file created. Use this command
+to create any text file required by a test with contents as needed.
+.TP
+\fBremoveFile\fR \fIname ?directory?\fR
+Forces the file referenced by \fIname\fR to be removed. This file name
+should be relative to \fIdirectory\fR. The default value of
+\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
+Returns an empty string. Use this command to delete files
+created by [\fBmakeFile\fR].
+.TP
+\fBmakeDirectory\fR \fIname ?directory?\fR
+Creates a directory named \fIname\fR relative to directory \fIdirectory\fR.
+The directory will be removed by the next evaluation of [\fBcleanupTests\fR],
+unless it is removed by [\fBremoveDirectory\fR] first.
+The default value of \fIdirectory\fR is the directory
+[\fBconfigure -tmpdir\fR].
+Returns the full path of the directory created. Use this command
+to create any directories that are required to exist by a test.
+.TP
+\fBremoveDirectory\fR \fIname ?directory?\fR
+Forces the directory referenced by \fIname\fR to be removed. This
+directory should be relative to \fIdirectory\fR.
+The default value of \fIdirectory\fR is the directory
+[\fBconfigure -tmpdir\fR].
+Returns an empty string. Use this command to delete any directories
+created by [\fBmakeDirectory\fR].
+.TP
+\fBviewFile\fR \fIfile ?directory?\fR
+Returns the contents of \fIfile\fR, except for any
+final newline, just as [\fBread -nonewline\fR] would return.
+This file name should be relative to \fIdirectory\fR.
+The default value of \fIdirectory\fR is the directory
+[\fBconfigure -tmpdir\fR]. Use this command
+as a convenient way to turn the contents of a file generated
+by a test into the result of that test for matching against
+an expected result. The contents of the file are read using
+the system encoding, so its usefulness is limited to text
+files.
+.TP
+\fBcleanupTests\fR
+Intended to clean up and summarize after several tests have been
+run. Typically called once per test file, at the end of the file
+after all tests have been completed. For best effectiveness, be
+sure that the [\fBcleanupTests\fR] is evaluated even if an error
+occurs earlier in the test file evaluation.
+.sp
+Prints statistics about the tests run and removes files that were
+created by [\fBmakeDirectory\fR] and [\fBmakeFile\fR] since the
+last [\fBcleanupTests\fR]. Names of files and directories
+in the directory [\fBconfigure -tmpdir\fR] created since
+the last [\fBcleanupTests\fR], but not created by
+[\fBmakeFile\fR] or [\fBmakeDirectory\fR] are printed
+to [\fBoutputChannel\fR]. This command also restores the original
+shell environment, as described by the ::env
+array. Returns an empty string.
+.TP
+\fBrunAllTests\fR
+This is a master command meant to run an entire suite of tests,
+spanning multiple files and/or directories, as governed by
+the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR
+below for a complete description of the many variations possible
+with [\fBrunAllTests\fR].
+.SH "CONFIGURATION COMMANDS"
+.VS
+.TP
+\fBconfigure\fR
+Returns the list of configurable options supported by \fBtcltest\fR.
+See \fBCONFIGURABLE OPTIONS\fR below for the full list of options,
+their valid values, and their effect on \fBtcltest\fR operations.
+.TP
+\fBconfigure \fIoption\fR
+Returns the current value of the supported configurable option \fIoption\fR.
+Raises an error if \fIoption\fR is not a supported configurable option.
+.TP
+\fBconfigure \fIoption value ?option value ...?\fR
+Sets the value of each configurable option \fIoption\fR to the
+corresponding value \fIvalue\fR, in order. Raises an error if
+an \fIoption\fR is not a supported configurable option, or if
+\fIvalue\fR is not a valid value for the corresponding \fIoption\fR,
+or if a \fIvalue\fR is not provided. When an error is raised, the
+operation of [\fBconfigure\fR] is halted, and subsequent \fIoption value\fR
+arguments are not processed.
+.sp
+If the environment variable \fB::env(TCLTEST_OPTIONS)\fR exists when
+the \fBtcltest\fR package is loaded (by [\fBpackage require tcltest\fR])
+then its value is taken as a list of arguments to pass to [\fBconfigure\fR].
+This allows the default values of the configuration options to be
+set by the environment.
+.TP
+\fBcustomMatch \fImode script\fR
+Registers \fImode\fR as a new legal value of the \fB-match\fR option
+to [\fBtest\fR]. When the \fB-match \fImode\fR option is
+passed to [\fBtest\fR], the script \fIscript\fR will be evaluated
+to compare the actual result of evaluating the body of the test
+to the expected result.
+To perform the match, the \fIscript\fR is completed with two additional
+words, the expected result, and the actual result, and the completed script
+is evaluated in the global namespace.
+The completed script is expected to return a boolean value indicating
+whether or not the results match. The built-in matching modes of
+[\fBtest\fR] are \fBexact\fR, \fBglob\fR, and \fBregexp\fR.
+.VE
+.TP
+\fBtestConstraint \fIconstraint ?boolean?\fR
+Sets or returns the boolean value associated with the named \fIconstraint\fR.
+See \fBTEST CONSTRAINTS\fR below for more information.
+.TP
+\fBinterpreter\fR \fI?executableName?\fR
+Sets or returns the name of the executable to be [\fBexec\fR]ed by
+[\fBrunAllTests\fR] to run each test file when
+[\fBconfigure -singleproc\fR] is false.
+The default value for [\fBinterpreter\fR] is the name of the
+currently running program as returned by [\fBinfo nameofexecutable\fR].
+.TP
+\fBoutputChannel\fR \fI?channelID?\fR
+Sets or returns the output channel ID. This defaults to stdout.
+Any test that prints test related output should send
+that output to [\fBoutputChannel\fR] rather than letting
+that output default to stdout.
+.TP
+\fBerrorChannel\fR \fI?channelID?\fR
+Sets or returns the error channel ID. This defaults to stderr.
+Any test that prints error messages should send
+that output to [\fBerrorChannel\fR] rather than printing
+directly to stderr.
+.SH "SHORTCUT COMMANDS"
+.TP
+\fBdebug \fI?level?\fR
+Same as [\fBconfigure -debug \fI?level?\fR].
+.TP
+\fBerrorFile \fI?filename?\fR
+Same as [\fBconfigure -errfile \fI?filename?\fR].
+.TP
+\fBlimitConstraints \fI?boolean?\fR
+Same as [\fBconfigure -limitconstraints \fI?boolean?\fR].
+.TP
+\fBloadFile \fI?filename?\fR
+Same as [\fBconfigure -loadfile \fI?filename?\fR].
+.TP
+\fBloadScript \fI?script?\fR
+Same as [\fBconfigure -load \fI?script?\fR].
+.TP
+\fBmatch \fI?patternList?\fR
+Same as [\fBconfigure -match \fI?patternList?\fR].
+.TP
+\fBmatchDirectories \fI?patternList?\fR
+Same as [\fBconfigure -relateddir \fI?patternList?\fR].
+.TP
+\fBmatchFiles \fI?patternList?\fR
+Same as [\fBconfigure -file \fI?patternList?\fR].
+.TP
+\fBoutputFile \fI?filename?\fR
+Same as [\fBconfigure -outfile \fI?filename?\fR].
+.TP
+\fBpreserveCore \fI?level?\fR
+Same as [\fBconfigure -preservecore \fI?level?\fR].
+.TP
+\fBsingleProcess \fI?boolean?\fR
+Same as [\fBconfigure -singleproc \fI?boolean?\fR].
+.TP
+\fBskip \fI?patternList?\fR
+Same as [\fBconfigure -skip \fI?patternList?\fR].
+.TP
+\fBskipDirectories \fI?patternList?\fR
+Same as [\fBconfigure -asidefromdir \fI?patternList?\fR].
+.TP
+\fBskipFiles \fI?patternList?\fR
+Same as [\fBconfigure -notfile \fI?patternList?\fR].
+.TP
+\fBtemporaryDirectory \fI?directory?\fR
+Same as [\fBconfigure -tmpdir \fI?directory?\fR].
+.TP
+\fBtestsDirectory \fI?directory?\fR
+Same as [\fBconfigure -testdir \fI?directory?\fR].
+.TP
+\fBverbose \fI?level?\fR
+Same as [\fBconfigure -verbose \fI?level?\fR].
+.SH "OTHER COMMANDS"
+.PP
+The remaining commands provided by \fBtcltest\fR have better
+alternatives provided by \fBtcltest\fR or \fBTcl\fR itself. They
+are retained to support existing test suites, but should be avoided
+in new code.
+.TP
+\fBtest\fR \fIname description optionList\fR
+This form of [\fBtest\fR] was provided to enable passing many
+options spanning several lines to [\fBtest\fR] as a single
+argument quoted by braces, rather than needing to backslash quote
+the newlines between arguments to [\fBtest\fR]. The \fIoptionList\fR
+argument is expected to be a list with an even number of elements
+representing \fIoption\fR and \fIvalue\fR arguments to pass
+to [\fBtest\fR]. However, these values are not passed directly, as
+in the alternate forms of [\fBswitch\fR]. Instead, this form makes
+an unfortunate attempt to overthrow Tcl's substitution rules by
+performing substitutions on some of the list elements as an attempt to
+implement a ``do what I mean'' interpretation of a brace-enclosed
+``block''. The result is nearly impossible to document clearly, and
+for that reason this form is not recommended. See the examples in
+\fBCREATING TEST SUITES WITH TCLTEST\fR below to see that this
+form is really not necessary to avoid backslash-quoted newlines.
+If you insist on using this form, examine
+the source code of \fBtcltest\fR if you want to know the substitution
+details, or just enclose the third through last argument
+to [\fBtest\fR] in braces and hope for the best.
+.TP
+\fBworkingDirectory\fR \fI?directoryName?\fR
+Sets or returns the current working directory when the test suite is
+running. The default value for workingDirectory is the directory in
+which the test suite was launched. The Tcl commands [\fBcd\fR] and
+[\fBpwd\fR] are sufficient replacements.
+.TP
+\fBnormalizeMsg\fR \fImsg\fR
+Returns the result of removing the ``extra'' newlines from \fImsg\fR,
+where ``extra'' is rather imprecise. Tcl offers plenty of string
+processing commands to modify strings as you wish, and
+[\fBcustomMatch\fR] allows flexible matching of actual and expected
+results.
+.TP
+\fBnormalizePath\fR \fIpathVar\fR
+Resolves symlinks in a path, thus creating a path without internal
+redirection. It is assumed that \fIpathVar\fR is absolute.
+\fIpathVar\fR is modified in place. The Tcl command [\fBfile normalize\fR]
+is a sufficient replacement.
+.TP
+\fBbytestring\fR \fIstring\fR
Construct a string that consists of the requested sequence of bytes,
as opposed to a string of properly formed UTF-8 characters using the
value supplied in \fIstring\fR. This allows the tester to create
denormalized or improperly formed strings to pass to C procedures that
are supposed to accept strings with embedded NULL types and confirm
-that a string result has a certain pattern of bytes.
-.TP
-\fB::tcltest::saveState\fP
-\fB::tcltest::restoreState\fP
-Save and restore the procedure and global variable names.
-A test file might contain calls to \fB::tcltest::saveState\fR and
-\fB::tcltest:restoreState\fR if it creates or deletes global variables
-or procs.
-.TP
-\fB::tcltest::threadReap\fP
-\fB::tcltest::threadReap\fR only works if \fItestthread\fR is
-defined, generally by compiling tcltest. If \fItestthread\fR is
-defined, \fB::tcltest::threadReap\fR kills all threads except for the
-main thread. It gets the ID of the main thread by calling
-\fItestthread names\fR during initialization. This value is stored in
-\fI::tcltest::mainThread\fR. \fB::tcltest::threadReap\fR returns the
-number of existing threads at completion.
+that a string result has a certain pattern of bytes. This is
+exactly equivalent to the Tcl command [\fBencoding convertfrom identity\fR].
.SH TESTS
-The \fBtest\fR procedure runs a test script and prints an error
-message if the script's result does not match the expected result.
-The following is the spec for the \fBtest\fR command:
-.DS
-test <name> <description> ?<constraint>? <script> <expectedAnswer>
-.DE
-The <name> argument should follow the pattern:
-.DS
-<target>-<majorNum>.<minorNum>
-.DE
+.PP
+The [\fBtest\fR] command is the heart of the \fBtcltest\fR package.
+Its essential function is to evaluate a Tcl script and compare
+the result with an expected result. The options of [\fBtest\fR]
+define the test script, the environment in which to evaluate it,
+the expected result, and how the compare the actual result to
+the expected result. Some configuration options of \fBtcltest\fR
+also influence how [\fBtest\fR] operates.
+.PP
+The valid options for [\fBtest\fR] are summarized:
+.CS
+.ta 0.8i
+test \fIname\fR \fIdescription\fR
+ ?-constraints \fIkeywordList|expression\fR?
+ ?-setup \fIsetupScript\fR?
+ ?-body \fItestScript\fR?
+ ?-cleanup \fIcleanupScript\fR?
+ ?-result \fIexpectedAnswer\fR?
+ ?-output \fIexpectedOutput\fR?
+ ?-errorOutput \fIexpectedError\fR?
+ ?-returnCodes \fIcodeList\fR?
+ ?-match \fImode\fR?
+.CE
+The \fIname\fR may be any string. It is conventional to choose
+a \fIname\fR according to the pattern:
+.CS
+\fItarget\fR-\fImajorNum\fR.\fIminorNum\fR
+.CE
For white-box (regression) tests, the target should be the name of the
C function or Tcl procedure being tested. For black-box tests, the
-target should be the name of the feature being tested. Related tests
-should share a major number.
+target should be the name of the feature being tested. Some conventions
+call for the names of black-box tests to have the suffix \fB_bb\fR.
+Related tests should share a major number. As a test suite evolves,
+it is best to have the same test name continue to correspond to the
+same test, so that it remains meaningful to say things like ``Test
+foo-1.3 passed in all releases up to 3.4, but began failing in
+release 3.5.''
.PP
-The <description> argument is a short textual description of the test,
-to help humans understand what it tests. The name of a Tcl or C
-function being tested should be included for regression tests. If the
-test case exists to reproduce a bug, include the bug ID in the
-description.
+During evaluation of [\fBtest\fR], the \fIname\fR will be compared
+to the lists of string matching patterns returned by
+[\fBconfigure -match\fR], and [\fBconfigure -skip\fR]. The test
+will be run only if \fIname\fR matches any of the patterns from
+[\fBconfigure -match\fR] and matches none of the patterns
+from [\fBconfigure -skip\fR].
.PP
-The optional <constraints> argument can be list of one or more
-keywords or an expression. If the <constraints> argument consists of
-keywords, each of these keywords must be the name of an element in the array
-\fI::tcltest::testConstraints\fR. If any of these elements is false or does
-not exist, the test is skipped. If the <constraints> argument
-consists of an expression, that expression is evaluated. If the
-expression evaluates to true, then the test is run.
+The \fIdescription\fR should be a short textual description of the
+test. The \fIdescription\fR is included in output produced by the
+test, typically test failure messages. Good \fIdescription\fR values
+should briefly explain the purpose of the test to users of a test suite.
+The name of a Tcl or C function being tested should be included in the
+description for regression tests. If the test case exists to reproduce
+a bug, include the bug ID in the description.
.PP
-Add appropriate constraints (e.g.,
-unixOnly) to any tests that should not always be run. For example, a
-test that should only be run on Unix should look like the following:
-.PP
-.DS
-test getAttribute-1.1 {testing file permissions} {unixOnly} {
- lindex [file attributes foo.tcl] 5
-} {00644}
-.DE
+Valid attributes and associated values are:
+.TP
+\fB-constraints \fIkeywordList|expression\fR
+The optional \fB-constraints\fR attribute can be list of one or more
+keywords or an expression. If the \fB-constraints\fR value is a list of
+keywords, each of these keywords should be the name of a constraint
+defined by a call to [\fBtestConstraint\fR]. If any of the listed
+constraints is false or does not exist, the test is skipped. If the
+\fB-constraints\fR value is an expression, that expression
+is evaluated. If the expression evaluates to true, then the test is run.
+Note that the expression form of \fB-constraints\fR may interfere with the
+operation of [\fBconfigure -constraints\fR] and
+[\fBconfigure -limitconstraints\fR], and is not recommended.
+Appropriate constraints should be added to any tests that should
+not always be run. That is, conditional evaluation of a test
+should be accomplished by the \fB-constraints\fR option, not by
+conditional evaluation of [\fBtest\fR]. In that way, the same
+number of tests are always reported by the test suite, though
+the number skipped may change based on the testing environment.
+The default value is an empty list.
+See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints
+and information on how to add your own constraints.
+.TP
+\fB-setup \fIscript\fR
+The optional \fB-setup\fR attribute indicates a \fIscript\fR that will be run
+before the script indicated by the \fB-body\fR attribute. If evaluation
+of \fIscript\fR raises an error, the test will fail. The default value
+is an empty script.
+.TP
+\fB-body \fIscript\fR
+The \fB-body\fR attribute indicates the \fIscript\fR to run to carry out the
+test. It must return a result that can be checked for correctness.
+If evaluation of \fIscript\fR raises an error, the test will fail.
+The default value is an empty script.
+.TP
+\fB-cleanup \fIscript\fR
+The optional \fB-cleanup\fR attribute indicates a \fIscript\fR that will be
+run after the script indicated by the \fB-body\fR attribute.
+If evaluation of \fIscript\fR raises an error, the test will fail.
+The default value is an empty script.
+.TP
+\fB-match \fImode\fR
+The \fB-match\fR attribute determines how expected answers supplied by
+\fB-result\fR, \fB-output\fR, and \fB-errorOutput\fR are compared. Valid
+values for \fImode\fR are \fBregexp\fR, \fBglob\fR, \fBexact\fR, and
+any value registered by a prior call to [\fBcustomMatch\fR]. The default
+value is \fBexact\fR.
+.TP
+\fB-result \fIexpectedValue\fR
+The \fB-result\fR attribute supplies the \fIexpectedValue\fR against which
+the return value from script will be compared. The default value is
+an empty string.
+.TP
+\fB-output \fIexpectedValue\fR
+The \fB-output\fR attribute supplies the \fIexpectedValue\fR against which
+any output sent to \fBstdout\fR or [\fBoutputChannel\fR] during evaluation
+of the script(s) will be compared. Note that only output printed using
+[\fBputs\fR] is used for comparison. If \fB-output\fR is not specified,
+output sent to \fBstdout\fR and [\fBoutputChannel\fR] is not processed for
+comparison.
+.TP
+\fB-errorOutput \fIexpectedValue\fR
+The \fB-errorOutput\fR attribute supplies the \fIexpectedValue\fR against
+which any output sent to \fBstderr\fR or [\fBerrorChannel\fR] during
+evaluation of the script(s) will be compared. Note that only output
+printed using [\fBputs\fR] is used for comparison. If \fB-errorOutput\fR
+is not specified, output sent to \fBstderr\fR and [\fBerrorChannel\fR] is
+not processed for comparison.
+.TP
+\fB-returnCodes \fIexpectedCodeList\fR
+The optional \fB-returnCodes\fR attribute supplies \fIexpectedCodeList\fR,
+a list of return codes that may be accepted from evaluation of the
+\fB-body\fR script. If evaluation of the \fB-body\fR script returns
+a code not in the \fIexpectedCodeList\fR, the test fails. All
+return codes known to [\fBreturn\fR], in both numeric and symbolic
+form, including extended return codes, are acceptable elements in
+the \fIexpectedCodeList\fR. Default value is \fB{ok return}\fR.
.PP
-An example of a test that contains an expression:
+To pass, a test must successfully evaluate its \fB-setup\fR, \fB-body\fR,
+and \fB-cleanup\fR scripts. The return code of the \fB-body\fR script and
+its result must match expected values, and if specified, output and error
+data from the test must match expected \fB-output\fR and \fB-errorOutput\fR
+values. If any of these conditions are not met, then the test fails.
+Note that all scripts are evaluated in the context of the caller
+of [\fBtest\fR].
.PP
-.DS
-test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
- catch {vwait x}
- set f [open foo w]
- fileevent $f writable {set x 1}
- vwait x
- close $f
- list [catch {vwait x} msg] $msg
-} {1 {can't wait for variable "x": would wait forever}}
-.DE
+As long as [\fBtest\fR] is called with valid syntax and legal
+values for all attributes, it will not raise an error. Test
+failures are instead reported as output written to [\fBoutputChannel\fR].
+In default operation, a successful test produces no output. The output
+messages produced by [\fBtest\fR] are controlled by the
+[\fBconfigure -verbose\fR] option as described in \fBCONFIGURABLE OPTIONS\fR
+below. Any output produced by the test scripts themselves should be
+produced using [\fBputs\fR] to [\fBoutputChannel\fR] or
+[\fBerrorChannel\fR], so that users of the test suite may
+easily capture output with the [\fBconfigure -outfile\fR] and
+[\fBconfigure -errfile\fR] options, and so that the \fB-output\fR
+and \fB-errorOutput\fR attributes work properly.
+.SH "TEST CONSTRAINTS"
.PP
-See the "Test Constraints" section for a list of built-in
-constraints and information on how to add your own constraints.
+Constraints are used to determine whether or not a test should be skipped.
+Each constraint has a name, which may be any string, and a boolean
+value. Each [\fBtest\fR] has a \fB-constraints\fR value which is a
+list of constraint names. There are two modes of constraint control.
+Most frequently, the default mode is used, indicated by a setting
+of [\fBconfigure -limitconstraints\fR] to false. The test will run
+only if all constraints in the list are true-valued. Thus,
+the \fB-constraints\fR option of [\fBtest\fR] is a convenient, symbolic
+way to define any conditions required for the test to be possible or
+meaningful. For example, a [\fBtest\fR] with \fB-constraints unix\fR
+will only be run if the constraint \fBunix\fR is true, which indicates
+the test suite is being run on a Unix platform.
.PP
-The <script> argument contains the script to run to carry out the
-test. It must return a result that can be checked for correctness.
-If your script requires that a file be created on the fly, please use
-the ::tcltest::makeFile procedure. If your test requires that a small
-file (<50 lines) be checked in, please consider creating the file on
-the fly using the ::tcltest::makeFile procedure. Files created by the
-::tcltest::makeFile procedure will automatically be removed by the
-::tcltest::cleanupTests call at the end of each test file.
+Each [\fBtest\fR] should include whatever \fB-constraints\fR are
+required to constrain it to run only where appropriate. Several
+constraints are pre-defined in the \fBtcltest\fR package, listed
+below. The registration of user-defined constraints is performed
+by the [\fBtestConstraint\fR] command. User-defined constraints
+may appear within a test file, or within the script specified
+by the [\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR]
+options.
.PP
-The <expectedAnswer> argument will be compared against the result of
-evaluating the <script> argument. If they match, the test passes,
-otherwise the test fails.
-.SH "TCLTEST NAMEPSACE VARIABLES"
-The following variables are also defined in the \fBtcltest\fR namespace and
-can be used by tests:
-.TP
-\fB::tcltest::outputChannel\fR
-output file ID - defaults to stdout and can be specified using
--outfile on the command line.
-Any test that prints test related output should send
-that output to \fI::tcltest::outputChannel\fR rather than letting
-that output default to stdout.
-.TP
-\fB::tcltest::errorChannel\fR
-error file ID - defaults to stderr and can be specified using -errfile
-on the command line.
-Any test that prints error messages should send
-that output to \fI::tcltest::errorChannel\fR rather than printing
-directly to stderr.
-.TP
-\fB::tcltest::mainThread\fR
-main thread ID - defaults to 1. This is the only thread that is not
-killed by ::tcltest::threadReap and is set according to the return
-value of \fItestthread names\fR at initialization.
-.TP
-\fB::tcltest::originalEnv\fR
-copy of the global "env" array at the beginning of the test run. This
-array is used to restore the "env" array to its original state when
-\fI::tcltest::cleanupTests\fR is called.
-.TP
-\fB::tcltest::workingDirectory\fR
-the directory in which the test suite was launched.
+The following is a list of constraints pre-defined by the
+\fBtcltest\fR package itself:
.TP
-\fB::tcltest::temporaryDirectory\fR
-the output directory - defaults to \fI::tcltest::workingDirectory\fR and can be
-specified using -tmpdir on the command line.
-.TP
-\fB::tcltest::testsDirectory\fR
-where the tests reside - defaults to \fI::tcltest::workingDirectory\fR
-if the script cannot determine where the \fItests\fR directory is
-located. It is possible to change the default by specifying
-\fI-testdir\fR on the commandline. This variable should be
-explicitly set if tests are being run from an all.tcl file.
-.TP
-\fB::tcltest::tcltest\fR
-the name of the executable used to invoke the test suite.
-.TP
-\fB::tcltest::loadScript\fR
-The script executed \fBloadTestedCommands\fR. Specified either by
-\fI-load\fR or \fI-loadfile\fR.
-.SH "TEST CONSTRAINTS"
-Constraints are used to determine whether a test should be skipped.
-Each constraint is stored as an index in the array
-\fI::tcltest::testConstraints\fR. For example, the unixOnly constraint is
-defined as the following:
-.DS
-set ::tcltest::testConstraints(unixOnly) \\
- [string equal $tcl_platform(platform) "unix"]
-.DE
-If a test is constrained by "unixOnly", then it will only be run if
-the value of ::tcltest::testConstraints(unixOnly) is true. Several
-constraints are defined in the \fBtcltest\fR package. To add file- or
-test-specific constraints, you can set the desired index of the
-::tcltest::testsConstraints array in your own test file.
-.PP
-The following is a list of constraints defined in the \fBtcltest\fR package:
+\fIsingleTestInterp\fR
+test can only be run if all test files are sourced into a single interpreter
.TP
\fIunix\fR
-test can only be run on any UNIX platform
+test can only be run on any Unix platform
.TP
-\fIpc\fR
+\fIwin\fR
test can only be run on any Windows platform
.TP
\fInt\fR
\fImac\fR
test can only be run on any Mac platform
.TP
-\fIunixOrPc\fR
-test can only be run on a UNIX or PC platform
+\fIunixOrWin\fR
+test can only be run on a Unix or Windows platform
.TP
-\fImacOrPc\fR
-test can only be run on a Mac or PC platform
+\fImacOrWin\fR
+test can only be run on a Mac or Windows platform
.TP
\fImacOrUnix\fR
-test can only be run on a Mac or UNIX platform
+test can only be run on a Mac or Unix platform
.TP
-\fItempNotPc\fR
+\fItempNotWin\fR
test can not be run on Windows. This flag is used to temporarily
disable a test.
.TP
to temporarily disable a test.
.TP
\fIunixCrash\fR
-test crashes if it's run on UNIX. This flag is used to temporarily
+test crashes if it's run on Unix. This flag is used to temporarily
disable a test.
.TP
-\fIpcCrash\fR
+\fIwinCrash\fR
test crashes if it's run on Windows. This flag is used to temporarily
disable a test.
.TP
\fIemptyTest\fR
test is empty, and so not worth running, but it remains as a
place-holder for a test to be written in the future. This constraint
-always causes tests to be skipped.
+has value false to cause tests to be skipped unless the user specifies
+otherwise.
.TP
\fIknownBug\fR
test is known to fail and the bug is not yet fixed. This constraint
-always causes tests to be skipped unless the user specifies otherwise.
-See the "Introduction" section for more details.
+has value false to cause tests to be skipped unless the user specifies
+otherwise.
.TP
\fInonPortable\fR
-test can only be run in the master Tcl/Tk development environment.
+test can only be run in some known development environment.
Some tests are inherently non-portable because they depend on things
like word length, file system configuration, window manager, etc.
-These tests are only run in the main Tcl development directory where
-the configuration is well known. This constraint always causes tests
-to be skipped unless the user specifies otherwise.
+This constraint has value false to cause tests to be skipped unless
+the user specifies otherwise.
.TP
\fIuserInteraction\fR
-test requires interaction from the user. This constraint always
-causes tests to be skipped unless the user specifies otherwise.
+test requires interaction from the user. This constraint has
+value false to causes tests to be skipped unless the user specifies
+otherwise.
.TP
\fIinteractive\fR
-test can only be run in if the interpreter is in interactive mode,
-that is the global tcl_interactive variable is set to 1.
+test can only be run in if the interpreter is in interactive mode
+(when the global tcl_interactive variable is set to 1).
.TP
\fInonBlockFiles\fR
test can only be run if platform supports setting files into
on a pipe
.TP
\fIunixExecs\fR
-test can only be run if this machine has commands such as 'cat', 'echo',
-etc. available.
+test can only be run if this machine has Unix-style commands
+\fBcat\fR, \fBecho\fR, \fBsh\fR, \fBwc\fR, \fBrm\fR, \fBsleep\fR,
+\fBfgrep\fR, \fBps\fR, \fBchmod\fR, and \fBmkdir\fR available
.TP
\fIhasIsoLocale\fR
test can only be run if can switch to an ISO locale
to the "e" format of floating-point numbers.
.TP
\fIstdio\fR
-test can only be run if the current app can be spawned via a pipe
-.SH "RUNNING TEST FILES"
-Use the following command to run a test file that uses package
-tcltest:
-.DS
-<shell> <testFile> ?<option> ?<value>?? ...
-.DE
-Command line options include (tcltest namespace variables that
-correspond to each flag are listed at the end of each flag description
-in parenthesis):
-.RS
-.TP
-\fB-help\fR
-display usage information.
-.TP
-\fB-verbose <level>\fR
-set the level of verbosity to a substring of "bps". See the "Test
-output" section for an explanation of this option. (::tcltest::verbose)
-.TP
-\fB-match <matchList>\fR
-only run tests that match one or more of the glob patterns in
-<matchList>. (::tcltest::match)
-.TP
-\fB-skip <skipList>\fR
-do not run tests that match one or more of the glob patterns in
-<skipList>. (::tcltest::skip)
-.TP
-\fB-file <globPatternList>\fR
-only source test files that match any of the items in
-<globPatternList> relative to ::tcltest::testsDirectory.
-This option
-only makes sense if you are running tests using "all.tcl" as the
-<testFile> instead of running single test files directly.
-(::tcltest::matchFiles)
-.TP
-\fB-notfile <globPatternList>\fR
-source files except for those that match any of the items in
-<globPatternList> relative to ::tcltest::testsDirectory.
-This option
-only makes sense if you are running tests using "all.tcl" as the
-<testFile> instead of running single test files directly.
-(::tcltest::skipFiles)
-.TP
-\fB-constraints <list>\fR
-tests with any constraints in <list> will not be skipped. Note that
-elements of <list> must exactly match the existing constraints. This
-is useful if you want to make sure that tests with a particular
-constraint are run (for example, if the tester wants to run all tests
-with the knownBug constraint).
-(::tcltest::testConstraints(\fIconstraintName\fR))
-.TP
-\fB-limitconstraints <bool>\fR
-If the argument to this flag is 1, the test harness limits test runs
-to those tests that match the constraints listed by the -constraints
-flag. Use of this flag requires use of the -constraints flag. The
-default value for this flag is 0 (false). This is useful if you want
-to run \fBonly\fR those tests that match the constraints listed using
-the -constraints option. A tester might want to do this if he were
-interested in running only those tests that are constrained to be
-unixOnly and no other tests.
-(::tcltest::limitConstraints)
-.TP
-\fB-load <script>\fR
-will use the specified script to load the commands under test
-(::tcltest::loadTestedCommands). The default is the empty
-script. See -loadfile below too. (::tcltest::loadScript)
-.TP
-\fB-loadfile <scriptfile>\fR
-will use the contents of the named file to load the commands under
-test (::tcltest::loadTestedCommands). See -load above too. The default
-is the empty script. (::tcltest::loadScript)
-.TP
-\fB-tmpdir <directoryName>\fR
-put any temporary files (created with ::tcltest::makeFile and
-::tcltest::makeDirectory) into the named directory. The default
-location is ::tcltest::workingDirectory. (::tcltest::temporaryDirectory)
-.TP
-\fB-testdir <directoryName>\fR
-search the test suite to execute in the named directory. The default
-location is ::tcltest::workingDirectory. (::tcltest::testsDirectory)
-.TP
-\fB-preservecore <level>\fR
-check for core files. This flag is used to determine how much
-checking should be done for core files. The default value for
-\fIlevel\fR is 0. Levels are defined as:
-.RS
-.IP 0
-No checking - do not check for core files at the end of each test
-command, but do check for them whenever ::tcltest::cleanupTests is
-called from an all.tcl file.
-.IP 1
-Check for core files at the end of each test command and whenever
-::tcltest::cleanupTests is called from all.tcl.
-.IP 2
-Check for core files at the end of all test commands and whenever
-::tcltest::cleanupTests is called from all.tcl. Save any core files
-produced in ::tcltest::temporaryDirectory.
-.RE
-.sp
-(::tcltest::preserveCore)
-.TP
-\fB-debug <debugLevel>\fR
-print debug information to stdout. This is used to debug code in the
-test harness. The default debug level is 0. Levels are defined as:
+test can only be run if [\fBinterpreter\fR] can be [\fBopen\fR]ed
+as a pipe.
+.PP
+The alternative mode of constraint control is enabled by setting
+[\fBconfigure -limitconstraints\fR] to true. With that configuration
+setting, all existing constraints other than those in the constraint
+list returned by [\fBconfigure -constraints\fR] are set to false.
+When the value of [\fBconfigure -constraints\fR]
+is set, all those constraints are set to true. The effect is that
+when both options [\fBconfigure -constraints\fR] and
+[\fBconfigure -limitconstraints\fR] are in use, only those tests including
+only constraints from the [\fBconfigure -constraints\fR] list
+are run; all others are skipped. For example, one might set
+up a configuration with
+.CS
+configure -constraints knownBug \e
+ -limitconstraints true \e
+ -verbose pass
+.CE
+to run exactly those tests that exercise known bugs, and discover
+whether any of them pass, indicating the bug had been fixed.
+.SH "RUNNING ALL TESTS"
+.PP
+The single command [\fBrunAllTests\fR] is evaluated to run an entire
+test suite, spanning many files and directories. The configuration
+options of \fBtcltest\fR control the precise operations. The
+[\fBrunAllTests\fR] command begins by printing a summary of its
+configuration to [\fBoutputChannel\fR].
+.PP
+Test files to be evaluated are sought in the directory
+[\fBconfigure -testdir\fR]. The list of files in that directory
+that match any of the patterns in [\fBconfigure -file\fR] and
+match none of the patterns in [\fBconfigure -notfile\fR] is generated
+and sorted. Then each file will be evaluated in turn. If
+[\fBconfigure -singleproc\fR] is true, then each file will
+be [\fBsource\fR]d in the caller's context. If if is false,
+then a copy of [\fBinterpreter\fR] will be [\fBexec\fR]d to
+evaluate each file. The multi-process operation is useful
+when testing can cause errors so severe that a process
+terminates. Although such an error may terminate a child
+process evaluating one file, the master process can continue
+with the rest of the test suite. In multi-process operation,
+the configuration of \fBtcltest\fR in the master process is
+passed to the child processes as command line arguments,
+with the exception of [\fBconfigure -outfile\fR]. The
+[\fBrunAllTests\fR] command in the
+master process collects all output from the child processes
+and collates their results into one master report. Any
+reports of individual test failures, or messages requested
+by a [\fBconfigure -verbose\fR] setting are passed directly
+on to [\fBoutputChannel\fR] by the master process.
+.PP
+After evaluating all selected test files, a summary of the
+results is printed to [\fBoutputChannel\fR]. The summary
+includes the total number of [\fBtest\fR]s evaluated, broken
+down into those skipped, those passed, and those failed.
+The summary also notes the number of files evaluated, and the names
+of any files with failing tests or errors. A list of
+the constraints that caused tests to be skipped, and the
+number of tests skipped for each is also printed. Also,
+messages are printed if it appears that evaluation of
+a test file has caused any temporary files to be left
+behind in [\fBconfigure -tmpdir\fR].
+.PP
+Having completed and summarized all selected test files,
+[\fBrunAllTests\fR] then recursively acts on subdirectories
+of [\fBconfigure -testdir\fR]. All subdirectories that
+match any of the patterns in [\fBconfigure -relateddir\fR]
+and do not match any of the patterns in
+[\fBconfigure -asidefromdir\fR] are examined. If
+a file named \fBall.tcl\fR is found in such a directory,
+it will be [\fBsource\fR]d in the caller's context.
+Whether or not an examined directory contains an
+\fBall.tcl\fR file, its subdirectories are also scanned
+against the [\fBconfigure -relateddir\fR] and
+[\fBconfigure -asidefromdir\fR] patterns. In this way,
+many directories in a directory tree can have all their
+test files evaluated by a single [\fBrunAllTests\fR]
+command.
+.SH "CONFIGURABLE OPTIONS"
+The [\fBconfigure\fR] command is used to set and query the configurable
+options of \fBtcltest\fR. The valid options are:
+.TP
+\fB-singleproc \fIboolean\fR
+Controls whether or not [\fBrunAllTests\fR] spawns a child process for
+each test file. No spawning when \fIboolean\fR is true. Default
+value is false.
+.TP
+\fB-debug \fIlevel\fR
+Sets the debug level to \fIlevel\fR, an integer value indicating how
+much debugging information should be printed to stdout. Note that
+debug messages always go to stdout, independent of the value of
+[\fBconfigure -outfile\fR]. Default value is 0. Levels are defined as:
.RS
.IP 0
Do not display any debug information.
.IP 1
Display information regarding whether a test is skipped because it
-doesn't match any of the tests that were specified using -match or
-::tcltest::match (userSpecifiedNonMatch) or matches any of the tests
-specified by -skip or ::tcltest::skip (userSpecifiedSkip).
+doesn't match any of the tests that were specified using by
+[\fBconfigure -match\fR] (userSpecifiedNonMatch) or matches any of
+the tests specified by [\fBconfigure -skip\fR] (userSpecifiedSkip). Also
+print warnings about possible lack of cleanup or balance in test files.
.IP 2
Display the flag array parsed by the command line processor, the
contents of the ::env array, and all user-defined variables that exist
Display information regarding what individual procs in the test
harness are doing.
.RE
-.sp
-(::tcltest::debug)
-.TP
-\fB-outfile <filename>\fR
-print output generated by the tcltest package to the named file. This
-defaults to stdout. Note that debug output always goes to stdout,
-regardless of this flag's setting. (::tcltest::outputChannel)
.TP
-\fB-errfile <filename>\fR
-print errors generated by the tcltest package to the named file. This
-defaults to stderr. (::tcltest::errorChannel)
+\fB-verbose \fIlevel\fR
+Sets the type of output verbosity desired to \fIlevel\fR,
+a list of zero or more of the elements \fBbody\fR, \fBpass\fR,
+\fBskip\fR, \fBstart\fR, and \fBerror\fR. Default value is \fBbody\fR.
+Levels are defined as:
+.RS
+.IP "body (b)"
+Display the body of failed tests
+.IP "pass (p)"
+Print output when a test passes
+.IP "skip (s)"
+Print output when a test is skipped
+.IP "start (t)"
+Print output whenever a test starts
+.IP "error (e)"
+Print errorInfo and errorCode, if they exist, when a test return code
+does not match its expected return code
.RE
+The single letter abbreviations noted above are also recognized
+so that [\fBconfigure -verbose pt\fR] is the same as
+[\fBconfigure -verbose {pass start}\fR].
+.TP
+\fB-preservecore \fIlevel\fR
+Sets the core preservation level to \fIlevel\fR. This level
+determines how stringent checks for core files are. Default
+value is 0. Levels are defined as:
+.RS
+.IP 0
+No checking - do not check for core files at the end of each test
+command, but do check for them in [\fBrunAllTests\fR] after all
+test files have been evaluated.
+.IP 1
+Also check for core files at the end of each [\fBtest\fR] command.
+.IP 2
+Check for core files at all times described above, and save a
+copy of each core file produced in [\fBconfigure -tmpdir\fR].
+.RE
+.TP
+\fB-limitconstraints \fIboolean\fR
+Sets the mode by which [\fBtest\fR] honors constraints as described
+in \fBTESTS\fR above. Default value is false.
+.TP
+\fB-constraints \fIlist\fR
+Sets all the constraints in \fIlist\fR to true. Also used in
+combination with [\fBconfigure -limitconstraints true\fR] to control an
+alternative constraint mode as described in \fBTESTS\fR above.
+Default value is an empty list.
+.TP
+\fB-tmpdir \fIdirectory\fR
+Sets the temporary directory to be used by [\fBmakeFile\fR],
+[\fBmakeDirectory\fR], [\fBviewFile\fR], [\fBremoveFile\fR],
+and [\fBremoveDirectory\fR] as the default directory where
+temporary files and directories created by test files should
+be created. Default value is [\fBworkingDirectory\fR].
+.TP
+\fB-testdir \fIdirectory\fR
+Sets the directory searched by [\fBrunAllTests\fR] for test files
+and subdirectories. Default value is [\fBworkingDirectory\fR].
+.TP
+\fB-file \fIpatternList\fR
+Sets the list of patterns used by [\fBrunAllTests\fR] to determine
+what test files to evaluate. Default value is \fB*.test\fR.
+.TP
+\fB-notfile \fIpatternList\fR
+Sets the list of patterns used by [\fBrunAllTests\fR] to determine
+what test files to skip. Default value is \fBl.*.test\fR, so
+that any SCCS lock files are skipped.
+.TP
+\fB-relateddir \fIpatternList\fR
+Sets the list of patterns used by [\fBrunAllTests\fR] to determine
+what subdirectories to search for an \fBall.tcl\fR file. Default
+value is \fB*\fR.
+.TP
+\fB-asidefromdir \fIpatternList\fR
+Sets the list of patterns used by [\fBrunAllTests\fR] to determine
+what subdirectories to skip when searching for an \fBall.tcl\fR file.
+Default value is an empty list.
+.TP
+\fB-match \fIpatternList\fR
+Set the list of patterns used by [\fBtest\fR] to determine whether
+a test should be run. Default value is \fB*\fR.
+.TP
+\fB-skip \fIpatternList\fR
+Set the list of patterns used by [\fBtest\fR] to determine whether
+a test should be skipped. Default value is an empty list.
+.TP
+\fB-load \fIscript\fR
+Sets a script to be evaluated by [\fBloadTestedCommands\fR].
+Default value is an empty script.
+.TP
+\fB-loadfile \fIfilename\fR
+Sets the filename from which to read a script to be evaluated
+by [\fBloadTestedCommands\fR]. This is an alternative to
+\fB-load\fR. They cannot be used together.
+.TP
+\fB-outfile \fIfilename\fR
+Sets the file to which all output produced by tcltest should be
+written. A file named \fIfilename\fR will be [\fBopen\fR]ed for writing,
+and the resulting channel will be set as the value of [\fBoutputChannel\fR].
+.TP
+\fB-errfile \fIfilename\fR
+Sets the file to which all error output produced by tcltest
+should be written. A file named \fIfilename\fR will be [\fBopen\fR]ed
+for writing, and the resulting channel will be set as the value
+of [\fBerrorChannel\fR].
+.SH "CREATING TEST SUITES WITH TCLTEST"
.PP
-A second way to run tets is to start up a shell, load the
-\fBtcltest\fR package, and then source an appropriate test file or use
-the test command. To use the options in interactive mode, set
-their corresponding tcltest namespace variables after loading the
-package.
-.PP
-See \fI"Test Constraints"\fR for all built-in constraint names
-that can be used in the \fB::tcltest::testConstraints\fR array.
-See \fI"Tcltest namespace variables"\fR for details on other variables
-defined in the \fBtcltest\fR namespace.
-.PP
-A final way to run tests would be to specify which test files to run
-within an \fIall.tcl\fR (or otherwise named) file. This is the
-approach used by the Tcl test suite. This file loads the tcltest
-package, sets the location of
-the test directory (::tcltest::testsDirectory), determines which test
-files to run, sources each of these files, calls
-::tcltest::cleanupTests and then exits.
-.PP
-A more elaborate \fIall.tcl\fR file might do some pre- and
-post-processing before sourcing
-each .test file, use separate interpreters for each file, or handle
-complex directory structures.
-For an example of an all.tcl file,
-please see the "Examples" section of this document.
-.SH "TEST OUTPUT"
-After all specified test files are run, the number of tests
-passed, skipped, and failed is printed to
-\fB::tcltest::outputChannel\fR. Aside from this
-statistical information, output can be controlled on a per-test basis
-by the \fB::tcltest::verbose\fR variable.
-.PP
-\fB::tcltest::verbose\fR can be set to any substring or permutation
-of "bps". In the string "bps", the 'b' stands for a test's "body",
-the 'p' stands for "passed" tests, and the 's' stands for "skipped"
-tests. The default value of \fB::tcltest::verbose\fR is "b". If 'b'
-is present, then the entire body of the test is printed for each
-failed test, otherwise only the test's name, desired output, and
-actual output, are printed for each failed test. If 'p' is present,
-then a line is printed for each passed test, otherwise no line is
-printed for passed tests. If 's' is present, then a line (containing
-the consraints that cause the test to be skipped) is printed for each
-skipped test, otherwise no line is printed for skipped tests.
-.PP
-You can set \fB::tcltest::verbose\fR either interactively (after the
-\fBtcltest\fR package has been loaded) or by using the command line
-argument \fB-verbose\fR, for example:
-.DS
-tclsh socket.test -verbose bps
-.DE
-.SH "CONTENTS OF A TEST FILE"
-Test files should begin by loading the \fBtcltest\fR package:
-.DS
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import ::tcltest::*
-}
-.DE
-Test files should end by cleaning up after themselves and calling
-\fB::tcltest::cleanupTests\fR. The \fB::tcltest::cleanupTests\fR
-procedure prints statistics about the number of tests that passed,
-skipped, and failed, and removes all files that were created using the
-\fB::tcltest::makeFile\fR and \fB::tcltest::makeDirectory\fR procedures.
-.DS
-# Remove files created by these tests
-# Change to original working directory
-# Unset global arrays
-::tcltest::cleanupTests
-return
-.DE
-When naming test files, file names should end with a .test extension.
-The names of test files that contain regression (or glass-box) tests
-should correspond to the Tcl or C code file that they are testing.
-For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test".
-Test files that contain black-box tests should match the pattern "*_bb.test".
-.SH "SELECTING TESTS FOR EXECUTION WITHIN A FILE"
-.PP
-Normally, all the tests in a file are run whenever the file is
-sourced. An individual test will be skipped if one of the following
-conditions is met:
+The fundamental element of a test suite is the individual [\fBtest\fR]
+command. We begin with several examples.
.IP [1]
-the \fIname\fR of the tests does not match (using glob style matching)
-one or more elements in the \fB::tcltest::match\fR variable
+Test of a script that returns normally.
+.CS
+test example-1.0 {normal return} {
+ format %s value
+} value
+.CE
.IP [2]
-the \fIname\fR of the tests matches (using glob style matching) one or
-more elements in the \fB::tcltest::skip\fR variable
+Test of a script that requires context setup and cleanup. Note the
+bracing and indenting style that avoids any need for line continuation.
+.CS
+test example-1.1 {test file existence} -setup {
+ set file [makeFile {} test]
+} -body {
+ file exists $file
+} -cleanup {
+ removeFile test
+} -result 1
+.CE
.IP [3]
-the \fIconstraints\fR argument to the \fB::tcltest::test\fR call, if
-given, contains one or more false elements.
-.PP
-You can set \fB::tcltest::match\fR and/or \fB::tcltest::skip\fR
-either interactively (after the \fBtcltest\fR package has been
-sourced), or by using the command line arguments \fB-match\fR and
-\fB-skip\fR, for example:
+Test of a script that raises an error.
+.CS
+test example-1.2 {error return} -body {
+ error message
+} -returnCodes error -result message
+.CE
+.IP [4]
+Test with a constraint.
+.CS
+test example-1.3 {user owns created files} -constraints {
+ unix
+} -setup {
+ set file [makeFile {} test]
+} -body {
+ file attributes $file -owner
+} -cleanup {
+ removeFile test
+} -result $::tcl_platform(user)
+.CE
.PP
+At the next higher layer of organization, several [\fBtest\fR] commands
+are gathered together into a single test file. Test files should have
+names with the \fB.test\fR extension, because that is the default pattern
+used by [\fBrunAllTests\fR] to find test files. It is a good rule of
+thumb to have one test file for each source code file of your project.
+It is good practice to edit the test file and the source code file
+together, keeping tests synchronized with code changes.
+.PP
+Most of the code in the test file should be the [\fBtest\fR] commands.
+Use constraints to skip tests, rather than conditional evaluation
+of [\fBtest\fR]. That is, do this:
+.IP [5]
+.CS
+testConstraint X [expr $myRequirement]
+test goodConditionalTest {} X {
+ # body
+} result
+.CE
+and do not do this:
+.IP [6]
.CS
-tclsh info.test -match '*-5.* *-7.*' -skip '*-7.1*'
+if $myRequirement {
+ test badConditionalTest {} {
+ #body
+ } result
+}
.CE
.PP
-Be sure to use the proper quoting convention so that your shell does
-not perform the glob substitution on the match or skip patterns you
-specify.
+Use the \fB-setup\fR and \fB-cleanup\fR options to establish and release
+all context requirements of the test body. Do not make tests depend on
+prior tests in the file. Those prior tests might be skipped. If several
+consecutive tests require the same context, the appropriate setup
+and cleanup scripts may be stored in variable for passing to each tests
+\fB-setup\fR and \fB-cleanup\fR options. This is a better solution than
+performing setup outside of [\fBtest\fR] commands, because the setup will
+only be done if necessary, and any errors during setup will be reported,
+and not cause the test file to abort.
.PP
-Predefined constraints (e.g. \fIknownBug\fR and \fInonPortable\fR) can be
-overridden either interactively (after the \fBtcltest\fR package has been
-sourced) by setting the proper
-\fB::tcltest::testConstraints(\fIconstraint\fB)\fR variable
-or by using the \fB-constraints\fR command line option with the name of the
-constraint in the argument. The following example shows how to run
-tests that are constrained by the \fIknownBug\fR and \fInonPortable\fR
-restrictions:
+A test file should be able to be combined with other test files and not
+interfere with them, even when [\fBconfigure -singleproc 1\fR] causes
+all files to be evaluated in a common interpreter. A simple way to
+achieve this is to have your tests define all their commands and variables
+in a namespace that is deleted when the test file evaluation is complete.
+A good namespace to use is a child namespace \fBtest\fR of the namespace
+of the module you are testing.
.PP
+A test file should also be able to be evaluated directly as a script,
+not depending on being called by a master [\fBrunAllTests\fR]. This
+means that each test file should process command line arguments to give
+the tester all the configuration control that \fBtcltest\fR provides.
+.PP
+After all [\fBtest\fR]s in a test file, the command [\fBcleanupTests\fR]
+should be called.
+.IP [7]
+Here is a sketch of a sample test file illustrating those points:
.CS
-tclsh all.tcl -constraints "knownBug nonPortable"
+package require tcltest 2.2
+eval tcltest::configure $argv
+package require example
+namespace eval ::example::test {
+ namespace import ::tcltest::*
+ testConstraint X [expr {...}]
+ variable SETUP {#common setup code}
+ variable CLEANUP {#common cleanup code}
+ test example-1 {} -setup $SETUP {
+ # First test
+ } -cleanup $CLEANUP -result {...}
+ test example-2 {} -constraints X -setup $SETUP {
+ # Second test; constrained
+ } -cleanup $CLEANUP -result {...}
+ test example-3 {} {
+ # Third test; no context required
+ } {...}
+ cleanupTests
+}
+namespace delete ::example::test
.CE
.PP
-See the \fI"Constraints"\fR package for information about using
-built-in constraints and adding new ones.
-.SH "HOW TO CUSTOMIZE THE TEST HARNESS"
-To create your own custom test harness, create a .tcl file that contains your
-namespace. Within this file, require package \fBtcltest\fR. Commands
-that can be redefined to customize the test harness include:
-.TP
-\fB::tcltest::PrintUsageInfoHook\fP
-print additional usage information specific to your situation.
-.TP
-\fB::tcltest::processCmdLineArgsFlagHook\fP
-tell the test harness about additional flags that you want it to understand.
-.TP
-\fB::tcltest::processCmdLineArgsHook\fR \fIflags\fP
-process the additional flags that you told the harness about in
-::tcltest::processCmdLineArgsFlagHook.
-.TP
-\fB::tcltest::initConstraintsHook\fP
-used to add additional built-in constraints to those already defined
-by \fBtcltest\fR.
-.TP
-\fB::tcltest::cleanupTestsHook\fP
-do additional cleanup
-.PP
+The next level of organization is a full test suite, made up of several
+test files. One script is used to control the entire suite. The
+basic function of this script is to call [\fBrunAllTests\fR] after
+doing any necessary setup. This script is usually named \fBall.tcl\fR
+because that's the default name used by [\fBrunAllTests\fR] when combining
+multiple test suites into one testing run.
+.IP [8]
+Here is a sketch of a sample test suite master script:
+.CS
+package require Tcl 8.4
+package require tcltest 2.2
+package require example
+tcltest::configure -testdir \
+ [file dir [file normalize [info script]]]
+eval tcltest::configure $argv
+tcltest::runAllTests
+.CE
+.SH COMPATIBILITY
.PP
-To add new flags to your customized test harness, redefine
-\fB::tcltest::processCmdLineArgsAddFlagHook\fR to define additional flags to be
-parsed and \fB::tcltest::processCmdLineArgsHook\fR to actually process them.
-For example:
-.DS
-proc ::tcltest::processCmdLineArgsAddFlagHook {} {
- return [list -flag1 -flag2]
-}
-
-proc ::tcltest::processCmdLineArgsHook {flagArray} {
- array set flag $flagArray
-
- if {[info exists flag(-flag1)]} {
- # Handle flag1
- }
-
- if {[info exists flag(-flag2)]} {
- # Handle flag2
+A number of commands and variables in the \fB::tcltest\fR namespace
+provided by earlier releases of \fBtcltest\fR have not been documented
+here. They are no longer part of the supported public interface of
+\fBtcltest\fR and should not be used in new test suites. However,
+to continue to support existing test suites written to the older
+interface specifications, many of those deprecated commands and
+variables still work as before. For example, in many circumstances,
+[\fBconfigure\fR] will be automatically called shortly after
+[\fBpackage require tcltest 2.1\fR] succeeds with arguments
+from the variable \fB::argv\fR. This is to support test suites
+that depend on the old behavior that \fBtcltest\fR was automatically
+configured from command line arguments. New test files should not
+depend on this, but should explicitly include
+.CS
+eval tcltest::configure $::argv
+.CE
+to establish a configuration from command line arguments.
+.SH "KNOWN ISSUES"
+There are two known issues related to nested evaluations of [\fBtest\fR].
+The first issue relates to the stack level in which test scripts are
+executed. Tests nested within other tests may be executed at the same
+stack level as the outermost test. For example, in the following code:
+.CS
+test level-1.1 {level 1} {
+ -body {
+ test level-2.1 {level 2} {
+ }
}
-
- return
}
-.DE
-You may also want to add usage information for these flags. This
-information would be displayed whenever the user specifies -help. To
-define additional usage information, define your own
-::tcltest::PrintUsageInfoHook proc. Within this proc, you should
-print out additional usage information for any flags that you've
-implemented.
+.CE
+any script executed in level-2.1 may be executed at the same stack
+level as the script defined for level-1.1.
.PP
-To add new built-in
-constraints to the test harness, define your own version of
-\fB::tcltest::initConstraintsHook\fR.
-Within your proc, you can add to the \fB::tcltest::testConstraints\fR array.
-For example:
-.DS
-proc ::tcltest::initConstraintsHook {} {
- set ::tcltest::testConstraints(win95Or98) \\
- [expr {$::tcltest::testConstraints(95) || \\
- $::tcltest::testConstraints(98)}]
-}
-.DE
+In addition, while two [\fBtest\fR]s have been run, results will only
+be reported by [\fBcleanupTests\fR] for tests at the same level as
+test level-1.1. However, test results for all tests run prior to
+level-1.1 will be available when test level-2.1 runs. What this
+means is that if you try to access the test results for test level-2.1,
+it will may say that 'm' tests have run, 'n' tests have
+been skipped, 'o' tests have passed and 'p' tests have failed,
+where 'm', 'n', 'o', and 'p' refer to tests that were run at the
+same test level as test level-1.1.
.PP
-Finally, if you want to add additional cleanup code to your harness
-you can define your own \fB::tcltest::cleanupTestsHook\fR. For example:
-.DS
-proc ::tcltest::cleanupTestsHook {} {
- # Add your cleanup code here
-}
-.DE
-.SH EXAMPLES
-.IP [1]
-A simple test file (foo.test)
-.DS
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import ::tcltest::*
-}
-
-test foo-1.1 {save 1 in variable name foo} {} {
- set foo 1
-} {1}
+Implementation of output and error comparison in the test command
+depends on usage of puts in your application code. Output is
+intercepted by redefining the puts command while the defined test
+script is being run. Errors thrown by C procedures or printed
+directly from C applications will not be caught by the test command.
+Therefore, usage of the \fB-output\fR and \fB-errorOuput\fR
+options to [\fBtest\fR] is useful only for pure Tcl applications
+that use [\fBputs\fR] to produce output.
-::tcltest::cleanupTests
-return
-.DE
-.IP [2]
-A simple all.tcl
-.DS
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import ::tcltest::*
-}
-
-set ::tcltest::testSingleFile false
-set ::tcltest::testsDirectory [file dir [info script]]
-
-foreach file [::tcltest::getMatchingTestFiles] {
- if {[catch {source $file} msg]} {
- puts stdout $msg
- }
-}
-
-::tclttest::cleanupTests 1
-return
-.DE
-.IP [3]
-Running a single test
-.DS
-tclsh foo.test
-.DE
-.IP [4]
-Running multiple tests
-.DS
-tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test'
-.DE
.SH KEYWORDS
test, test harness, test suite
-
PATH variable could be exported by the operating system as ``path'',
``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to
support many special cases. All other environment variables inherited by
-Tcl are left unmodified.
+Tcl are left unmodified. Setting an env array variable to blank is the
+same as unsetting it as this is the behavior of the underlying Windows OS.
+It should be noted that relying on an existing and empty environment variable
+won't work on windows and is discouraged for cross-platform usage.
.VE
.RE
.RS
\fBSTART_UP_FOLDER\fR
The path to the start up directory.
.TP
-\fBPWD\fR
+\fBHOME\fR
The path to the application's default directory.
.PP
You can also create your own environment variables for the Macintosh.
and applications may add additional values to the array. The
predefined elements are:
-
-
-
-
.RS
.VS
.TP
.TP
\fBdebug\fR
If this variable exists, then the interpreter
-was compiled with debugging symbols enabled. This varible will only
+was compiled with debugging symbols enabled. This variable will only
exist on Windows so extension writers can specify which package to load
depending on the C run-time library that is loaded.
.TP
current user based on the login information available on the platform.
This comes from the USER or LOGNAME environment variable on Unix,
and the value from GetUserName on Windows and Macintosh.
+.TP
+\fBwordSize\fR
+.VS 8.4
+This gives the size of the native-machine word in bytes (strictly, it
+is same as the result of evaluating \fIsizeof(long)\fR in C.)
+.VE 8.4
.RE
.TP
\fBtcl_precision\fR
tracking down suspected problems with the Tcl compiler.
It is also occasionally useful when converting
existing code to use Tcl8.0.
+
+This variable and functionality only exist if
+TCL_COMPILE_DEBUG was defined during Tcl's compilation.
.TP
\fBtcl_traceExec\fR
The value of this variable can be set to control
and interpreter.
It is also occasionally useful when converting
code to use Tcl8.0.
+
+This variable and functionality only exist if
+TCL_COMPILE_DEBUG was defined during Tcl's compilation.
.TP
\fBtcl_wordchars\fR
The value of this variable is a regular expression that can be set to
The value of this variable is returned by the \fBinfo tclversion\fR
command.
+.SH "SEE ALSO"
+eval(n)
+
.SH KEYWORDS
arithmetic, bytecode, compiler, error, environment, POSIX, precision, subprocess, variables
.VE 8.1
The value returned is -1 for channels that do not support
seeking.
+.PP
+.VS
+\fIChannelId\fR must be an identifier for an open channel such as a
+Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
+the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
+the result of a channel creation command provided by a Tcl extension.
+.VE
+
+.SH "SEE ALSO"
+file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3)
.SH KEYWORDS
access position, channel, seeking
in microseconds.
Time is measured in elapsed time, not CPU time.
+.SH "SEE ALSO"
+clock(n)
+
.SH KEYWORDS
script, time
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH trace n "" Tcl "Tcl Built-In Commands"
+.TH trace n "8.4" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-trace \- Monitor variable accesses
+trace \- Monitor variable accesses, command usages and command executions
.SH SYNOPSIS
\fBtrace \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command causes Tcl commands to be executed whenever certain operations are
-invoked. At present, only variable tracing is implemented. The
-legal \fIoption\fR's (which may be abbreviated) are:
+invoked. The legal \fIoption\fR's (which may be abbreviated) are:
.TP
-\fBtrace variable \fIname ops command\fR
+\fBtrace add \fItype name ops ?args?\fR
+Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR.
+.RS
+.TP
+\fBtrace add command\fR \fIname ops command\fR
+Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
+is modified in one of the ways given by the list \fIops\fR. \fIName\fR will be
+resolved using the usual namespace resolution rules used by
+procedures. If the command does not exist, an error will be thrown.
+.RS
+.PP
+\fIOps\fR indicates which operations are of interest, and is a list of
+one or more of the following items:
+.TP
+\fBrename\fR
+Invoke \fIcommand\fR whenever the command is renamed. Note that
+renaming to the empty string is considered deletion, and will not
+be traced with '\fBrename\fR'.
+.TP
+\fBdelete\fR
+Invoke \fIcommand\fR when the command is deleted. Commands can be
+deleted explicitly by using the \fBrename\fR command to rename the
+command to an empty string. Commands are also deleted when the
+interpreter is deleted, but traces will not be invoked because there is no
+interpreter in which to execute them.
+.PP
+When the trace triggers, depending on the operations being traced, a
+number of arguments are appended to \fIcommand\fR so that the actual
+command is as follows:
+.CS
+\fIcommand oldName newName op\fR
+.CE
+\fIOldName\fR and \fInewName\fR give the traced command's current
+(old) name, and the name to which it is being renamed (the empty
+string if this is a 'delete' operation).
+\fIOp\fR indicates what operation is being performed on the
+command, and is one of \fBrename\fR or \fBdelete\fR as
+defined above. The trace operation cannot be used to stop a command
+from being deleted. Tcl will always remove the command once the trace
+is complete. Recursive renaming or deleting will not cause further traces
+of the same type to be evaluated, so a delete trace which itself
+deletes the command, or a rename trace which itself renames the
+command will not cause further trace evaluations to occur.
+.RE
+.TP
+\fBtrace add execution\fR \fIname ops command\fR
+Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
+is modified in one of the ways given by the list \fIops\fR. \fIName\fR will be
+resolved using the usual namespace resolution rules used by
+procedures. If the command does not exist, an error will be thrown.
+.RS
+.PP
+\fIOps\fR indicates which operations are of interest, and is a list of
+one or more of the following items:
+.TP
+\fBenter\fR
+Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
+just before the actual execution takes place.
+.TP
+\fBleave\fR
+Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
+just after the actual execution takes place.
+.TP
+\fBenterstep\fR
+Invoke \fIcommand\fR for every tcl command which is executed
+inside the procedure \fIname\fR, just before the actual execution
+takes place. For example if we have 'proc foo {} { puts "hello" }',
+then a \fIenterstep\fR trace would be
+invoked just before \fIputs "hello"\fR is executed.
+Setting a \fIenterstep\fR trace on a \fIcommand\fR
+will not result in an error and is simply ignored.
+.TP
+\fBleavestep\fR
+Invoke \fIcommand\fR for every tcl command which is executed
+inside the procedure \fIname\fR, just after the actual execution
+takes place.
+Setting a \fIleavestep\fR trace on a \fIcommand\fR
+will not result in an error and is simply ignored.
+.PP
+When the trace triggers, depending on the operations being traced, a
+number of arguments are appended to \fIcommand\fR so that the actual
+command is as follows:
+
+For \fBenter\fR and \fBenterstep\fR operations:
+.CS
+\fIcommand command-string op\fR
+.CE
+\fICommand-string\fR gives the complete current command being
+executed (the traced command for a \fBenter\fR operation, an
+arbitrary command for a \fBenterstep\fR operation), including
+all arguments in their fully expanded form.
+\fIOp\fR indicates what operation is being performed on the
+command execution, and is one of \fBenter\fR or \fBenterstep\fR as
+defined above. The trace operation can be used to stop the
+command from executing, by deleting the command in question. Of
+course when the command is subsequently executed, an 'invalid command'
+error will occur.
+.TP
+For \fBleave\fR and \fBleavestep\fR operations:
+.CS
+\fIcommand command-string code result op\fR
+.CE
+\fICommand-string\fR gives the complete current command being
+executed (the traced command for a \fBenter\fR operation, an
+arbitrary command for a \fBenterstep\fR operation), including
+all arguments in their fully expanded form.
+\fICode\fR gives the result code of that execution, and \fIresult\fR
+the result string.
+\fIOp\fR indicates what operation is being performed on the
+command execution, and is one of \fBleave\fR or \fBleavestep\fR as
+defined above.
+Note that the creation of many \fBenterstep\fR or
+\fBleavestep\fR traces can lead to unintuitive results, since the
+invoked commands from one trace can themselves lead to further
+command invocations for other traces.
+
+\fICommand\fR executes in the same context as the code that invoked
+the traced operation: thus the \fIcommand\fR, if invoked from a procedure,
+will have access to the same local variables as code in the procedure.
+This context may be different than the context in which the trace was
+created. If \fIcommand\fR invokes a procedure (which it normally does)
+then the procedure will have to use upvar or uplevel commands if it wishes
+to access the local variables of the code which invoked the trace operation.
+
+While \fIcommand\fR is executing during an execution trace, traces
+on \fIname\fR are temporarily disabled. This allows the \fIcommand\fR
+to execute \fIname\fR in its body without invoking any other traces again.
+If an error occurs while executing the \fIcommand\fR body, then the
+\fIcommand\fR name as a whole will return that same error.
+
+When multiple traces are set on \fIname\fR, then for \fIenter\fR
+and \fIenterstep\fR operations, the traced commands are invoked
+in the reverse order of how the traces were originally created;
+and for \fIleave\fR and \fIleavestep\fR operations, the traced
+commands are invoked in the original order of creation.
+
+The behavior of execution traces is currently undefined for a command
+\fIname\fR imported into another namespace.
+.RE
+.TP
+\fBtrace add variable\fI name ops command\fR
Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR
-is accessed in one of the ways given by \fIops\fR. \fIName\fR may
+is accessed in one of the ways given by the list \fIops\fR. \fIName\fR may
refer to a normal variable, an element of an array, or to an array
as a whole (i.e. \fIname\fR may be just the name of an array, with no
parenthesized index). If \fIname\fR refers to a whole array, then
queries, but not to \fBinfo exists\fR queries.
.RS
.PP
-\fIOps\fR indicates which operations are of interest, and consists of
-one or more of the following letters:
+\fIOps\fR indicates which operations are of interest, and is a list of
+one or more of the following items:
+.TP
+\fBarray\fR
+Invoke \fIcommand\fR whenever the variable is accessed or modified via
+the \fBarray\fR command, provided that \fIname\fR is not a scalar
+variable at the time that the \fBarray\fR command is invoked. If
+\fIname\fR is a scalar variable, the access via the \fBarray\fR
+command will not trigger the trace.
.TP
-\fBr\fR
+\fBread\fR
Invoke \fIcommand\fR whenever the variable is read.
.TP
-\fBw\fR
+\fBwrite\fR
Invoke \fIcommand\fR whenever the variable is written.
.TP
-\fBu\fR
+\fBunset\fR
Invoke \fIcommand\fR whenever the variable is unset. Variables
can be unset explicitly with the \fBunset\fR command, or
implicitly when procedures return (all of their local variables
command allows a procedure to reference a variable under a
different name.
\fIOp\fR indicates what operation is being performed on the
-variable, and is one of \fBr\fR, \fBw\fR, or \fBu\fR as
+variable, and is one of \fBread\fR, \fBwrite\fR, or \fBunset\fR as
defined above.
.PP
\fICommand\fR executes in the same context as the code that invoked
-the traced operation: if the variable was accessed as part of a
-Tcl procedure, then \fIcommand\fR will have access to the same
-local variables as code in the procedure. This context may be
-different than the context in which the trace was created.
-If \fIcommand\fR invokes a procedure (which it normally does) then
-the procedure will have to use \fBupvar\fR or \fBuplevel\fR if it
-wishes to access the traced variable.
-Note also that \fIname1\fR may not necessarily be the same as the name
-used to set the trace on the variable; differences can occur if
-the access is made through a variable defined with the \fBupvar\fR
-command.
-.PP
-For read and write traces, \fIcommand\fR can modify
-the variable to affect the result of the traced operation.
-If \fIcommand\fR modifies the value of a variable during a
-read or write trace, then the new value will be returned as the
-result of the traced operation.
-The return value from \fIcommand\fR is ignored except that
-if it returns an error of any sort then the traced operation
-also returns an error with
-the same error message returned by the trace command
-(this mechanism can be used to implement read-only variables, for
-example).
-For write traces, \fIcommand\fR is invoked after the variable's
-value has been changed; it can write a new value into the variable
-to override the original value specified in the write operation.
-To implement read-only variables, \fIcommand\fR will have to restore
-the old value of the variable.
+the traced operation: if the variable was accessed as part of a Tcl
+procedure, then \fIcommand\fR will have access to the same local
+variables as code in the procedure. This context may be different
+than the context in which the trace was created. If \fIcommand\fR
+invokes a procedure (which it normally does) then the procedure will
+have to use \fBupvar\fR or \fBuplevel\fR if it wishes to access the
+traced variable. Note also that \fIname1\fR may not necessarily be
+the same as the name used to set the trace on the variable;
+differences can occur if the access is made through a variable defined
+with the \fBupvar\fR command.
+.PP
+For read and write traces, \fIcommand\fR can modify the variable to
+affect the result of the traced operation. If \fIcommand\fR modifies
+the value of a variable during a read or write trace, then the new
+value will be returned as the result of the traced operation. The
+return value from \fIcommand\fR is ignored except that if it returns
+an error of any sort then the traced operation also returns an error
+with the same error message returned by the trace command (this
+mechanism can be used to implement read-only variables, for example).
+For write traces, \fIcommand\fR is invoked after the variable's value
+has been changed; it can write a new value into the variable to
+override the original value specified in the write operation. To
+implement read-only variables, \fIcommand\fR will have to restore the
+old value of the variable.
.PP
While \fIcommand\fR is executing during a read or write trace, traces
-on the variable are temporarily disabled.
-This means that reads and writes invoked by
-\fIcommand\fR will occur directly, without invoking \fIcommand\fR
-(or any other traces) again.
-However, if \fIcommand\fR unsets the variable then unset traces
-will be invoked.
-.PP
-When an unset trace is invoked, the variable has already been
-deleted: it will appear to be undefined with no traces.
-If an unset occurs because of a procedure return, then the
-trace will be invoked in the variable context of the procedure
-being returned to: the stack frame of the returning procedure
-will no longer exist.
-Traces are not disabled during unset traces, so if an unset trace
-command creates a new trace and accesses the variable, the
-trace will be invoked.
-Any errors in unset traces are ignored.
-.PP
-If there are multiple traces on a variable they are invoked
-in order of creation, most-recent first.
-If one trace returns an error, then no further traces are
-invoked for the variable.
-If an array element has a trace set, and there is also a trace
-set on the array as a whole, the trace on the overall array
-is invoked before the one on the element.
-.PP
-Once created, the trace remains in effect either until the
-trace is removed with the \fBtrace vdelete\fR command described
-below, until the variable is unset, or until the interpreter
-is deleted.
-Unsetting an element of array will remove any traces on that
-element, but will not remove traces on the overall array.
+on the variable are temporarily disabled. This means that reads and
+writes invoked by \fIcommand\fR will occur directly, without invoking
+\fIcommand\fR (or any other traces) again. However, if \fIcommand\fR
+unsets the variable then unset traces will be invoked.
+.PP
+When an unset trace is invoked, the variable has already been deleted:
+it will appear to be undefined with no traces. If an unset occurs
+because of a procedure return, then the trace will be invoked in the
+variable context of the procedure being returned to: the stack frame
+of the returning procedure will no longer exist. Traces are not
+disabled during unset traces, so if an unset trace command creates a
+new trace and accesses the variable, the trace will be invoked. Any
+errors in unset traces are ignored.
+.PP
+If there are multiple traces on a variable they are invoked in order
+of creation, most-recent first. If one trace returns an error, then
+no further traces are invoked for the variable. If an array element
+has a trace set, and there is also a trace set on the array as a
+whole, the trace on the overall array is invoked before the one on the
+element.
+.PP
+Once created, the trace remains in effect either until the trace is
+removed with the \fBtrace remove variable\fR command described below,
+until the variable is unset, or until the interpreter is deleted.
+Unsetting an element of array will remove any traces on that element,
+but will not remove traces on the overall array.
.PP
This command returns an empty string.
.RE
+.RE
+.TP
+\fBtrace remove \fItype name opList command\fR
+Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR.
+.RS
+.TP
+\fBtrace remove command\fI name opList command\fR
+If there is a trace set on command \fIname\fR with the operations and
+command given by \fIopList\fR and \fIcommand\fR, then the trace is
+removed, so that \fIcommand\fR will never again be invoked. Returns
+an empty string. If \fIname\fR doesn't exist, the command will throw
+an error.
+.TP
+\fBtrace remove execution\fI name opList command\fR
+If there is a trace set on command \fIname\fR with the operations and
+command given by \fIopList\fR and \fIcommand\fR, then the trace is
+removed, so that \fIcommand\fR will never again be invoked. Returns
+an empty string. If \fIname\fR doesn't exist, the command will throw
+an error.
+.TP
+\fBtrace remove variable\fI name opList command\fR
+If there is a trace set on variable \fIname\fR with the operations and
+command given by \fIopList\fR and \fIcommand\fR, then the trace is
+removed, so that \fIcommand\fR will never again be invoked. Returns
+an empty string.
+.RE
+.TP
+\fBtrace info \fItype name\fR
+Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR.
+.RS
+.TP
+\fBtrace info command\fI name\fR
+Returns a list containing one element for each trace currently set on
+command \fIname\fR. Each element of the list is itself a list
+containing two elements, which are the \fIopList\fR and \fIcommand\fR
+associated with the trace. If \fIname\fR doesn't have any traces set,
+then the result of the command will be an empty string. If \fIname\fR
+doesn't exist, the command will throw an error.
+.TP
+\fBtrace info execution\fI name\fR
+Returns a list containing one element for each trace currently set on
+command \fIname\fR. Each element of the list is itself a list
+containing two elements, which are the \fIopList\fR and \fIcommand\fR
+associated with the trace. If \fIname\fR doesn't have any traces set,
+then the result of the command will be an empty string. If \fIname\fR
+doesn't exist, the command will throw an error.
+.TP
+\fBtrace info variable\fI name\fR
+Returns a list containing one element for each trace currently set on
+variable \fIname\fR. Each element of the list is itself a list
+containing two elements, which are the \fIopList\fR and \fIcommand\fR
+associated with the trace. If \fIname\fR doesn't exist or doesn't
+have any traces set, then the result of the command will be an empty
+string.
+.RE
+.PP
+For backwards compatibility, three other subcommands are available:
+.RS
+.TP
+\fBtrace variable \fIname ops command\fR
+This is equivalent to \fBtrace add variable \fIname ops command\fR.
.TP
\fBtrace vdelete \fIname ops command\fR
-If there is a trace set on variable \fIname\fR with the
-operations and command given by \fIops\fR and \fIcommand\fR,
-then the trace is removed, so that \fIcommand\fR will never
-again be invoked.
-Returns an empty string.
-.TP
-\fBtrace vinfo \fIname\fR
-Returns a list containing one element for each trace
-currently set on variable \fIname\fR.
-Each element of the list is itself a list containing two
-elements, which are the \fIops\fR and \fIcommand\fR associated
-with the trace.
-If \fIname\fR doesn't exist or doesn't have any traces set, then
-the result of the command will be an empty string.
+This is equivalent to \fBtrace remove variable \fIname ops command\fR
+.TP
+\fBtrace vinfo \fIname\fR
+This is equivalent to \fBtrace info variable \fIname\fR
+.RE
+.PP
+These subcommands are deprecated and will likely be removed in a
+future version of Tcl. They use an older syntax in which \fBarray\fR,
+\fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR,
+\fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a
+list, but simply a string concatenation of the operations, such as
+\fBrwua\fR.
+
+.SH "SEE ALSO"
+set(n), unset(n)
.SH KEYWORDS
-read, variable, write, trace, unset
+read, command, rename, variable, write, trace, unset
.SH DESCRIPTION
.PP
This command is invoked by the Tcl interpreter whenever a script
-tries to invoke a command that doesn't exist. The implementation
-of \fBunknown\fR isn't part of the Tcl core; instead, it is a
-library procedure defined by default when Tcl starts up. You
-can override the default \fBunknown\fR to change its functionality.
+tries to invoke a command that doesn't exist. The default implementation
+of \fBunknown\fR is a library procedure defined when Tcl initializes an
+interpreter. You can override the default \fBunknown\fR to change its
+functionality. Note that there is no default implementation of
+\fBunknown\fR in a safe interpreter.
.PP
If the Tcl interpreter encounters a command name for which there
is not a defined command, then Tcl checks for the existence of
is the return value from the command that was eventually
executed.
+.SH "SEE ALSO"
+info(n), proc(n), interp(n), library(n)
+
.SH KEYWORDS
error, non-existent command
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 2000 Ajuba Solutions.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" RCS: @(#) $Id$
'\"
.so man.macros
-.TH unset n "" Tcl "Tcl Built-In Commands"
+.TH unset n 8.4 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
unset \- Delete variables
.SH SYNOPSIS
-\fBunset \fIname \fR?\fIname name ...\fR?
+\fBunset \fR?\fI\-nocomplain\fR? ?\fI\-\-\fR? ?\fIname name name ...\fR?
.BE
.SH DESCRIPTION
If a \fIname\fR consists of an array name with no parenthesized
index, then the entire array is deleted.
The \fBunset\fR command returns an empty string as result.
-An error occurs if any of the variables doesn't exist, and any variables
-after the non-existent one are not deleted.
+.VS 8.4
+If \fI\-nocomplain\fR is specified as the first argument, any possible
+errors are suppressed. The option may not be abbreviated, in order to
+disambiguate it from possible variable names. The option \fI\-\-\fR
+indicates the end of the options, and should be used if you wish to
+remove a variable with the same name as any of the options.
+.VE 8.4
+If an error occurs, any variables after the named one causing the error not
+deleted. An error can occur when the named variable doesn't exist, or the
+name refers to an array element but the variable is a scalar, or the name
+refers to a variable in a non-existent namespace.
+
+.SH "SEE ALSO"
+set(n), trace(n)
.SH KEYWORDS
remove, variable
you occasionally call \fBupdate\fR then user input will be processed
during the next call to \fBupdate\fR.
+.SH "SEE ALSO"
+after(n), bgerror(n)
+
.SH KEYWORDS
event, flush, handler, idle, update
-
at top-level in the outermost namespace (the global namespace).
.SH "SEE ALSO"
-namespace(n)
+namespace(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variables
.VE
.SH "SEE ALSO"
-namespace(n)
+global(n), namespace(n), uplevel(n), variable(n)
.SH KEYWORDS
context, frame, global, level, namespace, procedure, variable
.PP
If the \fBvariable\fR command is executed inside a Tcl procedure,
it creates local variables
-linked to the corresponding namespace variables.
+linked to the corresponding namespace variables (and therefore these
+variables are listed by \fBinfo locals\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
only links to variables in the global namespace.
\fBset\fR or \fBarray\fR commands.
.SH "SEE ALSO"
-global(n), namespace(n)
+global(n), namespace(n), upvar(n)
.SH KEYWORDS
global, namespace, procedure, variable
blocked waiting for the event handler to complete, so it cannot
return either.
+.SH "SEE ALSO"
+global(n)
+
.SH KEYWORDS
event, variable, wait
}
.CE
+.SH "SEE ALSO"
+break(n), continue(n), for(n), foreach(n)
+
.SH KEYWORDS
boolean value, loop, test, while
+++ /dev/null
-1. No more [command1] [command2] construct for grouping multiple
-commands on a single command line.
-
-2. Semi-colon now available for grouping commands on a line.
-
-3. For a command to span multiple lines, must now use backslash-return
-at the end of each line but the last.
-
-4. "Var" command has been changed to "set".
-
-5. Double-quotes now available as an argument grouping character.
-
-6. "Return" may be used at top-level.
-
-7. More backslash sequences available now. In particular, backslash-newline
-may be used to join lines in command files.
-
-8. New or modified built-in commands: case, return, for, glob, info,
-print, return, set, source, string, uplevel.
-
-9. After an error, the variable "errorInfo" is filled with a stack
-trace showing what was being executed when the error occurred.
-
-10. Command abbreviations are accepted when parsing commands, but
-are not recommended except for purely-interactive commands.
-
-11. $, set, and expr all complain now if a non-existent variable is
-referenced.
-
-12. History facilities exist now. See Tcl.man and Tcl_RecordAndEval.man.
-
-13. Changed to distinguish between empty variables and those that don't
-exist at all. Interfaces to Tcl_GetVar and Tcl_ParseVar have changed
-(NULL return value is now possible). *** POTENTIAL INCOMPATIBILITY ***
-
-14. Changed meaning of "level" argument to "uplevel" command (1 now means
-"go up one level", not "go to level 1"; "#1" means "go to level 1").
-*** POTENTIAL INCOMPATIBILITY ***
+++ /dev/null
-/*
- * panic.c --
- *
- * Source code for the "panic" library procedure for Tcl;
- * individual applications will probably override this with
- * an application-specific panic procedure.
- *
- * Copyright (c) 1988-1993 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id$
- */
-
-#include <stdio.h>
-#ifdef NO_STDLIB_H
-# include "../compat/stdlib.h"
-#else
-# include <stdlib.h>
-#endif
-
-#define panic panicDummy
-#include "tcl.h"
-#undef panic
-
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLEXPORT
-
-EXTERN void panic _ANSI_ARGS_((char *format, char *arg1,
- char *arg2, char *arg3, char *arg4, char *arg5,
- char *arg6, char *arg7, char *arg8));
-
-/*
- * The panicProc variable contains a pointer to an application
- * specific panic procedure.
- */
-
-void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL;
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetPanicProc --
- *
- * Replace the default panic behavior with the specified functiion.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets the panicProc variable.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetPanicProc(proc)
- void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format));
-{
- panicProc = proc;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * panic --
- *
- * Print an error message and kill the process.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The process dies, entering the debugger if possible.
- *
- *----------------------------------------------------------------------
- */
-
- /* VARARGS ARGSUSED */
-void
-panic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8)
- char *format; /* Format string, suitable for passing to
- * fprintf. */
- char *arg1, *arg2, *arg3; /* Additional arguments (variable in number)
- * to pass to fprintf. */
- char *arg4, *arg5, *arg6, *arg7, *arg8;
-{
- if (panicProc != NULL) {
- (void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
- } else {
- (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6,
- arg7, arg8);
- (void) fprintf(stderr, "\n");
- (void) fflush(stderr);
- abort();
- }
-}
+++ /dev/null
-/*
- * patchlevel.h --
- *
- * This file does nothing except define a "patch level" for Tcl.
- * The patch level has the form "X.YpZ" where X.Y is the base
- * release, and Z is a serial number that is used to sequence
- * patches for a given release. Thus 7.4p1 is the first patch
- * to release 7.4, 7.4p2 is the patch that follows 7.4p1, and
- * so on. The "pZ" is omitted in an original new release, and
- * it is replaced with "bZ" for beta releases or "aZ for alpha
- * releases. The patch level ensures that patches are applied
- * in the correct order and only to appropriate sources.
- *
- * Copyright (c) 1993-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) patchlevel.h 1.17 96/04/08 14:15:07
- */
-
-#define TCL_PATCH_LEVEL "7.5"
*/
static struct cvec *
newcvec(nchrs, nranges, nmcces)
-int nchrs; /* to hold this many chrs... */
-int nranges; /* ... and this many ranges... */
-int nmcces; /* ... and this many MCCEs */
+ int nchrs; /* to hold this many chrs... */
+ int nranges; /* ... and this many ranges... */
+ int nmcces; /* ... and this many MCCEs */
{
- size_t n;
- size_t nc;
- struct cvec *cv;
+ size_t n;
+ size_t nc;
+ struct cvec *cv;
- nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2;
- n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) +
- nc*sizeof(chr);
- cv = (struct cvec *)MALLOC(n);
- if (cv == NULL)
- return NULL;
- cv->chrspace = nc;
- cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */
- cv->mccespace = nmcces;
- cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1);
- cv->rangespace = nranges;
- return clearcvec(cv);
+ nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2;
+ n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *)
+ + nc*sizeof(chr);
+ cv = (struct cvec *)MALLOC(n);
+ if (cv == NULL) {
+ return NULL;
+ }
+ cv->chrspace = nchrs;
+ cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */
+ cv->mccespace = nmcces;
+ cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1);
+ cv->rangespace = nranges;
+ return clearcvec(cv);
}
/*
*/
static struct cvec *
clearcvec(cv)
-struct cvec *cv;
+ struct cvec *cv; /* character vector */
{
- int i;
+ int i;
- assert(cv != NULL);
- cv->nchrs = 0;
- assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]);
- cv->nmcces = 0;
- cv->nmccechrs = 0;
- cv->nranges = 0;
- for (i = 0; i < cv->mccespace; i++)
- cv->mcces[i] = NULL;
+ assert(cv != NULL);
+ cv->nchrs = 0;
+ assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]);
+ cv->nmcces = 0;
+ cv->nmccechrs = 0;
+ cv->nranges = 0;
+ for (i = 0; i < cv->mccespace; i++) {
+ cv->mcces[i] = NULL;
+ }
- return cv;
+ return cv;
}
/*
*/
static VOID
addchr(cv, c)
-struct cvec *cv;
-pchr c;
+ struct cvec *cv; /* character vector */
+ pchr c; /* character to add */
{
- assert(cv->nchrs < cv->chrspace - cv->nmccechrs);
- cv->chrs[cv->nchrs++] = (chr)c;
+ assert(cv->nchrs < cv->chrspace - cv->nmccechrs);
+ cv->chrs[cv->nchrs++] = (chr)c;
}
/*
*/
static VOID
addrange(cv, from, to)
-struct cvec *cv;
-pchr from;
-pchr to;
+ struct cvec *cv; /* character vector */
+ pchr from; /* first character of range */
+ pchr to; /* last character of range */
{
- assert(cv->nranges < cv->rangespace);
- cv->ranges[cv->nranges*2] = (chr)from;
- cv->ranges[cv->nranges*2 + 1] = (chr)to;
- cv->nranges++;
+ assert(cv->nranges < cv->rangespace);
+ cv->ranges[cv->nranges*2] = (chr)from;
+ cv->ranges[cv->nranges*2 + 1] = (chr)to;
+ cv->nranges++;
}
/*
*/
static VOID
addmcce(cv, startp, endp)
-struct cvec *cv;
-chr *startp; /* beginning of text */
-chr *endp; /* just past end of text */
+ struct cvec *cv; /* character vector */
+ chr *startp; /* beginning of text */
+ chr *endp; /* just past end of text */
{
- int len;
- int i;
- chr *s;
- chr *d;
+ int len;
+ int i;
+ chr *s;
+ chr *d;
- if (startp == NULL && endp == NULL)
- return;
- len = endp - startp;
- assert(len > 0);
- assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs);
- assert(cv->nmcces < cv->mccespace);
- d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1];
- cv->mcces[cv->nmcces++] = d;
- for (s = startp, i = len; i > 0; s++, i--)
- *d++ = *s;
- *d++ = 0; /* endmarker */
- assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]);
- cv->nmccechrs += len + 1;
+ if (startp == NULL && endp == NULL) {
+ return;
+ }
+ len = endp - startp;
+ assert(len > 0);
+ assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs);
+ assert(cv->nmcces < cv->mccespace);
+ d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1];
+ cv->mcces[cv->nmcces++] = d;
+ for (s = startp, i = len; i > 0; s++, i--) {
+ *d++ = *s;
+ }
+ *d++ = 0; /* endmarker */
+ assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]);
+ cv->nmccechrs += len + 1;
}
/*
- haschr - does a cvec contain this chr?
^ static int haschr(struct cvec *, pchr);
*/
-static int /* predicate */
+static int /* predicate */
haschr(cv, c)
-struct cvec *cv;
-pchr c;
+ struct cvec *cv; /* character vector */
+ pchr c; /* character to test for */
{
- int i;
- chr *p;
+ int i;
+ chr *p;
- for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--)
- if (*p == c)
- return 1;
- for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--)
- if (*p <= c && c <= *(p+1))
- return 1;
- return 0;
+ for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) {
+ if (*p == c) {
+ return 1;
+ }
+ }
+ for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) {
+ if ((*p <= c) && (c <= *(p+1))) {
+ return 1;
+ }
+ }
+ return 0;
}
/*
*/
static struct cvec *
getcvec(v, nchrs, nranges, nmcces)
-struct vars *v;
-int nchrs; /* to hold this many chrs... */
-int nranges; /* ... and this many ranges... */
-int nmcces; /* ... and this many MCCEs */
+ struct vars *v; /* context */
+ int nchrs; /* to hold this many chrs... */
+ int nranges; /* ... and this many ranges... */
+ int nmcces; /* ... and this many MCCEs */
{
- if (v->cv != NULL && nchrs <= v->cv->chrspace &&
- nranges <= v->cv->rangespace &&
- nmcces <= v->cv->mccespace)
- return clearcvec(v->cv);
+ if (v->cv != NULL && nchrs <= v->cv->chrspace &&
+ nranges <= v->cv->rangespace && nmcces <= v->cv->mccespace) {
+ return clearcvec(v->cv);
+ }
- if (v->cv != NULL)
- freecvec(v->cv);
- v->cv = newcvec(nchrs, nranges, nmcces);
- if (v->cv == NULL)
- ERR(REG_ESPACE);
+ if (v->cv != NULL) {
+ freecvec(v->cv);
+ }
+ v->cv = newcvec(nchrs, nranges, nmcces);
+ if (v->cv == NULL) {
+ ERR(REG_ESPACE);
+ }
- return v->cv;
+ return v->cv;
}
/*
*/
static VOID
freecvec(cv)
-struct cvec *cv;
+ struct cvec *cv; /* character vector */
{
- FREE(cv);
+ FREE(cv);
}
/* ASCII character-name table */
static struct cname {
- char *name;
- char code;
+ char *name;
+ char code;
} cnames[] = {
- {"NUL", '\0'},
- {"SOH", '\001'},
- {"STX", '\002'},
- {"ETX", '\003'},
- {"EOT", '\004'},
- {"ENQ", '\005'},
- {"ACK", '\006'},
- {"BEL", '\007'},
- {"alert", '\007'},
- {"BS", '\010'},
- {"backspace", '\b'},
- {"HT", '\011'},
- {"tab", '\t'},
- {"LF", '\012'},
- {"newline", '\n'},
- {"VT", '\013'},
- {"vertical-tab", '\v'},
- {"FF", '\014'},
- {"form-feed", '\f'},
- {"CR", '\015'},
- {"carriage-return", '\r'},
- {"SO", '\016'},
- {"SI", '\017'},
- {"DLE", '\020'},
- {"DC1", '\021'},
- {"DC2", '\022'},
- {"DC3", '\023'},
- {"DC4", '\024'},
- {"NAK", '\025'},
- {"SYN", '\026'},
- {"ETB", '\027'},
- {"CAN", '\030'},
- {"EM", '\031'},
- {"SUB", '\032'},
- {"ESC", '\033'},
- {"IS4", '\034'},
- {"FS", '\034'},
- {"IS3", '\035'},
- {"GS", '\035'},
- {"IS2", '\036'},
- {"RS", '\036'},
- {"IS1", '\037'},
- {"US", '\037'},
- {"space", ' '},
- {"exclamation-mark", '!'},
- {"quotation-mark", '"'},
- {"number-sign", '#'},
- {"dollar-sign", '$'},
- {"percent-sign", '%'},
- {"ampersand", '&'},
- {"apostrophe", '\''},
- {"left-parenthesis", '('},
- {"right-parenthesis", ')'},
- {"asterisk", '*'},
- {"plus-sign", '+'},
- {"comma", ','},
- {"hyphen", '-'},
- {"hyphen-minus", '-'},
- {"period", '.'},
- {"full-stop", '.'},
- {"slash", '/'},
- {"solidus", '/'},
- {"zero", '0'},
- {"one", '1'},
- {"two", '2'},
- {"three", '3'},
- {"four", '4'},
- {"five", '5'},
- {"six", '6'},
- {"seven", '7'},
- {"eight", '8'},
- {"nine", '9'},
- {"colon", ':'},
- {"semicolon", ';'},
- {"less-than-sign", '<'},
- {"equals-sign", '='},
- {"greater-than-sign", '>'},
- {"question-mark", '?'},
- {"commercial-at", '@'},
- {"left-square-bracket", '['},
- {"backslash", '\\'},
- {"reverse-solidus", '\\'},
- {"right-square-bracket", ']'},
- {"circumflex", '^'},
- {"circumflex-accent", '^'},
- {"underscore", '_'},
- {"low-line", '_'},
- {"grave-accent", '`'},
- {"left-brace", '{'},
- {"left-curly-bracket", '{'},
- {"vertical-line", '|'},
- {"right-brace", '}'},
- {"right-curly-bracket", '}'},
- {"tilde", '~'},
- {"DEL", '\177'},
- {NULL, 0}
+ {"NUL", '\0'},
+ {"SOH", '\001'},
+ {"STX", '\002'},
+ {"ETX", '\003'},
+ {"EOT", '\004'},
+ {"ENQ", '\005'},
+ {"ACK", '\006'},
+ {"BEL", '\007'},
+ {"alert", '\007'},
+ {"BS", '\010'},
+ {"backspace", '\b'},
+ {"HT", '\011'},
+ {"tab", '\t'},
+ {"LF", '\012'},
+ {"newline", '\n'},
+ {"VT", '\013'},
+ {"vertical-tab", '\v'},
+ {"FF", '\014'},
+ {"form-feed", '\f'},
+ {"CR", '\015'},
+ {"carriage-return", '\r'},
+ {"SO", '\016'},
+ {"SI", '\017'},
+ {"DLE", '\020'},
+ {"DC1", '\021'},
+ {"DC2", '\022'},
+ {"DC3", '\023'},
+ {"DC4", '\024'},
+ {"NAK", '\025'},
+ {"SYN", '\026'},
+ {"ETB", '\027'},
+ {"CAN", '\030'},
+ {"EM", '\031'},
+ {"SUB", '\032'},
+ {"ESC", '\033'},
+ {"IS4", '\034'},
+ {"FS", '\034'},
+ {"IS3", '\035'},
+ {"GS", '\035'},
+ {"IS2", '\036'},
+ {"RS", '\036'},
+ {"IS1", '\037'},
+ {"US", '\037'},
+ {"space", ' '},
+ {"exclamation-mark",'!'},
+ {"quotation-mark", '"'},
+ {"number-sign", '#'},
+ {"dollar-sign", '$'},
+ {"percent-sign", '%'},
+ {"ampersand", '&'},
+ {"apostrophe", '\''},
+ {"left-parenthesis",'('},
+ {"right-parenthesis", ')'},
+ {"asterisk", '*'},
+ {"plus-sign", '+'},
+ {"comma", ','},
+ {"hyphen", '-'},
+ {"hyphen-minus", '-'},
+ {"period", '.'},
+ {"full-stop", '.'},
+ {"slash", '/'},
+ {"solidus", '/'},
+ {"zero", '0'},
+ {"one", '1'},
+ {"two", '2'},
+ {"three", '3'},
+ {"four", '4'},
+ {"five", '5'},
+ {"six", '6'},
+ {"seven", '7'},
+ {"eight", '8'},
+ {"nine", '9'},
+ {"colon", ':'},
+ {"semicolon", ';'},
+ {"less-than-sign", '<'},
+ {"equals-sign", '='},
+ {"greater-than-sign", '>'},
+ {"question-mark", '?'},
+ {"commercial-at", '@'},
+ {"left-square-bracket", '['},
+ {"backslash", '\\'},
+ {"reverse-solidus", '\\'},
+ {"right-square-bracket", ']'},
+ {"circumflex", '^'},
+ {"circumflex-accent", '^'},
+ {"underscore", '_'},
+ {"low-line", '_'},
+ {"grave-accent", '`'},
+ {"left-brace", '{'},
+ {"left-curly-bracket", '{'},
+ {"vertical-line", '|'},
+ {"right-brace", '}'},
+ {"right-curly-bracket", '}'},
+ {"tilde", '~'},
+ {"DEL", '\177'},
+ {NULL, 0}
};
/* Unicode character-class tables */
chr end;
} crange;
-/* Unicode: (Alphabetic) */
+/*
+ * Declarations of Unicode character ranges. This code
+ * is automatically generated by the tools/uniClass.tcl script
+ * and used in generic/regc_locale.c. Do not modify by hand.
+ */
+
+/* Unicode: alphabetic characters */
static crange alphaRangeTable[] = {
{0x0041, 0x005a}, {0x0061, 0x007a}, {0x00c0, 0x00d6}, {0x00d8, 0x00f6},
- {0x00f8, 0x01f5}, {0x01fa, 0x0217}, {0x0250, 0x02a8}, {0x02b0, 0x02b8},
+ {0x00f8, 0x021f}, {0x0222, 0x0233}, {0x0250, 0x02ad}, {0x02b0, 0x02b8},
{0x02bb, 0x02c1}, {0x02e0, 0x02e4}, {0x0388, 0x038a}, {0x038e, 0x03a1},
- {0x03a3, 0x03ce}, {0x03d0, 0x03d6}, {0x03e2, 0x03f3}, {0x0401, 0x040c},
- {0x040e, 0x044f}, {0x0451, 0x045c}, {0x045e, 0x0481}, {0x0490, 0x04c4},
- {0x04d0, 0x04eb}, {0x04ee, 0x04f5}, {0x0531, 0x0556}, {0x0561, 0x0587},
+ {0x03a3, 0x03ce}, {0x03d0, 0x03d7}, {0x03da, 0x03f5}, {0x0400, 0x0481},
+ {0x048c, 0x04c4}, {0x04d0, 0x04f5}, {0x0531, 0x0556}, {0x0561, 0x0587},
{0x05d0, 0x05ea}, {0x05f0, 0x05f2}, {0x0621, 0x063a}, {0x0640, 0x064a},
- {0x0671, 0x06b7}, {0x06ba, 0x06be}, {0x06c0, 0x06ce}, {0x06d0, 0x06d3},
+ {0x0671, 0x06d3}, {0x06fa, 0x06fc}, {0x0712, 0x072c}, {0x0780, 0x07a5},
{0x0905, 0x0939}, {0x0958, 0x0961}, {0x0985, 0x098c}, {0x0993, 0x09a8},
{0x09aa, 0x09b0}, {0x09b6, 0x09b9}, {0x09df, 0x09e1}, {0x0a05, 0x0a0a},
{0x0a13, 0x0a28}, {0x0a2a, 0x0a30}, {0x0a59, 0x0a5c}, {0x0a72, 0x0a74},
{0x0c05, 0x0c0c}, {0x0c0e, 0x0c10}, {0x0c12, 0x0c28}, {0x0c2a, 0x0c33},
{0x0c35, 0x0c39}, {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90}, {0x0c92, 0x0ca8},
{0x0caa, 0x0cb3}, {0x0cb5, 0x0cb9}, {0x0d05, 0x0d0c}, {0x0d0e, 0x0d10},
- {0x0d12, 0x0d28}, {0x0d2a, 0x0d39}, {0x0e01, 0x0e30}, {0x0e40, 0x0e46},
+ {0x0d12, 0x0d28}, {0x0d2a, 0x0d39}, {0x0d85, 0x0d96}, {0x0d9a, 0x0db1},
+ {0x0db3, 0x0dbb}, {0x0dc0, 0x0dc6}, {0x0e01, 0x0e30}, {0x0e40, 0x0e46},
{0x0e94, 0x0e97}, {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb0},
- {0x0ec0, 0x0ec4}, {0x0f40, 0x0f47}, {0x0f49, 0x0f69}, {0x0f88, 0x0f8b},
- {0x10a0, 0x10c5}, {0x10d0, 0x10f6}, {0x1100, 0x1159}, {0x115f, 0x11a2},
- {0x11a8, 0x11f9}, {0x1e00, 0x1e9b}, {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15},
- {0x1f18, 0x1f1d}, {0x1f20, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57},
- {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4},
- {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec},
- {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc}, {0x210a, 0x2113}, {0x2118, 0x211d},
- {0x212a, 0x2131}, {0x2133, 0x2138}, {0x3031, 0x3035}, {0x3041, 0x3094},
- {0x30a1, 0x30fa}, {0x30fc, 0x30fe}, {0x3105, 0x312c}, {0x3131, 0x318e},
- {0x4e00, 0x9fa5}, {0xac00, 0xd7a3}, {0xf900, 0xfa2d}, {0xfb00, 0xfb06},
- {0xfb13, 0xfb17}, {0xfb1f, 0xfb28}, {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c},
- {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7},
- {0xfdf0, 0xfdfb}, {0xfe70, 0xfe72}, {0xfe76, 0xfefc}, {0xff21, 0xff3a},
- {0xff41, 0xff5a}, {0xff66, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf},
- {0xffd2, 0xffd7}, {0xffda, 0xffdc}
+ {0x0ec0, 0x0ec4}, {0x0f40, 0x0f47}, {0x0f49, 0x0f6a}, {0x0f88, 0x0f8b},
+ {0x1000, 0x1021}, {0x1023, 0x1027}, {0x1050, 0x1055}, {0x10a0, 0x10c5},
+ {0x10d0, 0x10f6}, {0x1100, 0x1159}, {0x115f, 0x11a2}, {0x11a8, 0x11f9},
+ {0x1200, 0x1206}, {0x1208, 0x1246}, {0x124a, 0x124d}, {0x1250, 0x1256},
+ {0x125a, 0x125d}, {0x1260, 0x1286}, {0x128a, 0x128d}, {0x1290, 0x12ae},
+ {0x12b2, 0x12b5}, {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12ce},
+ {0x12d0, 0x12d6}, {0x12d8, 0x12ee}, {0x12f0, 0x130e}, {0x1312, 0x1315},
+ {0x1318, 0x131e}, {0x1320, 0x1346}, {0x1348, 0x135a}, {0x13a0, 0x13f4},
+ {0x1401, 0x166c}, {0x166f, 0x1676}, {0x1681, 0x169a}, {0x16a0, 0x16ea},
+ {0x1780, 0x17b3}, {0x1820, 0x1877}, {0x1880, 0x18a8}, {0x1e00, 0x1e9b},
+ {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15}, {0x1f18, 0x1f1d}, {0x1f20, 0x1f45},
+ {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4},
+ {0x1fb6, 0x1fbc}, {0x1fc2, 0x1fc4}, {0x1fc6, 0x1fcc}, {0x1fd0, 0x1fd3},
+ {0x1fd6, 0x1fdb}, {0x1fe0, 0x1fec}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffc},
+ {0x210a, 0x2113}, {0x2119, 0x211d}, {0x212a, 0x212d}, {0x212f, 0x2131},
+ {0x2133, 0x2139}, {0x3031, 0x3035}, {0x3041, 0x3094}, {0x30a1, 0x30fa},
+ {0x30fc, 0x30fe}, {0x3105, 0x312c}, {0x3131, 0x318e}, {0x31a0, 0x31b7},
+ {0x3400, 0x4db5}, {0x4e00, 0x9fa5}, {0xa000, 0xa48c}, {0xac00, 0xd7a3},
+ {0xf900, 0xfa2d}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1f, 0xfb28},
+ {0xfb2a, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfd3d},
+ {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb}, {0xfe70, 0xfe72},
+ {0xfe76, 0xfefc}, {0xff21, 0xff3a}, {0xff41, 0xff5a}, {0xff66, 0xffbe},
+ {0xffc2, 0xffc7}, {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc}
};
#define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange))
static chr alphaCharTable[] = {
- 0x00aa, 0x00b5, 0x00ba, 0x02d0, 0x02d1, 0x037a, 0x0386, 0x038c, 0x03da,
- 0x03dc, 0x03de, 0x03e0, 0x04c7, 0x04c8, 0x04cb, 0x04cc, 0x04f8, 0x04f9,
- 0x0559, 0x06d5, 0x06e5, 0x06e6, 0x093d, 0x0950, 0x098f, 0x0990, 0x09b2,
- 0x09dc, 0x09dd, 0x09f0, 0x09f1, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35,
- 0x0a36, 0x0a38, 0x0a39, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0abd, 0x0ad0,
- 0x0ae0, 0x0b0f, 0x0b10, 0x0b32, 0x0b33, 0x0b3d, 0x0b5c, 0x0b5d, 0x0b99,
- 0x0b9a, 0x0b9c, 0x0b9e, 0x0b9f, 0x0ba3, 0x0ba4, 0x0c60, 0x0c61, 0x0cde,
- 0x0ce0, 0x0ce1, 0x0d60, 0x0d61, 0x0e32, 0x0e33, 0x0e81, 0x0e82, 0x0e84,
- 0x0e87, 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0eb2,
- 0x0eb3, 0x0ebd, 0x0ec6, 0x0edc, 0x0edd, 0x0f00, 0x1f59, 0x1f5b, 0x1f5d,
- 0x1fbe, 0x207f, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x3005,
- 0x3006, 0x309d, 0x309e, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74
+ 0x00aa, 0x00b5, 0x00ba, 0x02d0, 0x02d1, 0x02ee, 0x037a, 0x0386, 0x038c,
+ 0x04c7, 0x04c8, 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0559, 0x06d5, 0x06e5,
+ 0x06e6, 0x0710, 0x093d, 0x0950, 0x098f, 0x0990, 0x09b2, 0x09dc, 0x09dd,
+ 0x09f0, 0x09f1, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, 0x0a36, 0x0a38,
+ 0x0a39, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0abd, 0x0ad0, 0x0ae0, 0x0b0f,
+ 0x0b10, 0x0b32, 0x0b33, 0x0b3d, 0x0b5c, 0x0b5d, 0x0b99, 0x0b9a, 0x0b9c,
+ 0x0b9e, 0x0b9f, 0x0ba3, 0x0ba4, 0x0c60, 0x0c61, 0x0cde, 0x0ce0, 0x0ce1,
+ 0x0d60, 0x0d61, 0x0dbd, 0x0e32, 0x0e33, 0x0e81, 0x0e82, 0x0e84, 0x0e87,
+ 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0eb2, 0x0eb3,
+ 0x0ebd, 0x0ec6, 0x0edc, 0x0edd, 0x0f00, 0x1029, 0x102a, 0x1248, 0x1258,
+ 0x1288, 0x12b0, 0x12c0, 0x1310, 0x1f59, 0x1f5b, 0x1f5d, 0x1fbe, 0x207f,
+ 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x3005, 0x3006, 0x309d,
+ 0x309e, 0xfb1d, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74, 0xfffe
};
#define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr))
-/* Unicode: (Decimal digit) */
+/* Unicode: decimal digit characters */
static crange digitRangeTable[] = {
{0x0030, 0x0039}, {0x0660, 0x0669}, {0x06f0, 0x06f9}, {0x0966, 0x096f},
{0x09e6, 0x09ef}, {0x0a66, 0x0a6f}, {0x0ae6, 0x0aef}, {0x0b66, 0x0b6f},
{0x0be7, 0x0bef}, {0x0c66, 0x0c6f}, {0x0ce6, 0x0cef}, {0x0d66, 0x0d6f},
- {0x0e50, 0x0e59}, {0x0ed0, 0x0ed9}, {0x0f20, 0x0f29}, {0xff10, 0xff19}
+ {0x0e50, 0x0e59}, {0x0ed0, 0x0ed9}, {0x0f20, 0x0f29}, {0x1040, 0x1049},
+ {0x1369, 0x1371}, {0x17e0, 0x17e9}, {0x1810, 0x1819}, {0xff10, 0xff19}
};
#define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange))
-/* Unicode: (Punctuation) */
+/* no singletons of digit characters */
+
+/* Unicode: punctuation characters */
static crange punctRangeTable[] = {
{0x0021, 0x0023}, {0x0025, 0x002a}, {0x002c, 0x002f}, {0x005b, 0x005d},
- {0x055a, 0x055f}, {0x066a, 0x066d}, {0x0f04, 0x0f12}, {0x0f3a, 0x0f3d},
- {0x2010, 0x2027}, {0x2030, 0x2043}, {0x3001, 0x3003}, {0x3008, 0x3011},
- {0x3014, 0x301f}, {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe61},
- {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d},
- {0xff61, 0xff65}
+ {0x055a, 0x055f}, {0x066a, 0x066d}, {0x0700, 0x070d}, {0x0f04, 0x0f12},
+ {0x0f3a, 0x0f3d}, {0x104a, 0x104f}, {0x1361, 0x1368}, {0x16eb, 0x16ed},
+ {0x17d4, 0x17da}, {0x1800, 0x180a}, {0x2010, 0x2027}, {0x2030, 0x2043},
+ {0x2048, 0x204d}, {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f},
+ {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03},
+ {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff61, 0xff65}
};
#define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange))
static chr punctCharTable[] = {
0x003a, 0x003b, 0x003f, 0x0040, 0x005f, 0x007b, 0x007d, 0x00a1, 0x00ab,
- 0x00ad, 0x00b7, 0x00bb, 0x00bf, 0x037e, 0x0387, 0x0589, 0x05be, 0x05c0,
- 0x05c3, 0x05f3, 0x05f4, 0x060c, 0x061b, 0x061f, 0x06d4, 0x0964, 0x0965,
- 0x0970, 0x0e5a, 0x0e5b, 0x0f85, 0x10fb, 0x2045, 0x2046, 0x207d, 0x207e,
- 0x208d, 0x208e, 0x2329, 0x232a, 0x3030, 0x30fb, 0xfd3e, 0xfd3f, 0xfe63,
- 0xfe68, 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b,
- 0xff5d
+ 0x00ad, 0x00b7, 0x00bb, 0x00bf, 0x037e, 0x0387, 0x0589, 0x058a, 0x05be,
+ 0x05c0, 0x05c3, 0x05f3, 0x05f4, 0x060c, 0x061b, 0x061f, 0x06d4, 0x0964,
+ 0x0965, 0x0970, 0x0df4, 0x0e4f, 0x0e5a, 0x0e5b, 0x0f85, 0x10fb, 0x166d,
+ 0x166e, 0x169b, 0x169c, 0x17dc, 0x2045, 0x2046, 0x207d, 0x207e, 0x208d,
+ 0x208e, 0x2329, 0x232a, 0x3030, 0x30fb, 0xfd3e, 0xfd3f, 0xfe63, 0xfe68,
+ 0xfe6a, 0xfe6b, 0xff1a, 0xff1b, 0xff1f, 0xff20, 0xff3f, 0xff5b, 0xff5d
};
#define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr))
-/* Unicode: (White space) */
+/* Unicode: white space characters */
static crange spaceRangeTable[] = {
- {0x0009, 0x000d}, {0x2000, 0x200b},
+ {0x0009, 0x000d}, {0x2000, 0x200b}
};
#define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange))
static chr spaceCharTable[] = {
- 0x0020, 0x00a0, 0x2028, 0x2029, 0x3000
+ 0x0020, 0x00a0, 0x1680, 0x2028, 0x2029, 0x202f, 0x3000
};
#define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr))
static crange lowerRangeTable[] = {
{0x0061, 0x007a}, {0x00df, 0x00f6}, {0x00f8, 0x00ff}, {0x017e, 0x0180},
- {0x0199, 0x019b}, {0x0250, 0x02a8}, {0x03ac, 0x03ce}, {0x03ef, 0x03f2},
- {0x0430, 0x044f}, {0x0451, 0x045c}, {0x0561, 0x0587}, {0x10d0, 0x10f6},
+ {0x0199, 0x019b}, {0x01bd, 0x01bf}, {0x0250, 0x02ad}, {0x03ac, 0x03ce},
+ {0x03d5, 0x03d7}, {0x03ef, 0x03f3}, {0x0430, 0x045f}, {0x0561, 0x0587},
{0x1e95, 0x1e9b}, {0x1f00, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27},
{0x1f30, 0x1f37}, {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67},
{0x1f70, 0x1f7d}, {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7},
0x0153, 0x0155, 0x0157, 0x0159, 0x015b, 0x015d, 0x015f, 0x0161, 0x0163,
0x0165, 0x0167, 0x0169, 0x016b, 0x016d, 0x016f, 0x0171, 0x0173, 0x0175,
0x0177, 0x017a, 0x017c, 0x0183, 0x0185, 0x0188, 0x018c, 0x018d, 0x0192,
- 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01ab, 0x01ad, 0x01b0,
- 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01bd, 0x01c6, 0x01c9, 0x01cc, 0x01ce,
+ 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01aa, 0x01ab, 0x01ad,
+ 0x01b0, 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01c6, 0x01c9, 0x01cc, 0x01ce,
0x01d0, 0x01d2, 0x01d4, 0x01d6, 0x01d8, 0x01da, 0x01dc, 0x01dd, 0x01df,
0x01e1, 0x01e3, 0x01e5, 0x01e7, 0x01e9, 0x01eb, 0x01ed, 0x01ef, 0x01f0,
- 0x01f3, 0x01f5, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205, 0x0207,
- 0x0209, 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217, 0x0390,
- 0x03d0, 0x03d1, 0x03d5, 0x03d6, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb,
- 0x03ed, 0x045e, 0x045f, 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b,
- 0x046d, 0x046f, 0x0471, 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d,
- 0x047f, 0x0481, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d,
- 0x049f, 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af,
- 0x04b1, 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2,
- 0x04c4, 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db,
- 0x04dd, 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ef,
+ 0x01f3, 0x01f5, 0x01f9, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205,
+ 0x0207, 0x0209, 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217,
+ 0x0219, 0x021b, 0x021d, 0x021f, 0x0223, 0x0225, 0x0227, 0x0229, 0x022b,
+ 0x022d, 0x022f, 0x0231, 0x0233, 0x0390, 0x03d0, 0x03d1, 0x03db, 0x03dd,
+ 0x03df, 0x03e1, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb, 0x03ed, 0x03f5,
+ 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b, 0x046d, 0x046f, 0x0471,
+ 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d, 0x047f, 0x0481, 0x048d,
+ 0x048f, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d, 0x049f,
+ 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af, 0x04b1,
+ 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2, 0x04c4,
+ 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db, 0x04dd,
+ 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ed, 0x04ef,
0x04f1, 0x04f3, 0x04f5, 0x04f9, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09,
0x1e0b, 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b,
0x1e1d, 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d,
0x1edd, 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed,
0x1eef, 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1fb6, 0x1fb7, 0x1fbe,
0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x207f, 0x210a, 0x210e,
- 0x210f, 0x2113, 0x2118, 0x212e, 0x212f, 0x2134
+ 0x210f, 0x2113, 0x212f, 0x2134, 0x2139
};
#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr))
static crange upperRangeTable[] = {
{0x0041, 0x005a}, {0x00c0, 0x00d6}, {0x00d8, 0x00de}, {0x0189, 0x018b},
- {0x018e, 0x0191}, {0x0196, 0x0198}, {0x01b1, 0x01b3}, {0x0388, 0x038a},
- {0x0391, 0x03a1}, {0x03a3, 0x03ab}, {0x03d2, 0x03d4}, {0x0401, 0x040c},
- {0x040e, 0x042f}, {0x0531, 0x0556}, {0x10a0, 0x10c5}, {0x1f08, 0x1f0f},
+ {0x018e, 0x0191}, {0x0196, 0x0198}, {0x01b1, 0x01b3}, {0x01f6, 0x01f8},
+ {0x0388, 0x038a}, {0x0391, 0x03a1}, {0x03a3, 0x03ab}, {0x03d2, 0x03d4},
+ {0x0400, 0x042f}, {0x0531, 0x0556}, {0x10a0, 0x10c5}, {0x1f08, 0x1f0f},
{0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d},
- {0x1f68, 0x1f6f}, {0x1f88, 0x1f8f}, {0x1f98, 0x1f9f}, {0x1fa8, 0x1faf},
- {0x1fb8, 0x1fbc}, {0x1fc8, 0x1fcc}, {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec},
- {0x1ff8, 0x1ffc}, {0x210b, 0x210d}, {0x2110, 0x2112}, {0x2119, 0x211d},
- {0x212a, 0x212d}, {0xff21, 0xff3a}
+ {0x1f68, 0x1f6f}, {0x1fb8, 0x1fbb}, {0x1fc8, 0x1fcb}, {0x1fd8, 0x1fdb},
+ {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffb}, {0x210b, 0x210d}, {0x2110, 0x2112},
+ {0x2119, 0x211d}, {0x212a, 0x212d}, {0xff21, 0xff3a}
};
#define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange))
0x01cf, 0x01d1, 0x01d3, 0x01d5, 0x01d7, 0x01d9, 0x01db, 0x01de, 0x01e0,
0x01e2, 0x01e4, 0x01e6, 0x01e8, 0x01ea, 0x01ec, 0x01ee, 0x01f1, 0x01f4,
0x01fa, 0x01fc, 0x01fe, 0x0200, 0x0202, 0x0204, 0x0206, 0x0208, 0x020a,
- 0x020c, 0x020e, 0x0210, 0x0212, 0x0214, 0x0216, 0x0386, 0x038c, 0x038e,
- 0x038f, 0x03da, 0x03dc, 0x03de, 0x03e0, 0x03e2, 0x03e4, 0x03e6, 0x03e8,
- 0x03ea, 0x03ec, 0x03ee, 0x0460, 0x0462, 0x0464, 0x0466, 0x0468, 0x046a,
- 0x046c, 0x046e, 0x0470, 0x0472, 0x0474, 0x0476, 0x0478, 0x047a, 0x047c,
- 0x047e, 0x0480, 0x0490, 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c,
- 0x049e, 0x04a0, 0x04a2, 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae,
- 0x04b0, 0x04b2, 0x04b4, 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c1,
- 0x04c3, 0x04c7, 0x04cb, 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da,
- 0x04dc, 0x04de, 0x04e0, 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ee,
+ 0x020c, 0x020e, 0x0210, 0x0212, 0x0214, 0x0216, 0x0218, 0x021a, 0x021c,
+ 0x021e, 0x0222, 0x0224, 0x0226, 0x0228, 0x022a, 0x022c, 0x022e, 0x0230,
+ 0x0232, 0x0386, 0x038c, 0x038e, 0x038f, 0x03da, 0x03dc, 0x03de, 0x03e0,
+ 0x03e2, 0x03e4, 0x03e6, 0x03e8, 0x03ea, 0x03ec, 0x03ee, 0x03f4, 0x0460,
+ 0x0462, 0x0464, 0x0466, 0x0468, 0x046a, 0x046c, 0x046e, 0x0470, 0x0472,
+ 0x0474, 0x0476, 0x0478, 0x047a, 0x047c, 0x047e, 0x0480, 0x048c, 0x048e,
+ 0x0490, 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c, 0x049e, 0x04a0,
+ 0x04a2, 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae, 0x04b0, 0x04b2,
+ 0x04b4, 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c0, 0x04c1, 0x04c3,
+ 0x04c7, 0x04cb, 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da, 0x04dc,
+ 0x04de, 0x04e0, 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ec, 0x04ee,
0x04f0, 0x04f2, 0x04f4, 0x04f8, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08,
0x1e0a, 0x1e0c, 0x1e0e, 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a,
0x1e1c, 0x1e1e, 0x1e20, 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c,
#define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr))
-/*
- * The graph table includes the set of characters that are Unicode
- * print characters excluding space.
- */
+/* Unicode: unicode print characters excluding space */
static crange graphRangeTable[] = {
- {0x0021, 0x007e}, {0x00a0, 0x011f}, {0x0121, 0x01f5}, {0x01fa, 0x0217},
- {0x0250, 0x02a8}, {0x02b0, 0x02de}, {0x02e0, 0x02e9}, {0x0300, 0x031f},
- {0x0321, 0x0345}, {0x0384, 0x038a}, {0x038e, 0x03a1}, {0x03a3, 0x03ce},
- {0x03d0, 0x03d6}, {0x03e2, 0x03f3}, {0x0401, 0x040c}, {0x040e, 0x041f},
- {0x0421, 0x044f}, {0x0451, 0x045c}, {0x045e, 0x0486}, {0x0490, 0x04c4},
- {0x04d0, 0x04eb}, {0x04ee, 0x04f5}, {0x0531, 0x0556}, {0x0559, 0x055f},
+ {0x0021, 0x007e}, {0x00a0, 0x011f}, {0x0121, 0x021f}, {0x0222, 0x0233},
+ {0x0250, 0x02ad}, {0x02b0, 0x02ee}, {0x0300, 0x031f}, {0x0321, 0x034e},
+ {0x0360, 0x0362}, {0x0384, 0x038a}, {0x038e, 0x03a1}, {0x03a3, 0x03ce},
+ {0x03d0, 0x03d7}, {0x03da, 0x03f5}, {0x0400, 0x041f}, {0x0421, 0x0486},
+ {0x048c, 0x04c4}, {0x04d0, 0x04f5}, {0x0531, 0x0556}, {0x0559, 0x055f},
{0x0561, 0x0587}, {0x0591, 0x05a1}, {0x05a3, 0x05b9}, {0x05bb, 0x05c4},
- {0x05d0, 0x05ea}, {0x05f0, 0x05f4}, {0x0621, 0x063a}, {0x0640, 0x0652},
- {0x0660, 0x066d}, {0x0670, 0x06b7}, {0x06ba, 0x06be}, {0x06c0, 0x06ce},
- {0x06d0, 0x06ed}, {0x06f0, 0x06f9}, {0x0901, 0x0903}, {0x0905, 0x091f},
- {0x0921, 0x0939}, {0x093c, 0x094d}, {0x0950, 0x0954}, {0x0958, 0x0970},
- {0x0981, 0x0983}, {0x0985, 0x098c}, {0x0993, 0x09a8}, {0x09aa, 0x09b0},
- {0x09b6, 0x09b9}, {0x09be, 0x09c4}, {0x09cb, 0x09cd}, {0x09df, 0x09e3},
- {0x09e6, 0x09fa}, {0x0a05, 0x0a0a}, {0x0a13, 0x0a1f}, {0x0a21, 0x0a28},
- {0x0a2a, 0x0a30}, {0x0a3e, 0x0a42}, {0x0a4b, 0x0a4d}, {0x0a59, 0x0a5c},
- {0x0a66, 0x0a74}, {0x0a81, 0x0a83}, {0x0a85, 0x0a8b}, {0x0a8f, 0x0a91},
- {0x0a93, 0x0aa8}, {0x0aaa, 0x0ab0}, {0x0ab5, 0x0ab9}, {0x0abc, 0x0ac5},
- {0x0ac7, 0x0ac9}, {0x0acb, 0x0acd}, {0x0ae6, 0x0aef}, {0x0b01, 0x0b03},
- {0x0b05, 0x0b0c}, {0x0b13, 0x0b1f}, {0x0b21, 0x0b28}, {0x0b2a, 0x0b30},
- {0x0b36, 0x0b39}, {0x0b3c, 0x0b43}, {0x0b4b, 0x0b4d}, {0x0b5f, 0x0b61},
- {0x0b66, 0x0b70}, {0x0b85, 0x0b8a}, {0x0b8e, 0x0b90}, {0x0b92, 0x0b95},
- {0x0ba8, 0x0baa}, {0x0bae, 0x0bb5}, {0x0bb7, 0x0bb9}, {0x0bbe, 0x0bc2},
- {0x0bc6, 0x0bc8}, {0x0bca, 0x0bcd}, {0x0be7, 0x0bf2}, {0x0c01, 0x0c03},
- {0x0c05, 0x0c0c}, {0x0c0e, 0x0c10}, {0x0c12, 0x0c1f}, {0x0c21, 0x0c28},
- {0x0c2a, 0x0c33}, {0x0c35, 0x0c39}, {0x0c3e, 0x0c44}, {0x0c46, 0x0c48},
- {0x0c4a, 0x0c4d}, {0x0c66, 0x0c6f}, {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90},
- {0x0c92, 0x0ca8}, {0x0caa, 0x0cb3}, {0x0cb5, 0x0cb9}, {0x0cbe, 0x0cc4},
- {0x0cc6, 0x0cc8}, {0x0cca, 0x0ccd}, {0x0ce6, 0x0cef}, {0x0d05, 0x0d0c},
- {0x0d0e, 0x0d10}, {0x0d12, 0x0d1f}, {0x0d21, 0x0d28}, {0x0d2a, 0x0d39},
- {0x0d3e, 0x0d43}, {0x0d46, 0x0d48}, {0x0d4a, 0x0d4d}, {0x0d66, 0x0d6f},
- {0x0e01, 0x0e1f}, {0x0e21, 0x0e3a}, {0x0e3f, 0x0e5b}, {0x0e94, 0x0e97},
- {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb9}, {0x0ebb, 0x0ebd},
- {0x0ec0, 0x0ec4}, {0x0ec8, 0x0ecd}, {0x0ed0, 0x0ed9}, {0x0f00, 0x0f1f},
- {0x0f21, 0x0f47}, {0x0f49, 0x0f69}, {0x0f71, 0x0f8b}, {0x0f90, 0x0f95},
- {0x0f99, 0x0fad}, {0x0fb1, 0x0fb7}, {0x10a0, 0x10c5}, {0x10d0, 0x10f6},
- {0x1100, 0x111f}, {0x1121, 0x1159}, {0x115f, 0x11a2}, {0x11a8, 0x11f9},
+ {0x05d0, 0x05ea}, {0x05f0, 0x05f4}, {0x0621, 0x063a}, {0x0640, 0x0655},
+ {0x0660, 0x066d}, {0x0670, 0x06ed}, {0x06f0, 0x06fe}, {0x0700, 0x070d},
+ {0x0710, 0x071f}, {0x0721, 0x072c}, {0x0730, 0x074a}, {0x0780, 0x07b0},
+ {0x0901, 0x0903}, {0x0905, 0x091f}, {0x0921, 0x0939}, {0x093c, 0x094d},
+ {0x0950, 0x0954}, {0x0958, 0x0970}, {0x0981, 0x0983}, {0x0985, 0x098c},
+ {0x0993, 0x09a8}, {0x09aa, 0x09b0}, {0x09b6, 0x09b9}, {0x09be, 0x09c4},
+ {0x09cb, 0x09cd}, {0x09df, 0x09e3}, {0x09e6, 0x09fa}, {0x0a05, 0x0a0a},
+ {0x0a13, 0x0a1f}, {0x0a21, 0x0a28}, {0x0a2a, 0x0a30}, {0x0a3e, 0x0a42},
+ {0x0a4b, 0x0a4d}, {0x0a59, 0x0a5c}, {0x0a66, 0x0a74}, {0x0a81, 0x0a83},
+ {0x0a85, 0x0a8b}, {0x0a8f, 0x0a91}, {0x0a93, 0x0aa8}, {0x0aaa, 0x0ab0},
+ {0x0ab5, 0x0ab9}, {0x0abc, 0x0ac5}, {0x0ac7, 0x0ac9}, {0x0acb, 0x0acd},
+ {0x0ae6, 0x0aef}, {0x0b01, 0x0b03}, {0x0b05, 0x0b0c}, {0x0b13, 0x0b1f},
+ {0x0b21, 0x0b28}, {0x0b2a, 0x0b30}, {0x0b36, 0x0b39}, {0x0b3c, 0x0b43},
+ {0x0b4b, 0x0b4d}, {0x0b5f, 0x0b61}, {0x0b66, 0x0b70}, {0x0b85, 0x0b8a},
+ {0x0b8e, 0x0b90}, {0x0b92, 0x0b95}, {0x0ba8, 0x0baa}, {0x0bae, 0x0bb5},
+ {0x0bb7, 0x0bb9}, {0x0bbe, 0x0bc2}, {0x0bc6, 0x0bc8}, {0x0bca, 0x0bcd},
+ {0x0be7, 0x0bf2}, {0x0c01, 0x0c03}, {0x0c05, 0x0c0c}, {0x0c0e, 0x0c10},
+ {0x0c12, 0x0c1f}, {0x0c21, 0x0c28}, {0x0c2a, 0x0c33}, {0x0c35, 0x0c39},
+ {0x0c3e, 0x0c44}, {0x0c46, 0x0c48}, {0x0c4a, 0x0c4d}, {0x0c66, 0x0c6f},
+ {0x0c85, 0x0c8c}, {0x0c8e, 0x0c90}, {0x0c92, 0x0ca8}, {0x0caa, 0x0cb3},
+ {0x0cb5, 0x0cb9}, {0x0cbe, 0x0cc4}, {0x0cc6, 0x0cc8}, {0x0cca, 0x0ccd},
+ {0x0ce6, 0x0cef}, {0x0d05, 0x0d0c}, {0x0d0e, 0x0d10}, {0x0d12, 0x0d1f},
+ {0x0d21, 0x0d28}, {0x0d2a, 0x0d39}, {0x0d3e, 0x0d43}, {0x0d46, 0x0d48},
+ {0x0d4a, 0x0d4d}, {0x0d66, 0x0d6f}, {0x0d85, 0x0d96}, {0x0d9a, 0x0db1},
+ {0x0db3, 0x0dbb}, {0x0dc0, 0x0dc6}, {0x0dcf, 0x0dd4}, {0x0dd8, 0x0ddf},
+ {0x0df2, 0x0df4}, {0x0e01, 0x0e1f}, {0x0e21, 0x0e3a}, {0x0e3f, 0x0e5b},
+ {0x0e94, 0x0e97}, {0x0e99, 0x0e9f}, {0x0ea1, 0x0ea3}, {0x0ead, 0x0eb9},
+ {0x0ebb, 0x0ebd}, {0x0ec0, 0x0ec4}, {0x0ec8, 0x0ecd}, {0x0ed0, 0x0ed9},
+ {0x0f00, 0x0f1f}, {0x0f21, 0x0f47}, {0x0f49, 0x0f6a}, {0x0f71, 0x0f8b},
+ {0x0f90, 0x0f97}, {0x0f99, 0x0fbc}, {0x0fbe, 0x0fcc}, {0x1000, 0x101f},
+ {0x1023, 0x1027}, {0x102c, 0x1032}, {0x1036, 0x1039}, {0x1040, 0x1059},
+ {0x10a0, 0x10c5}, {0x10d0, 0x10f6}, {0x1100, 0x111f}, {0x1121, 0x1159},
+ {0x115f, 0x11a2}, {0x11a8, 0x11f9}, {0x1200, 0x1206}, {0x1208, 0x121f},
+ {0x1221, 0x1246}, {0x124a, 0x124d}, {0x1250, 0x1256}, {0x125a, 0x125d},
+ {0x1260, 0x1286}, {0x128a, 0x128d}, {0x1290, 0x12ae}, {0x12b2, 0x12b5},
+ {0x12b8, 0x12be}, {0x12c2, 0x12c5}, {0x12c8, 0x12ce}, {0x12d0, 0x12d6},
+ {0x12d8, 0x12ee}, {0x12f0, 0x130e}, {0x1312, 0x1315}, {0x1318, 0x131e},
+ {0x1321, 0x1346}, {0x1348, 0x135a}, {0x1361, 0x137c}, {0x13a0, 0x13f4},
+ {0x1401, 0x141f}, {0x1421, 0x151f}, {0x1521, 0x161f}, {0x1621, 0x1676},
+ {0x1680, 0x169c}, {0x16a0, 0x16f0}, {0x1780, 0x17dc}, {0x17e0, 0x17e9},
+ {0x1800, 0x180a}, {0x1810, 0x1819}, {0x1821, 0x1877}, {0x1880, 0x18a9},
{0x1e00, 0x1e1f}, {0x1e21, 0x1e9b}, {0x1ea0, 0x1ef9}, {0x1f00, 0x1f15},
{0x1f18, 0x1f1d}, {0x1f21, 0x1f45}, {0x1f48, 0x1f4d}, {0x1f50, 0x1f57},
{0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3},
{0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe},
- {0x2000, 0x200b}, {0x2010, 0x201f}, {0x2021, 0x2029}, {0x2030, 0x2046},
- {0x2074, 0x208e}, {0x20a0, 0x20ac}, {0x20d0, 0x20e1}, {0x2100, 0x211f},
- {0x2121, 0x2138}, {0x2153, 0x2182}, {0x2190, 0x21ea}, {0x2200, 0x221f},
- {0x2221, 0x22f1}, {0x2302, 0x231f}, {0x2321, 0x237a}, {0x2400, 0x241f},
- {0x2421, 0x2424}, {0x2440, 0x244a}, {0x2460, 0x24ea}, {0x2500, 0x251f},
- {0x2521, 0x2595}, {0x25a0, 0x25ef}, {0x2600, 0x2613}, {0x261a, 0x261f},
- {0x2621, 0x266f}, {0x2701, 0x2704}, {0x2706, 0x2709}, {0x270c, 0x271f},
- {0x2721, 0x2727}, {0x2729, 0x274b}, {0x274f, 0x2752}, {0x2758, 0x275e},
- {0x2761, 0x2767}, {0x2776, 0x2794}, {0x2798, 0x27af}, {0x27b1, 0x27be},
- {0x3000, 0x301f}, {0x3021, 0x3037}, {0x3041, 0x3094}, {0x3099, 0x309e},
- {0x30a1, 0x30fe}, {0x3105, 0x311f}, {0x3121, 0x312c}, {0x3131, 0x318e},
- {0x3190, 0x319f}, {0x3200, 0x321c}, {0x3221, 0x3243}, {0x3260, 0x327b},
- {0x327f, 0x32b0}, {0x32c0, 0x32cb}, {0x32d0, 0x32fe}, {0x3300, 0x331f},
- {0x3321, 0x3376}, {0x337b, 0x33dd}, {0x33e0, 0x33fe}, {0x4e00, 0x4e1f},
+ {0x2000, 0x200b}, {0x2010, 0x201f}, {0x2021, 0x2029}, {0x202f, 0x2046},
+ {0x2048, 0x204d}, {0x2074, 0x208e}, {0x20a0, 0x20af}, {0x20d0, 0x20e3},
+ {0x2100, 0x211f}, {0x2121, 0x213a}, {0x2153, 0x2183}, {0x2190, 0x21f3},
+ {0x2200, 0x221f}, {0x2221, 0x22f1}, {0x2300, 0x231f}, {0x2321, 0x237b},
+ {0x237d, 0x239a}, {0x2400, 0x241f}, {0x2421, 0x2426}, {0x2440, 0x244a},
+ {0x2460, 0x24ea}, {0x2500, 0x251f}, {0x2521, 0x2595}, {0x25a0, 0x25f7},
+ {0x2600, 0x2613}, {0x2619, 0x261f}, {0x2621, 0x2671}, {0x2701, 0x2704},
+ {0x2706, 0x2709}, {0x270c, 0x271f}, {0x2721, 0x2727}, {0x2729, 0x274b},
+ {0x274f, 0x2752}, {0x2758, 0x275e}, {0x2761, 0x2767}, {0x2776, 0x2794},
+ {0x2798, 0x27af}, {0x27b1, 0x27be}, {0x2800, 0x281f}, {0x2821, 0x28ff},
+ {0x2e80, 0x2e99}, {0x2e9b, 0x2ef3}, {0x2f00, 0x2f1f}, {0x2f21, 0x2fd5},
+ {0x2ff0, 0x2ffb}, {0x3000, 0x301f}, {0x3021, 0x303a}, {0x3041, 0x3094},
+ {0x3099, 0x309e}, {0x30a1, 0x30fe}, {0x3105, 0x311f}, {0x3121, 0x312c},
+ {0x3131, 0x318e}, {0x3190, 0x31b7}, {0x3200, 0x321c}, {0x3221, 0x3243},
+ {0x3260, 0x327b}, {0x327f, 0x32b0}, {0x32c0, 0x32cb}, {0x32d0, 0x32fe},
+ {0x3300, 0x331f}, {0x3321, 0x3376}, {0x337b, 0x33dd}, {0x33e0, 0x33fe},
+ {0x3400, 0x341f}, {0x3421, 0x351f}, {0x3521, 0x361f}, {0x3621, 0x371f},
+ {0x3721, 0x381f}, {0x3821, 0x391f}, {0x3921, 0x3a1f}, {0x3a21, 0x3b1f},
+ {0x3b21, 0x3c1f}, {0x3c21, 0x3d1f}, {0x3d21, 0x3e1f}, {0x3e21, 0x3f1f},
+ {0x3f21, 0x401f}, {0x4021, 0x411f}, {0x4121, 0x421f}, {0x4221, 0x431f},
+ {0x4321, 0x441f}, {0x4421, 0x451f}, {0x4521, 0x461f}, {0x4621, 0x471f},
+ {0x4721, 0x481f}, {0x4821, 0x491f}, {0x4921, 0x4a1f}, {0x4a21, 0x4b1f},
+ {0x4b21, 0x4c1f}, {0x4c21, 0x4d1f}, {0x4d21, 0x4db5}, {0x4e00, 0x4e1f},
{0x4e21, 0x4f1f}, {0x4f21, 0x501f}, {0x5021, 0x511f}, {0x5121, 0x521f},
{0x5221, 0x531f}, {0x5321, 0x541f}, {0x5421, 0x551f}, {0x5521, 0x561f},
{0x5621, 0x571f}, {0x5721, 0x581f}, {0x5821, 0x591f}, {0x5921, 0x5a1f},
{0x9221, 0x931f}, {0x9321, 0x941f}, {0x9421, 0x951f}, {0x9521, 0x961f},
{0x9621, 0x971f}, {0x9721, 0x981f}, {0x9821, 0x991f}, {0x9921, 0x9a1f},
{0x9a21, 0x9b1f}, {0x9b21, 0x9c1f}, {0x9c21, 0x9d1f}, {0x9d21, 0x9e1f},
- {0x9e21, 0x9f1f}, {0x9f21, 0x9fa5}, {0xac00, 0xac1f}, {0xac21, 0xad1f},
- {0xad21, 0xae1f}, {0xae21, 0xaf1f}, {0xaf21, 0xb01f}, {0xb021, 0xb11f},
- {0xb121, 0xb21f}, {0xb221, 0xb31f}, {0xb321, 0xb41f}, {0xb421, 0xb51f},
- {0xb521, 0xb61f}, {0xb621, 0xb71f}, {0xb721, 0xb81f}, {0xb821, 0xb91f},
- {0xb921, 0xba1f}, {0xba21, 0xbb1f}, {0xbb21, 0xbc1f}, {0xbc21, 0xbd1f},
- {0xbd21, 0xbe1f}, {0xbe21, 0xbf1f}, {0xbf21, 0xc01f}, {0xc021, 0xc11f},
- {0xc121, 0xc21f}, {0xc221, 0xc31f}, {0xc321, 0xc41f}, {0xc421, 0xc51f},
- {0xc521, 0xc61f}, {0xc621, 0xc71f}, {0xc721, 0xc81f}, {0xc821, 0xc91f},
- {0xc921, 0xca1f}, {0xca21, 0xcb1f}, {0xcb21, 0xcc1f}, {0xcc21, 0xcd1f},
- {0xcd21, 0xce1f}, {0xce21, 0xcf1f}, {0xcf21, 0xd01f}, {0xd021, 0xd11f},
- {0xd121, 0xd21f}, {0xd221, 0xd31f}, {0xd321, 0xd41f}, {0xd421, 0xd51f},
- {0xd521, 0xd61f}, {0xd621, 0xd71f}, {0xd721, 0xd7a3}, {0xf900, 0xf91f},
- {0xf921, 0xfa1f}, {0xfa21, 0xfa2d}, {0xfb00, 0xfb06}, {0xfb13, 0xfb17},
- {0xfb21, 0xfb36}, {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfc1f},
- {0xfc21, 0xfd1f}, {0xfd21, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7},
- {0xfdf0, 0xfdfb}, {0xfe21, 0xfe23}, {0xfe30, 0xfe44}, {0xfe49, 0xfe52},
- {0xfe54, 0xfe66}, {0xfe68, 0xfe6b}, {0xfe70, 0xfe72}, {0xfe76, 0xfefc},
- {0xff01, 0xff1f}, {0xff21, 0xff5e}, {0xff61, 0xffbe}, {0xffc2, 0xffc7},
- {0xffca, 0xffcf}, {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6},
- {0xffe8, 0xffee}
+ {0x9e21, 0x9f1f}, {0x9f21, 0x9fa5}, {0xa000, 0xa01f}, {0xa021, 0xa11f},
+ {0xa121, 0xa21f}, {0xa221, 0xa31f}, {0xa321, 0xa41f}, {0xa421, 0xa48c},
+ {0xa490, 0xa4a1}, {0xa4a4, 0xa4b3}, {0xa4b5, 0xa4c0}, {0xa4c2, 0xa4c4},
+ {0xac00, 0xac1f}, {0xac21, 0xad1f}, {0xad21, 0xae1f}, {0xae21, 0xaf1f},
+ {0xaf21, 0xb01f}, {0xb021, 0xb11f}, {0xb121, 0xb21f}, {0xb221, 0xb31f},
+ {0xb321, 0xb41f}, {0xb421, 0xb51f}, {0xb521, 0xb61f}, {0xb621, 0xb71f},
+ {0xb721, 0xb81f}, {0xb821, 0xb91f}, {0xb921, 0xba1f}, {0xba21, 0xbb1f},
+ {0xbb21, 0xbc1f}, {0xbc21, 0xbd1f}, {0xbd21, 0xbe1f}, {0xbe21, 0xbf1f},
+ {0xbf21, 0xc01f}, {0xc021, 0xc11f}, {0xc121, 0xc21f}, {0xc221, 0xc31f},
+ {0xc321, 0xc41f}, {0xc421, 0xc51f}, {0xc521, 0xc61f}, {0xc621, 0xc71f},
+ {0xc721, 0xc81f}, {0xc821, 0xc91f}, {0xc921, 0xca1f}, {0xca21, 0xcb1f},
+ {0xcb21, 0xcc1f}, {0xcc21, 0xcd1f}, {0xcd21, 0xce1f}, {0xce21, 0xcf1f},
+ {0xcf21, 0xd01f}, {0xd021, 0xd11f}, {0xd121, 0xd21f}, {0xd221, 0xd31f},
+ {0xd321, 0xd41f}, {0xd421, 0xd51f}, {0xd521, 0xd61f}, {0xd621, 0xd71f},
+ {0xd721, 0xd7a3}, {0xf900, 0xf91f}, {0xf921, 0xfa1f}, {0xfa21, 0xfa2d},
+ {0xfb00, 0xfb06}, {0xfb13, 0xfb17}, {0xfb1d, 0xfb1f}, {0xfb21, 0xfb36},
+ {0xfb38, 0xfb3c}, {0xfb46, 0xfbb1}, {0xfbd3, 0xfc1f}, {0xfc21, 0xfd1f},
+ {0xfd21, 0xfd3f}, {0xfd50, 0xfd8f}, {0xfd92, 0xfdc7}, {0xfdf0, 0xfdfb},
+ {0xfe21, 0xfe23}, {0xfe30, 0xfe44}, {0xfe49, 0xfe52}, {0xfe54, 0xfe66},
+ {0xfe68, 0xfe6b}, {0xfe70, 0xfe72}, {0xfe76, 0xfefc}, {0xff01, 0xff1f},
+ {0xff21, 0xff5e}, {0xff61, 0xffbe}, {0xffc2, 0xffc7}, {0xffca, 0xffcf},
+ {0xffd2, 0xffd7}, {0xffda, 0xffdc}, {0xffe0, 0xffe6}, {0xffe8, 0xffee},
+ {0xfffc, 0xffff}
};
#define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange))
static chr graphCharTable[] = {
- 0x0360, 0x0361, 0x0374, 0x0375, 0x037a, 0x037e, 0x038c, 0x03da, 0x03dc,
- 0x03de, 0x03e0, 0x04c7, 0x04c8, 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0589,
- 0x060c, 0x061b, 0x061f, 0x098f, 0x0990, 0x09b2, 0x09bc, 0x09c7, 0x09c8,
- 0x09d7, 0x09dc, 0x09dd, 0x0a02, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35,
- 0x0a36, 0x0a38, 0x0a39, 0x0a3c, 0x0a47, 0x0a48, 0x0a5e, 0x0a8d, 0x0ab2,
- 0x0ab3, 0x0ad0, 0x0ae0, 0x0b0f, 0x0b10, 0x0b32, 0x0b33, 0x0b47, 0x0b48,
- 0x0b56, 0x0b57, 0x0b5c, 0x0b5d, 0x0b82, 0x0b83, 0x0b99, 0x0b9a, 0x0b9c,
- 0x0b9e, 0x0b9f, 0x0ba3, 0x0ba4, 0x0bd7, 0x0c55, 0x0c56, 0x0c60, 0x0c61,
- 0x0c82, 0x0c83, 0x0cd5, 0x0cd6, 0x0cde, 0x0ce0, 0x0ce1, 0x0d02, 0x0d03,
- 0x0d57, 0x0d60, 0x0d61, 0x0e81, 0x0e82, 0x0e84, 0x0e87, 0x0e88, 0x0e8a,
- 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0ec6, 0x0edc, 0x0edd, 0x0f97,
- 0x0fb9, 0x10fb, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x2300, 0x274d, 0x2756,
- 0x303f, 0xfb1e, 0xfb1f, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74,
- 0xfffc, 0xfffd
+ 0x0374, 0x0375, 0x037a, 0x037e, 0x038c, 0x0488, 0x0489, 0x04c7, 0x04c8,
+ 0x04cb, 0x04cc, 0x04f8, 0x04f9, 0x0589, 0x058a, 0x060c, 0x061b, 0x061f,
+ 0x098f, 0x0990, 0x09b2, 0x09bc, 0x09c7, 0x09c8, 0x09d7, 0x09dc, 0x09dd,
+ 0x0a02, 0x0a0f, 0x0a10, 0x0a32, 0x0a33, 0x0a35, 0x0a36, 0x0a38, 0x0a39,
+ 0x0a3c, 0x0a47, 0x0a48, 0x0a5e, 0x0a8d, 0x0ab2, 0x0ab3, 0x0ad0, 0x0ae0,
+ 0x0b0f, 0x0b10, 0x0b32, 0x0b33, 0x0b47, 0x0b48, 0x0b56, 0x0b57, 0x0b5c,
+ 0x0b5d, 0x0b82, 0x0b83, 0x0b99, 0x0b9a, 0x0b9c, 0x0b9e, 0x0b9f, 0x0ba3,
+ 0x0ba4, 0x0bd7, 0x0c55, 0x0c56, 0x0c60, 0x0c61, 0x0c82, 0x0c83, 0x0cd5,
+ 0x0cd6, 0x0cde, 0x0ce0, 0x0ce1, 0x0d02, 0x0d03, 0x0d57, 0x0d60, 0x0d61,
+ 0x0d82, 0x0d83, 0x0dbd, 0x0dca, 0x0dd6, 0x0e81, 0x0e82, 0x0e84, 0x0e87,
+ 0x0e88, 0x0e8a, 0x0e8d, 0x0ea5, 0x0ea7, 0x0eaa, 0x0eab, 0x0ec6, 0x0edc,
+ 0x0edd, 0x0fcf, 0x1021, 0x1029, 0x102a, 0x10fb, 0x1248, 0x1258, 0x1288,
+ 0x12b0, 0x12c0, 0x1310, 0x1f59, 0x1f5b, 0x1f5d, 0x2070, 0x274d, 0x2756,
+ 0x303e, 0x303f, 0xa4c6, 0xfb3e, 0xfb40, 0xfb41, 0xfb43, 0xfb44, 0xfe74
};
#define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr))
+/*
+ * End of auto-generated Unicode character ranges declarations.
+ */
#define CH NOCELT
*/
static int
nmcces(v)
-struct vars *v;
+ struct vars *v; /* context */
{
- return 0;
+ /*
+ * No multi-character collating elements defined at the moment.
+ */
+ return 0;
}
/*
*/
static int
nleaders(v)
-struct vars *v;
+ struct vars *v; /* context */
{
- return 0;
+ return 0;
}
/*
*/
static struct cvec *
allmcces(v, cv)
-struct vars *v;
-struct cvec *cv; /* this is supposed to have enough room */
+ struct vars *v; /* context */
+ struct cvec *cv; /* this is supposed to have enough room */
{
- return clearcvec(cv);
+ return clearcvec(cv);
}
/*
*/
static celt
element(v, startp, endp)
-struct vars *v;
-chr *startp; /* points to start of name */
-chr *endp; /* points just past end of name */
+ struct vars *v; /* context */
+ chr *startp; /* points to start of name */
+ chr *endp; /* points just past end of name */
{
- struct cname *cn;
- size_t len;
- Tcl_DString ds;
- char *np;
-
- /* generic: one-chr names stand for themselves */
- assert(startp < endp);
- len = endp - startp;
- if (len == 1)
- return *startp;
-
- NOTE(REG_ULOCALE);
-
- /* search table */
- Tcl_DStringInit(&ds);
- np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
- for (cn = cnames; cn->name != NULL; cn++)
- if (strlen(cn->name) == len && strncmp(cn->name, np, len) == 0)
- break; /* NOTE BREAK OUT */
- Tcl_DStringFree(&ds);
- if (cn->name != NULL)
- return CHR(cn->code);
-
- /* couldn't find it */
- ERR(REG_ECOLLATE);
- return 0;
+ struct cname *cn;
+ size_t len;
+ Tcl_DString ds;
+ CONST char *np;
+
+ /* generic: one-chr names stand for themselves */
+ assert(startp < endp);
+ len = endp - startp;
+ if (len == 1) {
+ return *startp;
+ }
+
+ NOTE(REG_ULOCALE);
+
+ /* search table */
+ Tcl_DStringInit(&ds);
+ np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
+ for (cn=cnames; cn->name!=NULL; cn++) {
+ if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) {
+ break; /* NOTE BREAK OUT */
+ }
+ }
+ Tcl_DStringFree(&ds);
+ if (cn->name != NULL) {
+ return CHR(cn->code);
+ }
+
+ /* couldn't find it */
+ ERR(REG_ECOLLATE);
+ return 0;
}
/*
*/
static struct cvec *
range(v, a, b, cases)
-struct vars *v;
-celt a;
-celt b; /* might equal a */
-int cases; /* case-independent? */
+ struct vars *v; /* context */
+ celt a; /* range start */
+ celt b; /* range end, might equal a */
+ int cases; /* case-independent? */
{
- int nchrs;
- struct cvec *cv;
- celt c, lc, uc, tc;
+ int nchrs;
+ struct cvec *cv;
+ celt c, lc, uc, tc;
- if (a != b && !before(a, b)) {
- ERR(REG_ERANGE);
- return NULL;
- }
+ if (a != b && !before(a, b)) {
+ ERR(REG_ERANGE);
+ return NULL;
+ }
- if (!cases) { /* easy version */
- cv = getcvec(v, 0, 1, 0);
- NOERRN();
- addrange(cv, a, b);
- return cv;
- }
+ if (!cases) { /* easy version */
+ cv = getcvec(v, 0, 1, 0);
+ NOERRN();
+ addrange(cv, a, b);
+ return cv;
+ }
- /*
- * When case-independent, it's hard to decide when cvec ranges are
- * usable, so for now at least, we won't try. We allocate enough
- * space for two case variants plus a little extra for the two
- * title case variants.
- */
+ /*
+ * When case-independent, it's hard to decide when cvec ranges are
+ * usable, so for now at least, we won't try. We allocate enough
+ * space for two case variants plus a little extra for the two
+ * title case variants.
+ */
- nchrs = (b - a + 1)*2 + 4;
+ nchrs = (b - a + 1)*2 + 4;
- cv = getcvec(v, nchrs, 0, 0);
- NOERRN();
+ cv = getcvec(v, nchrs, 0, 0);
+ NOERRN();
- for (c = a; c <= b; c++) {
- addchr(cv, c);
- lc = Tcl_UniCharToLower((chr)c);
- uc = Tcl_UniCharToUpper((chr)c);
- tc = Tcl_UniCharToTitle((chr)c);
- if (c != lc) {
- addchr(cv, lc);
- }
- if (c != uc) {
- addchr(cv, uc);
- }
- if (c != tc && tc != uc) {
- addchr(cv, tc);
- }
+ for (c=a; c<=b; c++) {
+ addchr(cv, c);
+ lc = Tcl_UniCharToLower((chr)c);
+ uc = Tcl_UniCharToUpper((chr)c);
+ tc = Tcl_UniCharToTitle((chr)c);
+ if (c != lc) {
+ addchr(cv, lc);
+ }
+ if (c != uc) {
+ addchr(cv, uc);
+ }
+ if (c != tc && tc != uc) {
+ addchr(cv, tc);
}
+ }
- return cv;
+ return cv;
}
/*
- before - is celt x before celt y, for purposes of range legality?
^ static int before(celt, celt);
*/
-static int /* predicate */
+static int /* predicate */
before(x, y)
-celt x;
-celt y;
+ celt x, y; /* collating elements */
{
- /* trivial because no MCCEs */
- if (x < y)
- return 1;
- return 0;
+ /* trivial because no MCCEs */
+ if (x < y) {
+ return 1;
+ }
+ return 0;
}
/*
*/
static struct cvec *
eclass(v, c, cases)
-struct vars *v;
-celt c;
-int cases; /* all cases? */
+ struct vars *v; /* context */
+ celt c; /* Collating element representing
+ * the equivalence class. */
+ int cases; /* all cases? */
{
- struct cvec *cv;
-
- /* crude fake equivalence class for testing */
- if ((v->cflags®_FAKE) && c == 'x') {
- cv = getcvec(v, 4, 0, 0);
- addchr(cv, (chr)'x');
- addchr(cv, (chr)'y');
- if (cases) {
- addchr(cv, (chr)'X');
- addchr(cv, (chr)'Y');
- }
- return cv;
+ struct cvec *cv;
+
+ /* crude fake equivalence class for testing */
+ if ((v->cflags®_FAKE) && c == 'x') {
+ cv = getcvec(v, 4, 0, 0);
+ addchr(cv, (chr)'x');
+ addchr(cv, (chr)'y');
+ if (cases) {
+ addchr(cv, (chr)'X');
+ addchr(cv, (chr)'Y');
}
-
- /* otherwise, none */
- if (cases)
- return allcases(v, c);
- cv = getcvec(v, 1, 0, 0);
- assert(cv != NULL);
- addchr(cv, (chr)c);
return cv;
+ }
+
+ /* otherwise, none */
+ if (cases) {
+ return allcases(v, c);
+ }
+ cv = getcvec(v, 1, 0, 0);
+ assert(cv != NULL);
+ addchr(cv, (chr)c);
+ return cv;
}
/*
*/
static struct cvec *
cclass(v, startp, endp, cases)
-struct vars *v;
-chr *startp; /* where the name starts */
-chr *endp; /* just past the end of the name */
-int cases; /* case-independent? */
+ struct vars *v; /* context */
+ chr *startp; /* where the name starts */
+ chr *endp; /* just past the end of the name */
+ int cases; /* case-independent? */
{
size_t len;
struct cvec *cv = NULL;
Tcl_DString ds;
- char *np, **namePtr;
+ CONST char *np;
+ char **namePtr;
int i, index;
/*
*/
index = -1;
- for (namePtr = classNames, i = 0; *namePtr != NULL; namePtr++, i++) {
+ for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) {
if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) {
index = i;
break;
*/
switch((enum classes) index) {
- case CC_PRINT:
- case CC_ALNUM:
- cv = getcvec(v, NUM_ALPHA_CHAR,
- NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_ALPHA_CHAR; i++) {
- addchr(cv, alphaCharTable[i]);
- }
- for (i = 0; i < NUM_ALPHA_RANGE; i++) {
- addrange(cv, alphaRangeTable[i].start,
- alphaRangeTable[i].end);
- }
- for (i = 0; i < NUM_DIGIT_RANGE; i++) {
- addrange(cv, digitRangeTable[i].start,
- digitRangeTable[i].end);
- }
+ case CC_PRINT:
+ case CC_ALNUM:
+ cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
+ addchr(cv, alphaCharTable[i]);
}
- break;
- case CC_ALPHA:
- cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_ALPHA_RANGE; i++) {
- addrange(cv, alphaRangeTable[i].start,
- alphaRangeTable[i].end);
- }
- for (i = 0; i < NUM_ALPHA_CHAR; i++) {
- addchr(cv, alphaCharTable[i]);
- }
+ for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
+ addrange(cv, alphaRangeTable[i].start,
+ alphaRangeTable[i].end);
}
- break;
- case CC_ASCII:
- cv = getcvec(v, 0, 1, 0);
- if (cv) {
- addrange(cv, 0, 0x7f);
+ for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
+ addrange(cv, digitRangeTable[i].start,
+ digitRangeTable[i].end);
}
- break;
- case CC_BLANK:
- cv = getcvec(v, 2, 0, 0);
- addchr(cv, '\t');
- addchr(cv, ' ');
- break;
- case CC_CNTRL:
- cv = getcvec(v, 0, 2, 0);
- addrange(cv, 0x0, 0x1f);
- addrange(cv, 0x7f, 0x9f);
- break;
- case CC_DIGIT:
- cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_DIGIT_RANGE; i++) {
- addrange(cv, digitRangeTable[i].start,
- digitRangeTable[i].end);
- }
+ }
+ break;
+ case CC_ALPHA:
+ cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
+ addrange(cv, alphaRangeTable[i].start,
+ alphaRangeTable[i].end);
}
- break;
- case CC_PUNCT:
- cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_PUNCT_RANGE; i++) {
- addrange(cv, punctRangeTable[i].start,
- punctRangeTable[i].end);
- }
- for (i = 0; i < NUM_PUNCT_CHAR; i++) {
- addchr(cv, punctCharTable[i]);
- }
+ for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
+ addchr(cv, alphaCharTable[i]);
}
- break;
- case CC_XDIGIT:
- cv = getcvec(v, 0, NUM_DIGIT_RANGE+2, 0);
- if (cv) {
- addrange(cv, '0', '9');
- addrange(cv, 'a', 'f');
- addrange(cv, 'A', 'F');
+ }
+ break;
+ case CC_ASCII:
+ cv = getcvec(v, 0, 1, 0);
+ if (cv) {
+ addrange(cv, 0, 0x7f);
+ }
+ break;
+ case CC_BLANK:
+ cv = getcvec(v, 2, 0, 0);
+ addchr(cv, '\t');
+ addchr(cv, ' ');
+ break;
+ case CC_CNTRL:
+ cv = getcvec(v, 0, 2, 0);
+ addrange(cv, 0x0, 0x1f);
+ addrange(cv, 0x7f, 0x9f);
+ break;
+ case CC_DIGIT:
+ cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
+ addrange(cv, digitRangeTable[i].start,
+ digitRangeTable[i].end);
}
- break;
- case CC_SPACE:
- cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_SPACE_RANGE; i++) {
- addrange(cv, spaceRangeTable[i].start,
- spaceRangeTable[i].end);
- }
- for (i = 0; i < NUM_SPACE_CHAR; i++) {
- addchr(cv, spaceCharTable[i]);
- }
+ }
+ break;
+ case CC_PUNCT:
+ cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_PUNCT_RANGE ; i++) {
+ addrange(cv, punctRangeTable[i].start,
+ punctRangeTable[i].end);
}
- break;
- case CC_LOWER:
- cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_LOWER_RANGE; i++) {
- addrange(cv, lowerRangeTable[i].start,
- lowerRangeTable[i].end);
- }
- for (i = 0; i < NUM_LOWER_CHAR; i++) {
- addchr(cv, lowerCharTable[i]);
- }
+ for (i=0 ; i<NUM_PUNCT_CHAR ; i++) {
+ addchr(cv, punctCharTable[i]);
}
- break;
- case CC_UPPER:
- cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_UPPER_RANGE; i++) {
- addrange(cv, upperRangeTable[i].start,
- upperRangeTable[i].end);
- }
- for (i = 0; i < NUM_UPPER_CHAR; i++) {
- addchr(cv, upperCharTable[i]);
- }
+ }
+ break;
+ case CC_XDIGIT:
+ /*
+ * This is a 3 instead of (NUM_DIGIT_RANGE+2) because I've no
+ * idea how to define the digits 'a' through 'f' in
+ * non-western locales. The concept is quite possibly non
+ * portable, or only used in contextx where the characters
+ * used would be the western ones anyway! Whatever is
+ * actually the case, the number of ranges is fixed (until
+ * someone comes up with a better arrangement!)
+ */
+ cv = getcvec(v, 0, 3, 0);
+ if (cv) {
+ addrange(cv, '0', '9');
+ addrange(cv, 'a', 'f');
+ addrange(cv, 'A', 'F');
+ }
+ break;
+ case CC_SPACE:
+ cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_SPACE_RANGE ; i++) {
+ addrange(cv, spaceRangeTable[i].start,
+ spaceRangeTable[i].end);
}
- break;
- case CC_GRAPH:
- cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0);
- if (cv) {
- for (i = 0; i < NUM_GRAPH_RANGE; i++) {
- addrange(cv, graphRangeTable[i].start,
- graphRangeTable[i].end);
- }
- for (i = 0; i < NUM_GRAPH_CHAR; i++) {
- addchr(cv, graphCharTable[i]);
- }
+ for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
+ addchr(cv, spaceCharTable[i]);
}
- break;
+ }
+ break;
+ case CC_LOWER:
+ cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_LOWER_RANGE ; i++) {
+ addrange(cv, lowerRangeTable[i].start,
+ lowerRangeTable[i].end);
+ }
+ for (i=0 ; i<NUM_LOWER_CHAR ; i++) {
+ addchr(cv, lowerCharTable[i]);
+ }
+ }
+ break;
+ case CC_UPPER:
+ cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_UPPER_RANGE ; i++) {
+ addrange(cv, upperRangeTable[i].start,
+ upperRangeTable[i].end);
+ }
+ for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
+ addchr(cv, upperCharTable[i]);
+ }
+ }
+ break;
+ case CC_GRAPH:
+ cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0);
+ if (cv) {
+ for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
+ addrange(cv, graphRangeTable[i].start,
+ graphRangeTable[i].end);
+ }
+ for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
+ addchr(cv, graphCharTable[i]);
+ }
+ }
+ break;
}
if (cv == NULL) {
ERR(REG_ESPACE);
*/
static struct cvec *
allcases(v, pc)
-struct vars *v;
-pchr pc;
+ struct vars *v; /* context */
+ pchr pc; /* character to get case equivs of */
{
- struct cvec *cv;
- chr c = (chr)pc;
- chr lc, uc, tc;
-
- lc = Tcl_UniCharToLower((chr)c);
- uc = Tcl_UniCharToUpper((chr)c);
- tc = Tcl_UniCharToTitle((chr)c);
-
- if (tc != uc) {
- cv = getcvec(v, 3, 0, 0);
- addchr(cv, tc);
- } else {
- cv = getcvec(v, 2, 0, 0);
- }
- addchr(cv, lc);
- if (lc != uc) {
- addchr(cv, uc);
- }
- return cv;
+ struct cvec *cv;
+ chr c = (chr)pc;
+ chr lc, uc, tc;
+
+ lc = Tcl_UniCharToLower((chr)c);
+ uc = Tcl_UniCharToUpper((chr)c);
+ tc = Tcl_UniCharToTitle((chr)c);
+
+ if (tc != uc) {
+ cv = getcvec(v, 3, 0, 0);
+ addchr(cv, tc);
+ } else {
+ cv = getcvec(v, 2, 0, 0);
+ }
+ addchr(cv, lc);
+ if (lc != uc) {
+ addchr(cv, uc);
+ }
+ return cv;
}
/*
* stop at embedded NULs!
^ static int cmp(CONST chr *, CONST chr *, size_t);
*/
-static int /* 0 for equal, nonzero for unequal */
+static int /* 0 for equal, nonzero for unequal */
cmp(x, y, len)
-CONST chr *x;
-CONST chr *y;
-size_t len; /* exact length of comparison */
+ CONST chr *x, *y; /* strings to compare */
+ size_t len; /* exact length of comparison */
{
- return memcmp(VS(x), VS(y), len*sizeof(chr));
+ return memcmp(VS(x), VS(y), len*sizeof(chr));
}
/*
* stop at embedded NULs!
^ static int casecmp(CONST chr *, CONST chr *, size_t);
*/
-static int /* 0 for equal, nonzero for unequal */
+static int /* 0 for equal, nonzero for unequal */
casecmp(x, y, len)
-CONST chr *x;
-CONST chr *y;
-size_t len; /* exact length of comparison */
+ CONST chr *x, *y; /* strings to compare */
+ size_t len; /* exact length of comparison */
{
- size_t i;
- CONST chr *xp;
- CONST chr *yp;
-
- for (xp = x, yp = y, i = len; i > 0; i--)
- if (Tcl_UniCharToLower(*xp++) != Tcl_UniCharToLower(*yp++))
- return 1;
- return 0;
+ for (; len > 0; len--, x++, y++) {
+ if ((*x!=*y) && (Tcl_UniCharToLower(*x) != Tcl_UniCharToLower(*y))) {
+ return 1;
+ }
+ }
+ return 0;
}
+++ /dev/null
-/*
- * TclRegComp and TclRegExec -- TclRegSub is elsewhere
- *
- * Copyright (c) 1986 by University of Toronto.
- * Written by Henry Spencer. Not derived from licensed software.
- *
- * Permission is granted to anyone to use this software for any
- * purpose on any computer system, and to redistribute it freely,
- * subject to the following restrictions:
- *
- * 1. The author is not responsible for the consequences of use of
- * this software, no matter how awful, even if they arise
- * from defects in it.
- *
- * 2. The origin of this software must not be misrepresented, either
- * by explicit claim or by omission.
- *
- * 3. Altered versions must be plainly marked as such, and must not
- * be misrepresented as being the original software.
- *
- * Beware that some of this code is subtly aware of the way operator
- * precedence is structured in regular expressions. Serious changes in
- * regular-expression syntax might require a total rethink.
- *
- * *** NOTE: this code has been altered slightly for use in Tcl: ***
- * *** 1. Use ckalloc and ckfree instead of malloc and free. ***
- * *** 2. Add extra argument to regexp to specify the real ***
- * *** start of the string separately from the start of the ***
- * *** current search. This is needed to search for multiple ***
- * *** matches within a string. ***
- * *** 3. Names have been changed, e.g. from regcomp to ***
- * *** TclRegComp, to avoid clashes with other ***
- * *** regexp implementations used by applications. ***
- * *** 4. Added errMsg declaration and TclRegError procedure ***
- * *** 5. Various lint-like things, such as casting arguments ***
- * *** in procedure calls. ***
- *
- * *** NOTE: This code has been altered for use in MT-Sturdy Tcl ***
- * *** 1. All use of static variables has been changed to access ***
- * *** fields of a structure. ***
- * *** 2. This in addition to changes to TclRegError makes the ***
- * *** code multi-thread safe. ***
- *
- * RCS: @(#) $Id$
- */
-
-#include "tclInt.h"
-#include "tclPort.h"
-
-/*
- * The variable below is set to NULL before invoking regexp functions
- * and checked after those functions. If an error occurred then TclRegError
- * will set the variable to point to a (static) error message. This
- * mechanism unfortunately does not support multi-threading, but the
- * procedures TclRegError and TclGetRegError can be modified to use
- * thread-specific storage for the variable and thereby make the code
- * thread-safe.
- */
-
-static char *errMsg = NULL;
-
-/*
- * The "internal use only" fields in regexp.h are present to pass info from
- * compile to execute that permits the execute phase to run lots faster on
- * simple cases. They are:
- *
- * regstart char that must begin a match; '\0' if none obvious
- * reganch is the match anchored (at beginning-of-line only)?
- * regmust string (pointer into program) that match must include, or NULL
- * regmlen length of regmust string
- *
- * Regstart and reganch permit very fast decisions on suitable starting points
- * for a match, cutting down the work a lot. Regmust permits fast rejection
- * of lines that cannot possibly match. The regmust tests are costly enough
- * that TclRegComp() supplies a regmust only if the r.e. contains something
- * potentially expensive (at present, the only such thing detected is * or +
- * at the start of the r.e., which can involve a lot of backup). Regmlen is
- * supplied because the test in TclRegExec() needs it and TclRegComp() is
- * computing it anyway.
- */
-
-/*
- * Structure for regexp "program". This is essentially a linear encoding
- * of a nondeterministic finite-state machine (aka syntax charts or
- * "railroad normal form" in parsing technology). Each node is an opcode
- * plus a "next" pointer, possibly plus an operand. "Next" pointers of
- * all nodes except BRANCH implement concatenation; a "next" pointer with
- * a BRANCH on both ends of it is connecting two alternatives. (Here we
- * have one of the subtle syntax dependencies: an individual BRANCH (as
- * opposed to a collection of them) is never concatenated with anything
- * because of operator precedence.) The operand of some types of node is
- * a literal string; for others, it is a node leading into a sub-FSM. In
- * particular, the operand of a BRANCH node is the first node of the branch.
- * (NB this is *not* a tree structure: the tail of the branch connects
- * to the thing following the set of BRANCHes.) The opcodes are:
- */
-
-/* definition number opnd? meaning */
-#define END 0 /* no End of program. */
-#define BOL 1 /* no Match "" at beginning of line. */
-#define EOL 2 /* no Match "" at end of line. */
-#define ANY 3 /* no Match any one character. */
-#define ANYOF 4 /* str Match any character in this string. */
-#define ANYBUT 5 /* str Match any character not in this string. */
-#define BRANCH 6 /* node Match this alternative, or the next... */
-#define BACK 7 /* no Match "", "next" ptr points backward. */
-#define EXACTLY 8 /* str Match this string. */
-#define NOTHING 9 /* no Match empty string. */
-#define STAR 10 /* node Match this (simple) thing 0 or more times. */
-#define PLUS 11 /* node Match this (simple) thing 1 or more times. */
-#define OPEN 20 /* no Mark this point in input as start of #n. */
- /* OPEN+1 is number 1, etc. */
-#define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */
-
-/*
- * Opcode notes:
- *
- * BRANCH The set of branches constituting a single choice are hooked
- * together with their "next" pointers, since precedence prevents
- * anything being concatenated to any individual branch. The
- * "next" pointer of the last BRANCH in a choice points to the
- * thing following the whole choice. This is also where the
- * final "next" pointer of each individual branch points; each
- * branch starts with the operand node of a BRANCH node.
- *
- * BACK Normal "next" pointers all implicitly point forward; BACK
- * exists to make loop structures possible.
- *
- * STAR,PLUS '?', and complex '*' and '+', are implemented as circular
- * BRANCH structures using BACK. Simple cases (one character
- * per match) are implemented with STAR and PLUS for speed
- * and to minimize recursive plunges.
- *
- * OPEN,CLOSE ...are numbered at compile time.
- */
-
-/*
- * A node is one char of opcode followed by two chars of "next" pointer.
- * "Next" pointers are stored as two 8-bit pieces, high order first. The
- * value is a positive offset from the opcode of the node containing it.
- * An operand, if any, simply follows the node. (Note that much of the
- * code generation knows about this implicit relationship.)
- *
- * Using two bytes for the "next" pointer is vast overkill for most things,
- * but allows patterns to get big without disasters.
- */
-#define OP(p) (*(p))
-#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
-#define OPERAND(p) ((p) + 3)
-
-/*
- * See regmagic.h for one further detail of program structure.
- */
-
-
-/*
- * Utility definitions.
- */
-#ifndef CHARBITS
-#define UCHARAT(p) ((int)*(unsigned char *)(p))
-#else
-#define UCHARAT(p) ((int)*(p)&CHARBITS)
-#endif
-
-#define FAIL(m) { TclRegError(m); return(NULL); }
-#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?')
-#define META "^$.[()|?+*\\"
-
-/*
- * Flags to be passed up and down.
- */
-#define HASWIDTH 01 /* Known never to match null string. */
-#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */
-#define SPSTART 04 /* Starts with * or +. */
-#define WORST 0 /* Worst case. */
-
-/*
- * Global work variables for TclRegComp().
- */
-struct regcomp_state {
- char *regparse; /* Input-scan pointer. */
- int regnpar; /* () count. */
- char *regcode; /* Code-emit pointer; ®dummy = don't. */
- long regsize; /* Code size. */
-};
-
-static char regdummy;
-
-/*
- * The first byte of the regexp internal "program" is actually this magic
- * number; the start node begins in the second byte.
- */
-#define MAGIC 0234
-
-
-/*
- * Forward declarations for TclRegComp()'s friends.
- */
-
-static char * reg _ANSI_ARGS_((int paren, int *flagp,
- struct regcomp_state *rcstate));
-static char * regatom _ANSI_ARGS_((int *flagp,
- struct regcomp_state *rcstate));
-static char * regbranch _ANSI_ARGS_((int *flagp,
- struct regcomp_state *rcstate));
-static void regc _ANSI_ARGS_((int b,
- struct regcomp_state *rcstate));
-static void reginsert _ANSI_ARGS_((int op, char *opnd,
- struct regcomp_state *rcstate));
-static char * regnext _ANSI_ARGS_((char *p));
-static char * regnode _ANSI_ARGS_((int op,
- struct regcomp_state *rcstate));
-static void regoptail _ANSI_ARGS_((char *p, char *val));
-static char * regpiece _ANSI_ARGS_((int *flagp,
- struct regcomp_state *rcstate));
-static void regtail _ANSI_ARGS_((char *p, char *val));
-
-#ifdef STRCSPN
-static int strcspn _ANSI_ARGS_((char *s1, char *s2));
-#endif
-
-/*
- - TclRegComp - compile a regular expression into internal code
- *
- * We can't allocate space until we know how big the compiled form will be,
- * but we can't compile it (and thus know how big it is) until we've got a
- * place to put the code. So we cheat: we compile it twice, once with code
- * generation turned off and size counting turned on, and once "for real".
- * This also means that we don't allocate space until we are sure that the
- * thing really will compile successfully, and we never have to move the
- * code and thus invalidate pointers into it. (Note that it has to be in
- * one piece because free() must be able to free it all.)
- *
- * Beware that the optimization-preparation code in here knows about some
- * of the structure of the compiled regexp.
- */
-regexp *
-TclRegComp(exp)
-char *exp;
-{
- register regexp *r;
- register char *scan;
- register char *longest;
- register int len;
- int flags;
- struct regcomp_state state;
- struct regcomp_state *rcstate= &state;
-
- if (exp == NULL)
- FAIL("NULL argument");
-
- /* First pass: determine size, legality. */
- rcstate->regparse = exp;
- rcstate->regnpar = 1;
- rcstate->regsize = 0L;
- rcstate->regcode = ®dummy;
- regc(MAGIC, rcstate);
- if (reg(0, &flags, rcstate) == NULL)
- return(NULL);
-
- /* Small enough for pointer-storage convention? */
- if (rcstate->regsize >= 32767L) /* Probably could be 65535L. */
- FAIL("regexp too big");
-
- /* Allocate space. */
- r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)rcstate->regsize);
- if (r == NULL)
- FAIL("out of space");
-
- /* Second pass: emit code. */
- rcstate->regparse = exp;
- rcstate->regnpar = 1;
- rcstate->regcode = r->program;
- regc(MAGIC, rcstate);
- if (reg(0, &flags, rcstate) == NULL)
- return(NULL);
-
- /* Dig out information for optimizations. */
- r->regstart = '\0'; /* Worst-case defaults. */
- r->reganch = 0;
- r->regmust = NULL;
- r->regmlen = 0;
- scan = r->program+1; /* First BRANCH. */
- if (OP(regnext(scan)) == END) { /* Only one top-level choice. */
- scan = OPERAND(scan);
-
- /* Starting-point info. */
- if (OP(scan) == EXACTLY)
- r->regstart = *OPERAND(scan);
- else if (OP(scan) == BOL)
- r->reganch++;
-
- /*
- * If there's something expensive in the r.e., find the
- * longest literal string that must appear and make it the
- * regmust. Resolve ties in favor of later strings, since
- * the regstart check works with the beginning of the r.e.
- * and avoiding duplication strengthens checking. Not a
- * strong reason, but sufficient in the absence of others.
- */
- if (flags&SPSTART) {
- longest = NULL;
- len = 0;
- for (; scan != NULL; scan = regnext(scan))
- if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) {
- longest = OPERAND(scan);
- len = strlen(OPERAND(scan));
- }
- r->regmust = longest;
- r->regmlen = len;
- }
- }
-
- return(r);
-}
-
-/*
- - reg - regular expression, i.e. main body or parenthesized thing
- *
- * Caller must absorb opening parenthesis.
- *
- * Combining parenthesis handling with the base level of regular expression
- * is a trifle forced, but the need to tie the tails of the branches to what
- * follows makes it hard to avoid.
- */
-static char *
-reg(paren, flagp, rcstate)
-int paren; /* Parenthesized? */
-int *flagp;
-struct regcomp_state *rcstate;
-{
- register char *ret;
- register char *br;
- register char *ender;
- register int parno = 0;
- int flags;
-
- *flagp = HASWIDTH; /* Tentatively. */
-
- /* Make an OPEN node, if parenthesized. */
- if (paren) {
- if (rcstate->regnpar >= NSUBEXP)
- FAIL("too many ()");
- parno = rcstate->regnpar;
- rcstate->regnpar++;
- ret = regnode(OPEN+parno,rcstate);
- } else
- ret = NULL;
-
- /* Pick up the branches, linking them together. */
- br = regbranch(&flags,rcstate);
- if (br == NULL)
- return(NULL);
- if (ret != NULL)
- regtail(ret, br); /* OPEN -> first. */
- else
- ret = br;
- if (!(flags&HASWIDTH))
- *flagp &= ~HASWIDTH;
- *flagp |= flags&SPSTART;
- while (*rcstate->regparse == '|') {
- rcstate->regparse++;
- br = regbranch(&flags,rcstate);
- if (br == NULL)
- return(NULL);
- regtail(ret, br); /* BRANCH -> BRANCH. */
- if (!(flags&HASWIDTH))
- *flagp &= ~HASWIDTH;
- *flagp |= flags&SPSTART;
- }
-
- /* Make a closing node, and hook it on the end. */
- ender = regnode((paren) ? CLOSE+parno : END,rcstate);
- regtail(ret, ender);
-
- /* Hook the tails of the branches to the closing node. */
- for (br = ret; br != NULL; br = regnext(br))
- regoptail(br, ender);
-
- /* Check for proper termination. */
- if (paren && *rcstate->regparse++ != ')') {
- FAIL("unmatched ()");
- } else if (!paren && *rcstate->regparse != '\0') {
- if (*rcstate->regparse == ')') {
- FAIL("unmatched ()");
- } else
- FAIL("junk on end"); /* "Can't happen". */
- /* NOTREACHED */
- }
-
- return(ret);
-}
-
-/*
- - regbranch - one alternative of an | operator
- *
- * Implements the concatenation operator.
- */
-static char *
-regbranch(flagp, rcstate)
-int *flagp;
-struct regcomp_state *rcstate;
-{
- register char *ret;
- register char *chain;
- register char *latest;
- int flags;
-
- *flagp = WORST; /* Tentatively. */
-
- ret = regnode(BRANCH,rcstate);
- chain = NULL;
- while (*rcstate->regparse != '\0' && *rcstate->regparse != '|' &&
- *rcstate->regparse != ')') {
- latest = regpiece(&flags, rcstate);
- if (latest == NULL)
- return(NULL);
- *flagp |= flags&HASWIDTH;
- if (chain == NULL) /* First piece. */
- *flagp |= flags&SPSTART;
- else
- regtail(chain, latest);
- chain = latest;
- }
- if (chain == NULL) /* Loop ran zero times. */
- (void) regnode(NOTHING,rcstate);
-
- return(ret);
-}
-
-/*
- - regpiece - something followed by possible [*+?]
- *
- * Note that the branching code sequences used for ? and the general cases
- * of * and + are somewhat optimized: they use the same NOTHING node as
- * both the endmarker for their branch list and the body of the last branch.
- * It might seem that this node could be dispensed with entirely, but the
- * endmarker role is not redundant.
- */
-static char *
-regpiece(flagp, rcstate)
-int *flagp;
-struct regcomp_state *rcstate;
-{
- register char *ret;
- register char op;
- register char *next;
- int flags;
-
- ret = regatom(&flags,rcstate);
- if (ret == NULL)
- return(NULL);
-
- op = *rcstate->regparse;
- if (!ISMULT(op)) {
- *flagp = flags;
- return(ret);
- }
-
- if (!(flags&HASWIDTH) && op != '?')
- FAIL("*+ operand could be empty");
- *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
-
- if (op == '*' && (flags&SIMPLE))
- reginsert(STAR, ret, rcstate);
- else if (op == '*') {
- /* Emit x* as (x&|), where & means "self". */
- reginsert(BRANCH, ret, rcstate); /* Either x */
- regoptail(ret, regnode(BACK,rcstate)); /* and loop */
- regoptail(ret, ret); /* back */
- regtail(ret, regnode(BRANCH,rcstate)); /* or */
- regtail(ret, regnode(NOTHING,rcstate)); /* null. */
- } else if (op == '+' && (flags&SIMPLE))
- reginsert(PLUS, ret, rcstate);
- else if (op == '+') {
- /* Emit x+ as x(&|), where & means "self". */
- next = regnode(BRANCH,rcstate); /* Either */
- regtail(ret, next);
- regtail(regnode(BACK,rcstate), ret); /* loop back */
- regtail(next, regnode(BRANCH,rcstate)); /* or */
- regtail(ret, regnode(NOTHING,rcstate)); /* null. */
- } else if (op == '?') {
- /* Emit x? as (x|) */
- reginsert(BRANCH, ret, rcstate); /* Either x */
- regtail(ret, regnode(BRANCH,rcstate)); /* or */
- next = regnode(NOTHING,rcstate); /* null. */
- regtail(ret, next);
- regoptail(ret, next);
- }
- rcstate->regparse++;
- if (ISMULT(*rcstate->regparse))
- FAIL("nested *?+");
-
- return(ret);
-}
-
-/*
- - regatom - the lowest level
- *
- * Optimization: gobbles an entire sequence of ordinary characters so that
- * it can turn them into a single node, which is smaller to store and
- * faster to run. Backslashed characters are exceptions, each becoming a
- * separate node; the code is simpler that way and it's not worth fixing.
- */
-static char *
-regatom(flagp, rcstate)
-int *flagp;
-struct regcomp_state *rcstate;
-{
- register char *ret;
- int flags;
-
- *flagp = WORST; /* Tentatively. */
-
- switch (*rcstate->regparse++) {
- case '^':
- ret = regnode(BOL,rcstate);
- break;
- case '$':
- ret = regnode(EOL,rcstate);
- break;
- case '.':
- ret = regnode(ANY,rcstate);
- *flagp |= HASWIDTH|SIMPLE;
- break;
- case '[': {
- register int clss;
- register int classend;
-
- if(rcstate->regparse[0] != '\\' &&
- rcstate->regparse[0] != '^' &&
- rcstate->regparse[1] == ']') {
- ret = regnode(EXACTLY,rcstate);
- regc(*rcstate->regparse++,rcstate);
- regc('\0',rcstate);
- rcstate->regparse++;
- *flagp |= HASWIDTH|SIMPLE;
- break;
- }
- if (*rcstate->regparse == '^') { /* Complement of range. */
- ret = regnode(ANYBUT,rcstate);
- rcstate->regparse++;
- } else
- ret = regnode(ANYOF,rcstate);
- if (*rcstate->regparse == ']' || *rcstate->regparse == '-')
- regc(*rcstate->regparse++,rcstate);
- while (*rcstate->regparse != '\0' && *rcstate->regparse != ']') {
- if (*rcstate->regparse == '-') {
- rcstate->regparse++;
- if (*rcstate->regparse == ']' || *rcstate->regparse == '\0')
- regc('-',rcstate);
- else {
- clss = UCHARAT(rcstate->regparse-2)+1;
- classend = UCHARAT(rcstate->regparse);
- if (clss > classend+1)
- FAIL("invalid [] range");
- for (; clss <= classend; clss++)
- regc((char)clss,rcstate);
- rcstate->regparse++;
- }
- } else
- regc(*rcstate->regparse++,rcstate);
- }
- regc('\0',rcstate);
- if (*rcstate->regparse != ']')
- FAIL("unmatched []");
- rcstate->regparse++;
- *flagp |= HASWIDTH|SIMPLE;
- }
- break;
- case '(':
- ret = reg(1, &flags, rcstate);
- if (ret == NULL)
- return(NULL);
- *flagp |= flags&(HASWIDTH|SPSTART);
- break;
- case '\0':
- case '|':
- case ')':
- FAIL("internal urp"); /* Supposed to be caught earlier. */
- /* NOTREACHED */
- case '?':
- case '+':
- case '*':
- FAIL("?+* follows nothing");
- /* NOTREACHED */
- case '\\':
- if (*rcstate->regparse == '\0')
- FAIL("trailing \\");
- ret = regnode(EXACTLY,rcstate);
- regc(*rcstate->regparse++,rcstate);
- regc('\0',rcstate);
- *flagp |= HASWIDTH|SIMPLE;
- break;
- default: {
- register int len;
- register char ender;
-
- rcstate->regparse--;
- len = strcspn(rcstate->regparse, META);
- if (len <= 0)
- FAIL("internal disaster");
- ender = *(rcstate->regparse+len);
- if (len > 1 && ISMULT(ender))
- len--; /* Back off clear of ?+* operand. */
- *flagp |= HASWIDTH;
- if (len == 1)
- *flagp |= SIMPLE;
- ret = regnode(EXACTLY,rcstate);
- while (len > 0) {
- regc(*rcstate->regparse++,rcstate);
- len--;
- }
- regc('\0',rcstate);
- }
- break;
- }
-
- return(ret);
-}
-
-/*
- - regnode - emit a node
- */
-static char * /* Location. */
-regnode(op, rcstate)
-int op;
-struct regcomp_state *rcstate;
-{
- register char *ret;
- register char *ptr;
-
- ret = rcstate->regcode;
- if (ret == ®dummy) {
- rcstate->regsize += 3;
- return(ret);
- }
-
- ptr = ret;
- *ptr++ = (char)op;
- *ptr++ = '\0'; /* Null "next" pointer. */
- *ptr++ = '\0';
- rcstate->regcode = ptr;
-
- return(ret);
-}
-
-/*
- - regc - emit (if appropriate) a byte of code
- */
-static void
-regc(b, rcstate)
-int b;
-struct regcomp_state *rcstate;
-{
- if (rcstate->regcode != ®dummy)
- *rcstate->regcode++ = (char)b;
- else
- rcstate->regsize++;
-}
-
-/*
- - reginsert - insert an operator in front of already-emitted operand
- *
- * Means relocating the operand.
- */
-static void
-reginsert(op, opnd, rcstate)
-int op;
-char *opnd;
-struct regcomp_state *rcstate;
-{
- register char *src;
- register char *dst;
- register char *place;
-
- if (rcstate->regcode == ®dummy) {
- rcstate->regsize += 3;
- return;
- }
-
- src = rcstate->regcode;
- rcstate->regcode += 3;
- dst = rcstate->regcode;
- while (src > opnd)
- *--dst = *--src;
-
- place = opnd; /* Op node, where operand used to be. */
- *place++ = (char)op;
- *place++ = '\0';
- *place = '\0';
-}
-
-/*
- - regtail - set the next-pointer at the end of a node chain
- */
-static void
-regtail(p, val)
-char *p;
-char *val;
-{
- register char *scan;
- register char *temp;
- register int offset;
-
- if (p == ®dummy)
- return;
-
- /* Find last node. */
- scan = p;
- for (;;) {
- temp = regnext(scan);
- if (temp == NULL)
- break;
- scan = temp;
- }
-
- if (OP(scan) == BACK)
- offset = scan - val;
- else
- offset = val - scan;
- *(scan+1) = (char)((offset>>8)&0377);
- *(scan+2) = (char)(offset&0377);
-}
-
-/*
- - regoptail - regtail on operand of first argument; nop if operandless
- */
-static void
-regoptail(p, val)
-char *p;
-char *val;
-{
- /* "Operandless" and "op != BRANCH" are synonymous in practice. */
- if (p == NULL || p == ®dummy || OP(p) != BRANCH)
- return;
- regtail(OPERAND(p), val);
-}
-
-/*
- * TclRegExec and friends
- */
-
-/*
- * Global work variables for TclRegExec().
- */
-struct regexec_state {
- char *reginput; /* String-input pointer. */
- char *regbol; /* Beginning of input, for ^ check. */
- char **regstartp; /* Pointer to startp array. */
- char **regendp; /* Ditto for endp. */
-};
-
-/*
- * Forwards.
- */
-static int regtry _ANSI_ARGS_((regexp *prog, char *string,
- struct regexec_state *restate));
-static int regmatch _ANSI_ARGS_((char *prog,
- struct regexec_state *restate));
-static int regrepeat _ANSI_ARGS_((char *p,
- struct regexec_state *restate));
-
-#ifdef DEBUG
-int regnarrate = 0;
-void regdump _ANSI_ARGS_((regexp *r));
-static char *regprop _ANSI_ARGS_((char *op));
-#endif
-
-/*
- - TclRegExec - match a regexp against a string
- */
-int
-TclRegExec(prog, string, start)
-register regexp *prog;
-register char *string;
-char *start;
-{
- register char *s;
- struct regexec_state state;
- struct regexec_state *restate= &state;
-
- /* Be paranoid... */
- if (prog == NULL || string == NULL) {
- TclRegError("NULL parameter");
- return(0);
- }
-
- /* Check validity of program. */
- if (UCHARAT(prog->program) != MAGIC) {
- TclRegError("corrupted program");
- return(0);
- }
-
- /* If there is a "must appear" string, look for it. */
- if (prog->regmust != NULL) {
- s = string;
- while ((s = strchr(s, prog->regmust[0])) != NULL) {
- if (strncmp(s, prog->regmust, (size_t) prog->regmlen)
- == 0)
- break; /* Found it. */
- s++;
- }
- if (s == NULL) /* Not present. */
- return(0);
- }
-
- /* Mark beginning of line for ^ . */
- restate->regbol = start;
-
- /* Simplest case: anchored match need be tried only once. */
- if (prog->reganch)
- return(regtry(prog, string, restate));
-
- /* Messy cases: unanchored match. */
- s = string;
- if (prog->regstart != '\0')
- /* We know what char it must start with. */
- while ((s = strchr(s, prog->regstart)) != NULL) {
- if (regtry(prog, s, restate))
- return(1);
- s++;
- }
- else
- /* We don't -- general case. */
- do {
- if (regtry(prog, s, restate))
- return(1);
- } while (*s++ != '\0');
-
- /* Failure. */
- return(0);
-}
-
-/*
- - regtry - try match at specific point
- */
-static int /* 0 failure, 1 success */
-regtry(prog, string, restate)
-regexp *prog;
-char *string;
-struct regexec_state *restate;
-{
- register int i;
- register char **sp;
- register char **ep;
-
- restate->reginput = string;
- restate->regstartp = prog->startp;
- restate->regendp = prog->endp;
-
- sp = prog->startp;
- ep = prog->endp;
- for (i = NSUBEXP; i > 0; i--) {
- *sp++ = NULL;
- *ep++ = NULL;
- }
- if (regmatch(prog->program + 1,restate)) {
- prog->startp[0] = string;
- prog->endp[0] = restate->reginput;
- return(1);
- } else
- return(0);
-}
-
-/*
- - regmatch - main matching routine
- *
- * Conceptually the strategy is simple: check to see whether the current
- * node matches, call self recursively to see whether the rest matches,
- * and then act accordingly. In practice we make some effort to avoid
- * recursion, in particular by going through "ordinary" nodes (that don't
- * need to know whether the rest of the match failed) by a loop instead of
- * by recursion.
- */
-static int /* 0 failure, 1 success */
-regmatch(prog, restate)
-char *prog;
-struct regexec_state *restate;
-{
- register char *scan; /* Current node. */
- char *next; /* Next node. */
-
- scan = prog;
-#ifdef DEBUG
- if (scan != NULL && regnarrate)
- fprintf(stderr, "%s(\n", regprop(scan));
-#endif
- while (scan != NULL) {
-#ifdef DEBUG
- if (regnarrate)
- fprintf(stderr, "%s...\n", regprop(scan));
-#endif
- next = regnext(scan);
-
- switch (OP(scan)) {
- case BOL:
- if (restate->reginput != restate->regbol) {
- return 0;
- }
- break;
- case EOL:
- if (*restate->reginput != '\0') {
- return 0;
- }
- break;
- case ANY:
- if (*restate->reginput == '\0') {
- return 0;
- }
- restate->reginput++;
- break;
- case EXACTLY: {
- register int len;
- register char *opnd;
-
- opnd = OPERAND(scan);
- /* Inline the first character, for speed. */
- if (*opnd != *restate->reginput) {
- return 0 ;
- }
- len = strlen(opnd);
- if (len > 1 && strncmp(opnd, restate->reginput, (size_t) len)
- != 0) {
- return 0;
- }
- restate->reginput += len;
- break;
- }
- case ANYOF:
- if (*restate->reginput == '\0'
- || strchr(OPERAND(scan), *restate->reginput) == NULL) {
- return 0;
- }
- restate->reginput++;
- break;
- case ANYBUT:
- if (*restate->reginput == '\0'
- || strchr(OPERAND(scan), *restate->reginput) != NULL) {
- return 0;
- }
- restate->reginput++;
- break;
- case NOTHING:
- break;
- case BACK:
- break;
- case OPEN+1:
- case OPEN+2:
- case OPEN+3:
- case OPEN+4:
- case OPEN+5:
- case OPEN+6:
- case OPEN+7:
- case OPEN+8:
- case OPEN+9: {
- register int no;
- register char *save;
-
- doOpen:
- no = OP(scan) - OPEN;
- save = restate->reginput;
-
- if (regmatch(next,restate)) {
- /*
- * Don't set startp if some later invocation of the
- * same parentheses already has.
- */
- if (restate->regstartp[no] == NULL) {
- restate->regstartp[no] = save;
- }
- return 1;
- } else {
- return 0;
- }
- }
- case CLOSE+1:
- case CLOSE+2:
- case CLOSE+3:
- case CLOSE+4:
- case CLOSE+5:
- case CLOSE+6:
- case CLOSE+7:
- case CLOSE+8:
- case CLOSE+9: {
- register int no;
- register char *save;
-
- doClose:
- no = OP(scan) - CLOSE;
- save = restate->reginput;
-
- if (regmatch(next,restate)) {
- /*
- * Don't set endp if some later
- * invocation of the same parentheses
- * already has.
- */
- if (restate->regendp[no] == NULL)
- restate->regendp[no] = save;
- return 1;
- } else {
- return 0;
- }
- }
- case BRANCH: {
- register char *save;
-
- if (OP(next) != BRANCH) { /* No choice. */
- next = OPERAND(scan); /* Avoid recursion. */
- } else {
- do {
- save = restate->reginput;
- if (regmatch(OPERAND(scan),restate))
- return(1);
- restate->reginput = save;
- scan = regnext(scan);
- } while (scan != NULL && OP(scan) == BRANCH);
- return 0;
- }
- break;
- }
- case STAR:
- case PLUS: {
- register char nextch;
- register int no;
- register char *save;
- register int min;
-
- /*
- * Lookahead to avoid useless match attempts
- * when we know what character comes next.
- */
- nextch = '\0';
- if (OP(next) == EXACTLY)
- nextch = *OPERAND(next);
- min = (OP(scan) == STAR) ? 0 : 1;
- save = restate->reginput;
- no = regrepeat(OPERAND(scan),restate);
- while (no >= min) {
- /* If it could work, try it. */
- if (nextch == '\0' || *restate->reginput == nextch)
- if (regmatch(next,restate))
- return(1);
- if (nextch != '\0' && no > (min + 1)) {
- char tmp = *(save + no);
- char *p;
- *(save + no) = 0;
- p = strrchr(save, nextch);
- *(save + no) = tmp;
- if (p != NULL)
- no = p - save + 1;
- else
- no = 0;
- }
-
- /* Couldn't or didn't -- back up. */
- no--;
- restate->reginput = save + no;
- }
- return(0);
- }
- case END:
- return(1); /* Success! */
- default:
- if (OP(scan) > OPEN && OP(scan) < OPEN+NSUBEXP) {
- goto doOpen;
- } else if (OP(scan) > CLOSE && OP(scan) < CLOSE+NSUBEXP) {
- goto doClose;
- }
- TclRegError("memory corruption");
- return 0;
- }
-
- scan = next;
- }
-
- /*
- * We get here only if there's trouble -- normally "case END" is
- * the terminating point.
- */
- TclRegError("corrupted pointers");
- return(0);
-}
-
-/*
- - regrepeat - repeatedly match something simple, report how many
- */
-static int
-regrepeat(p, restate)
-char *p;
-struct regexec_state *restate;
-{
- register int count = 0;
- register char *scan;
- register char *opnd;
-
- scan = restate->reginput;
- opnd = OPERAND(p);
- switch (OP(p)) {
- case ANY:
- count = strlen(scan);
- scan += count;
- break;
- case EXACTLY:
- while (*opnd == *scan) {
- count++;
- scan++;
- }
- break;
- case ANYOF:
- while (*scan != '\0' && strchr(opnd, *scan) != NULL) {
- count++;
- scan++;
- }
- break;
- case ANYBUT:
- while (*scan != '\0' && strchr(opnd, *scan) == NULL) {
- count++;
- scan++;
- }
- break;
- default: /* Oh dear. Called inappropriately. */
- TclRegError("internal foulup");
- count = 0; /* Best compromise. */
- break;
- }
- restate->reginput = scan;
-
- return(count);
-}
-
-/*
- - regnext - dig the "next" pointer out of a node
- */
-static char *
-regnext(p)
-register char *p;
-{
- register int offset;
-
- if (p == ®dummy)
- return(NULL);
-
- offset = NEXT(p);
- if (offset == 0)
- return(NULL);
-
- if (OP(p) == BACK)
- return(p-offset);
- else
- return(p+offset);
-}
-
-#ifdef DEBUG
-
-static char *regprop();
-
-/*
- - regdump - dump a regexp onto stdout in vaguely comprehensible form
- */
-void
-regdump(r)
-regexp *r;
-{
- register char *s;
- register char op = EXACTLY; /* Arbitrary non-END op. */
- register char *next;
-
-
- s = r->program + 1;
- while (op != END) { /* While that wasn't END last time... */
- op = OP(s);
- printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */
- next = regnext(s);
- if (next == NULL) /* Next ptr. */
- printf("(0)");
- else
- printf("(%d)", (s-r->program)+(next-s));
- s += 3;
- if (op == ANYOF || op == ANYBUT || op == EXACTLY) {
- /* Literal string, where present. */
- while (*s != '\0') {
- putchar(*s);
- s++;
- }
- s++;
- }
- putchar('\n');
- }
-
- /* Header fields of interest. */
- if (r->regstart != '\0')
- printf("start `%c' ", r->regstart);
- if (r->reganch)
- printf("anchored ");
- if (r->regmust != NULL)
- printf("must have \"%s\"", r->regmust);
- printf("\n");
-}
-
-/*
- - regprop - printable representation of opcode
- */
-static char *
-regprop(op)
-char *op;
-{
- register char *p;
- static char buf[50];
-
- (void) strcpy(buf, ":");
-
- switch (OP(op)) {
- case BOL:
- p = "BOL";
- break;
- case EOL:
- p = "EOL";
- break;
- case ANY:
- p = "ANY";
- break;
- case ANYOF:
- p = "ANYOF";
- break;
- case ANYBUT:
- p = "ANYBUT";
- break;
- case BRANCH:
- p = "BRANCH";
- break;
- case EXACTLY:
- p = "EXACTLY";
- break;
- case NOTHING:
- p = "NOTHING";
- break;
- case BACK:
- p = "BACK";
- break;
- case END:
- p = "END";
- break;
- case OPEN+1:
- case OPEN+2:
- case OPEN+3:
- case OPEN+4:
- case OPEN+5:
- case OPEN+6:
- case OPEN+7:
- case OPEN+8:
- case OPEN+9:
- sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
- p = NULL;
- break;
- case CLOSE+1:
- case CLOSE+2:
- case CLOSE+3:
- case CLOSE+4:
- case CLOSE+5:
- case CLOSE+6:
- case CLOSE+7:
- case CLOSE+8:
- case CLOSE+9:
- sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
- p = NULL;
- break;
- case STAR:
- p = "STAR";
- break;
- case PLUS:
- p = "PLUS";
- break;
- default:
- if (OP(op) > OPEN && OP(op) < OPEN+NSUBEXP) {
- sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
- p = NULL;
- break;
- } else if (OP(op) > CLOSE && OP(op) < CLOSE+NSUBEXP) {
- sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
- p = NULL;
- } else {
- TclRegError("corrupted opcode");
- }
- break;
- }
- if (p != NULL)
- (void) strcat(buf, p);
- return(buf);
-}
-#endif
-
-/*
- * The following is provided for those people who do not have strcspn() in
- * their C libraries. They should get off their butts and do something
- * about it; at least one public-domain implementation of those (highly
- * useful) string routines has been published on Usenet.
- */
-#ifdef STRCSPN
-/*
- * strcspn - find length of initial segment of s1 consisting entirely
- * of characters not from s2
- */
-
-static int
-strcspn(s1, s2)
-char *s1;
-char *s2;
-{
- register char *scan1;
- register char *scan2;
- register int count;
-
- count = 0;
- for (scan1 = s1; *scan1 != '\0'; scan1++) {
- for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */
- if (*scan1 == *scan2++)
- return(count);
- count++;
- }
- return(count);
-}
-#endif
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclRegError --
- *
- * This procedure is invoked by the regexp code when an error
- * occurs. It saves the error message so it can be seen by the
- * code that called Spencer's code.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The value of "string" is saved in "errMsg".
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclRegError(string)
- char *string; /* Error message. */
-{
- errMsg = string;
-}
-
-char *
-TclGetRegError()
-{
- return errMsg;
-}
#
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# to preserve backwards compatibility.
declare 0 generic {
- int Tcl_PkgProvideEx(Tcl_Interp *interp, char *name, char *version, \
- ClientData clientData)
+ int Tcl_PkgProvideEx(Tcl_Interp* interp, CONST char* name,
+ CONST char* version, ClientData clientData)
}
declare 1 generic {
- char * Tcl_PkgRequireEx(Tcl_Interp *interp, char *name, char *version, \
- int exact, ClientData *clientDataPtr)
+ CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, CONST char *name,
+ CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 2 generic {
- void Tcl_Panic(char *format, ...)
+ void Tcl_Panic(CONST char *format, ...)
}
declare 3 generic {
char * Tcl_Alloc(unsigned int size)
char * Tcl_Realloc(char *ptr, unsigned int size)
}
declare 6 generic {
- char * Tcl_DbCkalloc(unsigned int size, char *file, int line)
+ char * Tcl_DbCkalloc(unsigned int size, CONST char *file, int line)
}
declare 7 generic {
- int Tcl_DbCkfree(char *ptr, char *file, int line)
+ int Tcl_DbCkfree(char *ptr, CONST char *file, int line)
}
declare 8 generic {
- char * Tcl_DbCkrealloc(char *ptr, unsigned int size, char *file, int line)
+ char * Tcl_DbCkrealloc(char *ptr, unsigned int size,
+ CONST char *file, int line)
}
# Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix,
# compatibility reasons.
declare 9 unix {
- void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, \
+ void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
ClientData clientData)
}
declare 10 unix {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 generic {
- void Tcl_AppendToObj(Tcl_Obj *objPtr, char *bytes, int length)
+ void Tcl_AppendToObj(Tcl_Obj* objPtr, CONST char* bytes, int length)
}
declare 17 generic {
Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *CONST objv[])
}
declare 18 generic {
- int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_ObjType *typePtr)
}
declare 19 generic {
- void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, char *file, int line)
+ void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
}
declare 20 generic {
- void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, char *file, int line)
+ void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, CONST char *file, int line)
}
declare 21 generic {
- int Tcl_DbIsShared(Tcl_Obj *objPtr, char *file, int line)
+ int Tcl_DbIsShared(Tcl_Obj *objPtr, CONST char *file, int line)
}
declare 22 generic {
- Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, char *file, int line)
+ Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, CONST char *file, int line)
}
declare 23 generic {
- Tcl_Obj * Tcl_DbNewByteArrayObj(unsigned char *bytes, int length, \
- char *file, int line)
+ Tcl_Obj * Tcl_DbNewByteArrayObj(CONST unsigned char *bytes, int length,
+ CONST char *file, int line)
}
declare 24 generic {
- Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, char *file, int line)
+ Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue,
+ CONST char *file, int line)
}
declare 25 generic {
- Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *CONST objv[], char *file, \
- int line)
+ Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *CONST *objv,
+ CONST char *file, int line)
}
declare 26 generic {
- Tcl_Obj * Tcl_DbNewLongObj(long longValue, char *file, int line)
+ Tcl_Obj * Tcl_DbNewLongObj(long longValue, CONST char *file, int line)
}
declare 27 generic {
- Tcl_Obj * Tcl_DbNewObj(char *file, int line)
+ Tcl_Obj * Tcl_DbNewObj(CONST char *file, int line)
}
declare 28 generic {
- Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, \
- char *file, int line)
+ Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length,
+ CONST char *file, int line)
}
declare 29 generic {
Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr)
void TclFreeObj(Tcl_Obj *objPtr)
}
declare 31 generic {
- int Tcl_GetBoolean(Tcl_Interp *interp, char *str, int *boolPtr)
+ int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *str, int *boolPtr)
}
declare 32 generic {
- int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *boolPtr)
}
declare 33 generic {
unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 34 generic {
- int Tcl_GetDouble(Tcl_Interp *interp, char *str, double *doublePtr)
+ int Tcl_GetDouble(Tcl_Interp *interp, CONST char *str, double *doublePtr)
}
declare 35 generic {
- int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
declare 36 generic {
- int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \
- char **tablePtr, char *msg, int flags, int *indexPtr)
+ int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ CONST84 char **tablePtr, CONST char *msg, int flags, int *indexPtr)
}
declare 37 generic {
- int Tcl_GetInt(Tcl_Interp *interp, char *str, int *intPtr)
+ int Tcl_GetInt(Tcl_Interp *interp, CONST char *str, int *intPtr)
}
declare 38 generic {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
declare 40 generic {
- Tcl_ObjType * Tcl_GetObjType(char *typeName)
+ Tcl_ObjType * Tcl_GetObjType(CONST char *typeName)
}
declare 41 generic {
char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr)
void Tcl_InvalidateStringRep(Tcl_Obj *objPtr)
}
declare 43 generic {
- int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr, \
+ int Tcl_ListObjAppendList(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *elemListPtr)
}
declare 44 generic {
- int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, \
+ int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *objPtr)
}
declare 45 generic {
- int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, \
+ int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *objcPtr, Tcl_Obj ***objvPtr)
}
declare 46 generic {
- int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, \
+ int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index,
Tcl_Obj **objPtrPtr)
}
declare 47 generic {
- int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *intPtr)
+ int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ int *lengthPtr)
}
declare 48 generic {
- int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, \
+ int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
int count, int objc, Tcl_Obj *CONST objv[])
}
declare 49 generic {
- Tcl_Obj * Tcl_NewBooleanObj(int boolValue)
+ Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
}
declare 50 generic {
- Tcl_Obj * Tcl_NewByteArrayObj(unsigned char *bytes, int length)
+ Tcl_Obj *Tcl_NewByteArrayObj(CONST unsigned char* bytes, int length)
}
declare 51 generic {
Tcl_Obj * Tcl_NewDoubleObj(double doubleValue)
unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length)
}
declare 59 generic {
- void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, unsigned char *bytes, int length)
+ void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, CONST unsigned char *bytes,
+ int length)
}
declare 60 generic {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
void Tcl_SetObjLength(Tcl_Obj *objPtr, int length)
}
declare 65 generic {
- void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length)
+ void Tcl_SetStringObj(Tcl_Obj* objPtr, CONST char* bytes, int length)
}
declare 66 generic {
void Tcl_AddErrorInfo(Tcl_Interp *interp, CONST char *message)
}
declare 67 generic {
- void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, \
+ void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message,
int length)
}
declare 68 generic {
void Tcl_AppendResult(Tcl_Interp *interp, ...)
}
declare 71 generic {
- Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc, \
+ Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
ClientData clientData)
}
declare 72 generic {
char Tcl_Backslash(CONST char *src, int *readPtr)
}
declare 78 generic {
- int Tcl_BadChannelOption(Tcl_Interp *interp, char *optionName, \
- char *optionList)
+ int Tcl_BadChannelOption(Tcl_Interp *interp, CONST char *optionName,
+ CONST char *optionList)
}
declare 79 generic {
- void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, \
+ void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
ClientData clientData)
}
declare 80 generic {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 generic {
- int Tcl_CommandComplete(char *cmd)
+ int Tcl_CommandComplete(CONST char *cmd)
}
declare 83 generic {
- char * Tcl_Concat(int argc, char **argv)
+ char * Tcl_Concat(int argc, CONST84 char * CONST *argv)
}
declare 84 generic {
int Tcl_ConvertElement(CONST char *src, char *dst, int flags)
}
declare 85 generic {
- int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst, \
+ int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst,
int flags)
}
declare 86 generic {
- int Tcl_CreateAlias(Tcl_Interp *slave, char *slaveCmd, \
- Tcl_Interp *target, char *targetCmd, int argc, char **argv)
+ int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd,
+ Tcl_Interp *target, CONST char *targetCmd, int argc,
+ CONST84 char * CONST *argv)
}
declare 87 generic {
- int Tcl_CreateAliasObj(Tcl_Interp *slave, char *slaveCmd, \
- Tcl_Interp *target, char *targetCmd, int objc, \
+ int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd,
+ Tcl_Interp *target, CONST char *targetCmd, int objc,
Tcl_Obj *CONST objv[])
}
declare 88 generic {
- Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr, char *chanName, \
- ClientData instanceData, int mask)
+ Tcl_Channel Tcl_CreateChannel(Tcl_ChannelType *typePtr,
+ CONST char *chanName, ClientData instanceData, int mask)
}
declare 89 generic {
- void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask, \
+ void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData)
}
declare 90 generic {
- void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, \
+ void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
declare 91 generic {
- Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, char *cmdName, \
- Tcl_CmdProc *proc, ClientData clientData, \
+ Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, CONST char *cmdName,
+ Tcl_CmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 92 generic {
- void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc, \
+ void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
declare 93 generic {
Tcl_Interp * Tcl_CreateInterp(void)
}
declare 95 generic {
- void Tcl_CreateMathFunc(Tcl_Interp *interp, char *name, int numArgs, \
- Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData)
+ void Tcl_CreateMathFunc(Tcl_Interp *interp, CONST char *name,
+ int numArgs, Tcl_ValueType *argTypes,
+ Tcl_MathProc *proc, ClientData clientData)
}
declare 96 generic {
- Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, char *cmdName, \
- Tcl_ObjCmdProc *proc, ClientData clientData, \
+ Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp,
+ CONST char *cmdName,
+ Tcl_ObjCmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 97 generic {
- Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, char *slaveName, \
+ Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, CONST char *slaveName,
int isSafe)
}
declare 98 generic {
- Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, \
+ Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, ClientData clientData)
}
declare 99 generic {
- Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, \
+ Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
Tcl_CmdTraceProc *proc, ClientData clientData)
}
declare 100 generic {
- void Tcl_DeleteAssocData(Tcl_Interp *interp, char *name)
+ void Tcl_DeleteAssocData(Tcl_Interp *interp, CONST char *name)
}
declare 101 generic {
- void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc, \
+ void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc,
ClientData clientData)
}
declare 102 generic {
- void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc, \
+ void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
declare 103 generic {
- int Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName)
+ int Tcl_DeleteCommand(Tcl_Interp *interp, CONST char *cmdName)
}
declare 104 generic {
int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command)
void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData)
}
declare 106 generic {
- void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc, \
+ void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
declare 107 generic {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
declare 114 generic {
- void Tcl_DontCallWhenDeleted(Tcl_Interp *interp, \
+ void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
declare 115 generic {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 generic {
- char * Tcl_ErrnoId(void)
+ CONST84_RETURN char * Tcl_ErrnoId(void)
}
declare 128 generic {
- char * Tcl_ErrnoMsg(int err)
+ CONST84_RETURN char * Tcl_ErrnoMsg(int err)
}
declare 129 generic {
- int Tcl_Eval(Tcl_Interp *interp, char *string)
+ int Tcl_Eval(Tcl_Interp *interp, CONST char *string)
}
+# This is obsolete, use Tcl_FSEvalFile
declare 130 generic {
- int Tcl_EvalFile(Tcl_Interp *interp, char *fileName)
+ int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName)
}
declare 131 generic {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
void Tcl_Exit(int status)
}
declare 134 generic {
- int Tcl_ExposeCommand(Tcl_Interp *interp, char *hiddenCmdToken, \
- char *cmdName)
+ int Tcl_ExposeCommand(Tcl_Interp *interp, CONST char *hiddenCmdToken,
+ CONST char *cmdName)
}
declare 135 generic {
- int Tcl_ExprBoolean(Tcl_Interp *interp, char *str, int *ptr)
+ int Tcl_ExprBoolean(Tcl_Interp *interp, CONST char *str, int *ptr)
}
declare 136 generic {
int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)
}
declare 137 generic {
- int Tcl_ExprDouble(Tcl_Interp *interp, char *str, double *ptr)
+ int Tcl_ExprDouble(Tcl_Interp *interp, CONST char *str, double *ptr)
}
declare 138 generic {
int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)
}
declare 139 generic {
- int Tcl_ExprLong(Tcl_Interp *interp, char *str, long *ptr)
+ int Tcl_ExprLong(Tcl_Interp *interp, CONST char *str, long *ptr)
}
declare 140 generic {
int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)
}
declare 141 generic {
- int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Obj **resultPtrPtr)
}
declare 142 generic {
- int Tcl_ExprString(Tcl_Interp *interp, char *string)
+ int Tcl_ExprString(Tcl_Interp *interp, CONST char *string)
}
declare 143 generic {
void Tcl_Finalize(void)
void Tcl_FindExecutable(CONST char *argv0)
}
declare 145 generic {
- Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, \
+ Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
declare 146 generic {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 generic {
- int Tcl_GetAlias(Tcl_Interp *interp, char *slaveCmd, \
- Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, \
- char ***argvPtr)
+ int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd,
+ Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
+ int *argcPtr, CONST84 char ***argvPtr)
}
declare 149 generic {
- int Tcl_GetAliasObj(Tcl_Interp *interp, char *slaveCmd, \
- Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, \
- Tcl_Obj ***objv)
+ int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd,
+ Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
+ int *objcPtr, Tcl_Obj ***objv)
}
declare 150 generic {
- ClientData Tcl_GetAssocData(Tcl_Interp *interp, char *name, \
+ ClientData Tcl_GetAssocData(Tcl_Interp *interp, CONST char *name,
Tcl_InterpDeleteProc **procPtr)
}
declare 151 generic {
- Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, char *chanName, \
+ Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, CONST char *chanName,
int *modePtr)
}
declare 152 generic {
int Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
declare 153 generic {
- int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, \
+ int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
ClientData *handlePtr)
}
declare 154 generic {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 generic {
- char * Tcl_GetChannelName(Tcl_Channel chan)
+ CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 generic {
- int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, \
- char *optionName, Tcl_DString *dsPtr)
+ int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
+ CONST char *optionName, Tcl_DString *dsPtr)
}
declare 158 generic {
Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan)
}
declare 159 generic {
- int Tcl_GetCommandInfo(Tcl_Interp *interp, char *cmdName, \
+ int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName,
Tcl_CmdInfo *infoPtr)
}
declare 160 generic {
- char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command)
+ CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
+ Tcl_Command command)
}
declare 161 generic {
int Tcl_GetErrno(void)
}
declare 162 generic {
- char * Tcl_GetHostName(void)
+ CONST84_RETURN char * Tcl_GetHostName(void)
}
declare 163 generic {
int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
# generic interface, so we inlcude it here for compatibility reasons.
declare 167 unix {
- int Tcl_GetOpenFile(Tcl_Interp *interp, char *str, int forWriting, \
+ int Tcl_GetOpenFile(Tcl_Interp *interp, CONST char *str, int forWriting,
int checkUsage, ClientData *filePtr)
}
-
+# Obsolete. Should now use Tcl_FSGetPathType which is objectified
+# and therefore usually faster.
declare 168 generic {
- Tcl_PathType Tcl_GetPathType(char *path)
+ Tcl_PathType Tcl_GetPathType(CONST char *path)
}
declare 169 generic {
int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
int Tcl_GetServiceMode(void)
}
declare 172 generic {
- Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, char *slaveName)
+ Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, CONST char *slaveName)
}
declare 173 generic {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 generic {
- char * Tcl_GetStringResult(Tcl_Interp *interp)
+ CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 generic {
- char * Tcl_GetVar(Tcl_Interp *interp, char *varName, int flags)
+ CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, CONST char *varName,
+ int flags)
}
declare 176 generic {
- char * Tcl_GetVar2(Tcl_Interp *interp, char *part1, char *part2, int flags)
+ CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, CONST char *part1,
+ CONST char *part2, int flags)
}
declare 177 generic {
- int Tcl_GlobalEval(Tcl_Interp *interp, char *command)
+ int Tcl_GlobalEval(Tcl_Interp *interp, CONST char *command)
}
declare 178 generic {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 generic {
- int Tcl_HideCommand(Tcl_Interp *interp, char *cmdName, \
- char *hiddenCmdToken)
+ int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName,
+ CONST char *hiddenCmdToken)
}
declare 180 generic {
int Tcl_Init(Tcl_Interp *interp)
declare 185 generic {
int Tcl_IsSafe(Tcl_Interp *interp)
}
+# Obsolete, use Tcl_FSJoinPath
declare 186 generic {
- char * Tcl_JoinPath(int argc, char **argv, Tcl_DString *resultPtr)
+ char * Tcl_JoinPath(int argc, CONST84 char * CONST *argv,
+ Tcl_DString *resultPtr)
}
declare 187 generic {
- int Tcl_LinkVar(Tcl_Interp *interp, char *varName, char *addr, int type)
+ int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName, char *addr,
+ int type)
}
# This slot is reserved for use by the plus patch:
Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
}
declare 192 generic {
- char * Tcl_Merge(int argc, char **argv)
+ char * Tcl_Merge(int argc, CONST84 char * CONST *argv)
}
declare 193 generic {
Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
void Tcl_NotifyChannel(Tcl_Channel channel, int mask)
}
declare 195 generic {
- Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \
+ Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags)
}
declare 196 generic {
- Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \
+ Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags)
}
declare 197 {unix win} {
- Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, \
- char **argv, int flags)
+ Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
+ CONST84 char **argv, int flags)
}
+# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 generic {
- Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, char *fileName, \
- char *modeString, int permissions)
+ Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, CONST char *fileName,
+ CONST char *modeString, int permissions)
}
declare 199 generic {
- Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, \
- char *address, char *myaddr, int myport, int async)
+ Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
+ CONST char *address, CONST char *myaddr, int myport, int async)
}
declare 200 generic {
- Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, char *host, \
- Tcl_TcpAcceptProc *acceptProc, ClientData callbackData)
+ Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
+ CONST char *host, Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData)
}
declare 201 generic {
void Tcl_Preserve(ClientData data)
int Tcl_PutEnv(CONST char *string)
}
declare 204 generic {
- char * Tcl_PosixError(Tcl_Interp *interp)
+ CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 generic {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
void Tcl_ReapDetachedProcs(void)
}
declare 208 generic {
- int Tcl_RecordAndEval(Tcl_Interp *interp, char *cmd, int flags)
+ int Tcl_RecordAndEval(Tcl_Interp *interp, CONST char *cmd, int flags)
}
declare 209 generic {
int Tcl_RecordAndEvalObj(Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags)
void Tcl_RegisterObjType(Tcl_ObjType *typePtr)
}
declare 212 generic {
- Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, char *string)
+ Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, CONST char *string)
}
declare 213 generic {
- int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, \
+ int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
CONST char *str, CONST char *start)
}
declare 214 generic {
- int Tcl_RegExpMatch(Tcl_Interp *interp, char *str, char *pattern)
+ int Tcl_RegExpMatch(Tcl_Interp *interp, CONST char *str,
+ CONST char *pattern)
}
declare 215 generic {
- void Tcl_RegExpRange(Tcl_RegExp regexp, int index, char **startPtr, \
- char **endPtr)
+ void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
+ CONST84 char **startPtr, CONST84 char **endPtr)
}
declare 216 generic {
void Tcl_Release(ClientData clientData)
declare 219 generic {
int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr)
}
+# Obsolete
declare 220 generic {
- int Tcl_Seek(Tcl_Channel chan, int offset, int mode)
+ int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 generic {
int Tcl_ServiceAll(void)
int Tcl_ServiceEvent(int flags)
}
declare 223 generic {
- void Tcl_SetAssocData(Tcl_Interp *interp, char *name, \
+ void Tcl_SetAssocData(Tcl_Interp *interp, CONST char *name,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
declare 224 generic {
void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz)
}
declare 225 generic {
- int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, \
- char *optionName, char *newValue)
+ int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
+ CONST char *optionName, CONST char *newValue)
}
declare 226 generic {
- int Tcl_SetCommandInfo(Tcl_Interp *interp, char *cmdName, \
- Tcl_CmdInfo *infoPtr)
+ int Tcl_SetCommandInfo(Tcl_Interp *interp, CONST char *cmdName,
+ CONST Tcl_CmdInfo *infoPtr)
}
declare 227 generic {
void Tcl_SetErrno(int err)
int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
}
declare 232 generic {
- void Tcl_SetResult(Tcl_Interp *interp, char *str, \
+ void Tcl_SetResult(Tcl_Interp *interp, char *str,
Tcl_FreeProc *freeProc)
}
declare 233 generic {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 generic {
- char * Tcl_SetVar(Tcl_Interp *interp, char *varName, char *newValue, \
- int flags)
+ CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, CONST char *varName,
+ CONST char *newValue, int flags)
}
declare 238 generic {
- char * Tcl_SetVar2(Tcl_Interp *interp, char *part1, char *part2, \
- char *newValue, int flags)
+ CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, CONST char *part1,
+ CONST char *part2, CONST char *newValue, int flags)
}
declare 239 generic {
- char * Tcl_SignalId(int sig)
+ CONST84_RETURN char * Tcl_SignalId(int sig)
}
declare 240 generic {
- char * Tcl_SignalMsg(int sig)
+ CONST84_RETURN char * Tcl_SignalMsg(int sig)
}
declare 241 generic {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 generic {
- int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, \
- char ***argvPtr)
+ int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr,
+ CONST84 char ***argvPtr)
}
+# Obsolete, use Tcl_FSSplitPath
declare 243 generic {
- void Tcl_SplitPath(CONST char *path, int *argcPtr, char ***argvPtr)
+ void Tcl_SplitPath(CONST char *path, int *argcPtr, CONST84 char ***argvPtr)
}
declare 244 generic {
- void Tcl_StaticPackage(Tcl_Interp *interp, char *pkgName, \
+ void Tcl_StaticPackage(Tcl_Interp *interp, CONST char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
declare 245 generic {
int Tcl_StringMatch(CONST char *str, CONST char *pattern)
}
+# Obsolete
declare 246 generic {
- int Tcl_Tell(Tcl_Channel chan)
+ int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 generic {
- int Tcl_TraceVar(Tcl_Interp *interp, char *varName, int flags, \
+ int Tcl_TraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 248 generic {
- int Tcl_TraceVar2(Tcl_Interp *interp, char *part1, char *part2, \
+ int Tcl_TraceVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
int flags, Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 249 generic {
- char * Tcl_TranslateFileName(Tcl_Interp *interp, char *name, \
+ char * Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name,
Tcl_DString *bufferPtr)
}
declare 250 generic {
- int Tcl_Ungets(Tcl_Channel chan, char *str, int len, int atHead)
+ int Tcl_Ungets(Tcl_Channel chan, CONST char *str, int len, int atHead)
}
declare 251 generic {
- void Tcl_UnlinkVar(Tcl_Interp *interp, char *varName)
+ void Tcl_UnlinkVar(Tcl_Interp *interp, CONST char *varName)
}
declare 252 generic {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 253 generic {
- int Tcl_UnsetVar(Tcl_Interp *interp, char *varName, int flags)
+ int Tcl_UnsetVar(Tcl_Interp *interp, CONST char *varName, int flags)
}
declare 254 generic {
- int Tcl_UnsetVar2(Tcl_Interp *interp, char *part1, char *part2, int flags)
+ int Tcl_UnsetVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
+ int flags)
}
declare 255 generic {
- void Tcl_UntraceVar(Tcl_Interp *interp, char *varName, int flags, \
+ void Tcl_UntraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 256 generic {
- void Tcl_UntraceVar2(Tcl_Interp *interp, char *part1, char *part2, \
- int flags, Tcl_VarTraceProc *proc, ClientData clientData)
+ void Tcl_UntraceVar2(Tcl_Interp *interp, CONST char *part1,
+ CONST char *part2, int flags, Tcl_VarTraceProc *proc,
+ ClientData clientData)
}
declare 257 generic {
- void Tcl_UpdateLinkedVar(Tcl_Interp *interp, char *varName)
+ void Tcl_UpdateLinkedVar(Tcl_Interp *interp, CONST char *varName)
}
declare 258 generic {
- int Tcl_UpVar(Tcl_Interp *interp, char *frameName, char *varName, \
- char *localName, int flags)
+ int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName,
+ CONST char *varName, CONST char *localName, int flags)
}
declare 259 generic {
- int Tcl_UpVar2(Tcl_Interp *interp, char *frameName, char *part1, \
- char *part2, char *localName, int flags)
+ int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, CONST char *part1,
+ CONST char *part2, CONST char *localName, int flags)
}
declare 260 generic {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 261 generic {
- ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, char *varName, \
+ ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, CONST char *varName,
int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
declare 262 generic {
- ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, char *part1, \
- char *part2, int flags, Tcl_VarTraceProc *procPtr, \
+ ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, CONST char *part1,
+ CONST char *part2, int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData)
}
declare 263 generic {
- int Tcl_Write(Tcl_Channel chan, char *s, int slen)
+ int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen)
}
declare 264 generic {
- void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, \
- Tcl_Obj *CONST objv[], char *message)
+ void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[], CONST char *message)
}
declare 265 generic {
- int Tcl_DumpActiveMemory(char *fileName)
+ int Tcl_DumpActiveMemory(CONST char *fileName)
}
declare 266 generic {
- void Tcl_ValidateAllMemory(char *file, int line)
+ void Tcl_ValidateAllMemory(CONST char *file, int line)
}
+
declare 267 generic {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 generic {
- char * Tcl_HashStats(Tcl_HashTable *tablePtr)
+ CONST84_RETURN char * Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 generic {
- char * Tcl_ParseVar(Tcl_Interp *interp, char *str, char **termPtr)
+ CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *str,
+ CONST84 char **termPtr)
}
declare 271 generic {
- char * Tcl_PkgPresent(Tcl_Interp *interp, char *name, char *version, \
- int exact)
+ CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name,
+ CONST char *version, int exact)
}
declare 272 generic {
- char * Tcl_PkgPresentEx(Tcl_Interp *interp, char *name, char *version, \
- int exact, ClientData *clientDataPtr)
+ CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, CONST char *name,
+ CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 273 generic {
- int Tcl_PkgProvide(Tcl_Interp *interp, char *name, char *version)
+ int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name,
+ CONST char *version)
}
declare 274 generic {
- char * Tcl_PkgRequire(Tcl_Interp *interp, char *name, char *version, \
- int exact)
+ CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name,
+ CONST char *version, int exact)
}
declare 275 generic {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
declare 277 generic {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
-declare 278 {unix win} {
- void Tcl_PanicVA(char *format, va_list argList)
+declare 278 generic {
+ void Tcl_PanicVA(CONST char *format, va_list argList)
}
declare 279 generic {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
# version into the new one).
declare 281 generic {
- Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, \
- Tcl_ChannelType *typePtr, ClientData instanceData, \
- int mask, Tcl_Channel prevChan)
+ Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, Tcl_ChannelType *typePtr,
+ ClientData instanceData, int mask, Tcl_Channel prevChan)
}
declare 282 generic {
int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan)
declare 283 generic {
Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan)
}
+
+# 284 was reserved, but added in 8.4a2
+declare 284 generic {
+ void Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
+}
+
# Reserved for future use (8.0.x vs. 8.1)
-# declare 284 generic {
-# }
# declare 285 generic {
# }
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 generic {
- int Tcl_EvalEx(Tcl_Interp *interp, char *script, int numBytes, int flags)
+ int Tcl_EvalEx(Tcl_Interp *interp, CONST char *script, int numBytes,
+ int flags)
}
declare 292 generic {
- int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \
+ int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
int flags)
}
declare 293 generic {
void Tcl_ExitThread(int status)
}
declare 295 generic {
- int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, \
- CONST char *src, int srcLen, int flags, \
- Tcl_EncodingState *statePtr, char *dst, int dstLen, \
+ int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 296 generic {
- char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, CONST char *src, \
- int srcLen, Tcl_DString *dsPtr)
+ char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
+ CONST char *src, int srcLen, Tcl_DString *dsPtr)
}
declare 297 generic {
void Tcl_FinalizeThread(void)
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 302 generic {
- char * Tcl_GetEncodingName(Tcl_Encoding encoding)
+ CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 generic {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 generic {
- int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, \
- char **tablePtr, int offset, char *msg, int flags, int *indexPtr)
+ int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ CONST VOID *tablePtr, int offset, CONST char *msg, int flags,
+ int *indexPtr)
}
declare 305 generic {
VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
declare 306 generic {
- Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \
- int flags)
+ Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1,
+ CONST char *part2, int flags)
}
declare 307 generic {
ClientData Tcl_InitNotifier(void)
void Tcl_ConditionNotify(Tcl_Condition *condPtr)
}
declare 311 generic {
- void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, \
+ void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
Tcl_Time *timePtr)
}
declare 312 generic {
int Tcl_NumUtfChars(CONST char *src, int len)
}
declare 313 generic {
- int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, \
+ int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead,
int appendFlag)
}
declare 314 generic {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 317 generic {
- Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \
- Tcl_Obj *newValuePtr, int flags)
+ Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, CONST char *part1,
+ CONST char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 generic {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 generic {
- void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, \
+ void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr,
Tcl_QueuePosition position)
}
declare 320 generic {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 generic {
- char * Tcl_UtfAtIndex(CONST char *src, int index)
+ CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index)
}
declare 326 generic {
int Tcl_UtfCharComplete(CONST char *src, int len)
int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
}
declare 328 generic {
- char * Tcl_UtfFindFirst(CONST char *src, int ch)
+ CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch)
}
declare 329 generic {
- char * Tcl_UtfFindLast(CONST char *src, int ch)
+ CONST84_RETURN char * Tcl_UtfFindLast(CONST char *src, int ch)
}
declare 330 generic {
- char * Tcl_UtfNext(CONST char *src)
+ CONST84_RETURN char * Tcl_UtfNext(CONST char *src)
}
declare 331 generic {
- char * Tcl_UtfPrev(CONST char *src, CONST char *start)
+ CONST84_RETURN char * Tcl_UtfPrev(CONST char *src, CONST char *start)
}
declare 332 generic {
- int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, \
- CONST char *src, int srcLen, int flags, \
- Tcl_EncodingState *statePtr, char *dst, int dstLen, \
+ int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 333 generic {
- char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, CONST char *src, \
- int srcLen, Tcl_DString *dsPtr)
+ char * Tcl_UtfToExternalDString(Tcl_Encoding encoding,
+ CONST char *src, int srcLen, Tcl_DString *dsPtr)
}
declare 334 generic {
int Tcl_UtfToLower(char *src)
char * Tcl_GetString(Tcl_Obj *objPtr)
}
declare 341 generic {
- char * Tcl_GetDefaultEncodingDir(void)
+ CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void)
}
declare 342 generic {
- void Tcl_SetDefaultEncodingDir(char *path)
+ void Tcl_SetDefaultEncodingDir(CONST char *path)
}
declare 343 generic {
void Tcl_AlertNotifier(ClientData clientData)
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 generic {
- int Tcl_UniCharLen(Tcl_UniChar *str)
+ int Tcl_UniCharLen(CONST Tcl_UniChar *str)
}
declare 353 generic {
- int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,\
- unsigned long n)
+ int Tcl_UniCharNcmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,
+ unsigned long n)
}
declare 354 generic {
- char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, int numChars, \
- Tcl_DString *dsPtr)
+ char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string,
+ int numChars, Tcl_DString *dsPtr)
}
declare 355 generic {
- Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, int length, \
- Tcl_DString *dsPtr)
+ Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string,
+ int length, Tcl_DString *dsPtr)
}
declare 356 generic {
- Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags)
+ Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
+ int flags)
}
declare 357 generic {
- Tcl_Obj *Tcl_EvalTokens (Tcl_Interp *interp, Tcl_Token *tokenPtr, \
+ Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
declare 358 generic {
- void Tcl_FreeParse (Tcl_Parse *parsePtr)
+ void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 generic {
- void Tcl_LogCommandInfo (Tcl_Interp *interp, char *script, \
- char *command, int length)
+ void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script,
+ CONST char *command, int length)
}
declare 360 generic {
- int Tcl_ParseBraces (Tcl_Interp *interp, char *string, \
- int numBytes, Tcl_Parse *parsePtr,int append, char **termPtr)
+ int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *string, int numBytes,
+ Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
}
declare 361 generic {
- int Tcl_ParseCommand (Tcl_Interp *interp, char *string, int numBytes, \
+ int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *string, int numBytes,
int nested, Tcl_Parse *parsePtr)
}
declare 362 generic {
- int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes, \
+ int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *string, int numBytes,
Tcl_Parse *parsePtr)
}
declare 363 generic {
- int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes, \
- Tcl_Parse *parsePtr, int append, char **termPtr)
+ int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *string,
+ int numBytes, Tcl_Parse *parsePtr, int append,
+ CONST84 char **termPtr)
}
declare 364 generic {
- int Tcl_ParseVarName (Tcl_Interp *interp, char *string, \
- int numBytes, Tcl_Parse *parsePtr, int append)
+ int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *string, int numBytes,
+ Tcl_Parse *parsePtr, int append)
}
+# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
+# Tcl_FSAccess and Tcl_FSStat
declare 365 generic {
char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
int Tcl_UniCharIsPunct(int ch)
}
declare 376 generic {
- int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, \
+ int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
Tcl_Obj *objPtr, int offset, int nmatches, int flags)
}
declare 377 generic {
void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
declare 378 generic {
- Tcl_Obj * Tcl_NewUnicodeObj(Tcl_UniChar *unicode, int numChars)
+ Tcl_Obj * Tcl_NewUnicodeObj(CONST Tcl_UniChar *unicode, int numChars)
}
declare 379 generic {
- void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, Tcl_UniChar *unicode, \
+ void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
int numChars)
}
declare 380 generic {
- int Tcl_GetCharLength (Tcl_Obj *objPtr)
+ int Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 generic {
- Tcl_UniChar Tcl_GetUniChar (Tcl_Obj *objPtr, int index)
+ Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
declare 382 generic {
- Tcl_UniChar * Tcl_GetUnicode (Tcl_Obj *objPtr)
+ Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 generic {
- Tcl_Obj * Tcl_GetRange (Tcl_Obj *objPtr, int first, int last)
+ Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}
declare 384 generic {
- void Tcl_AppendUnicodeToObj (Tcl_Obj *objPtr, \
- Tcl_UniChar *unicode, int length)
+ void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
+ int length)
}
declare 385 generic {
- int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj, \
+ int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *stringObj,
Tcl_Obj *patternObj)
}
declare 386 generic {
int Tcl_GetChannelNames(Tcl_Interp *interp)
}
declare 389 generic {
- int Tcl_GetChannelNamesEx(Tcl_Interp *interp, char *pattern)
+ int Tcl_GetChannelNamesEx(Tcl_Interp *interp, CONST char *pattern)
}
declare 390 generic {
- int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp, \
+ int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
}
declare 391 generic {
- void Tcl_ConditionFinalize (Tcl_Condition *condPtr)
+ void Tcl_ConditionFinalize(Tcl_Condition *condPtr)
}
declare 392 generic {
- void Tcl_MutexFinalize (Tcl_Mutex *mutex)
+ void Tcl_MutexFinalize(Tcl_Mutex *mutex)
}
declare 393 generic {
- int Tcl_CreateThread (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, \
+ int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc,
ClientData clientData, int stackSize, int flags)
}
+# Introduced in 8.3.2
declare 394 generic {
- int Tcl_ReadRaw (Tcl_Channel chan, char *dst, int bytesToRead)
+ int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead)
}
declare 395 generic {
- int Tcl_WriteRaw (Tcl_Channel chan, char *src, int srcLen)
+ int Tcl_WriteRaw(Tcl_Channel chan, CONST char *src, int srcLen)
}
declare 396 generic {
- Tcl_Channel Tcl_GetTopChannel (Tcl_Channel chan)
+ Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 generic {
- int Tcl_ChannelBuffered (Tcl_Channel chan)
+ int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 generic {
- char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr)
+ CONST84_RETURN char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr)
}
declare 399 generic {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(Tcl_ChannelType *chanTypePtr)
}
declare 400 generic {
- Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType \
+ Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType
*chanTypePtr)
}
declare 401 generic {
Tcl_DriverSeekProc * Tcl_ChannelSeekProc(Tcl_ChannelType *chanTypePtr)
}
declare 406 generic {
- Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(Tcl_ChannelType \
+ Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(Tcl_ChannelType
*chanTypePtr)
}
declare 407 generic {
- Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(Tcl_ChannelType \
+ Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(Tcl_ChannelType
*chanTypePtr)
}
declare 408 generic {
Tcl_DriverWatchProc * Tcl_ChannelWatchProc(Tcl_ChannelType *chanTypePtr)
}
declare 409 generic {
- Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(Tcl_ChannelType \
+ Tcl_DriverGetHandleProc * Tcl_ChannelGetHandleProc(Tcl_ChannelType
*chanTypePtr)
}
declare 410 generic {
Tcl_DriverFlushProc * Tcl_ChannelFlushProc(Tcl_ChannelType *chanTypePtr)
}
declare 411 generic {
- Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType \
+ Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType
*chanTypePtr)
}
+# Introduced in 8.4a2
+declare 412 generic {
+ int Tcl_JoinThread(Tcl_ThreadId id, int* result)
+}
+declare 413 generic {
+ int Tcl_IsChannelShared(Tcl_Channel channel)
+}
+declare 414 generic {
+ int Tcl_IsChannelRegistered(Tcl_Interp* interp, Tcl_Channel channel)
+}
+declare 415 generic {
+ void Tcl_CutChannel(Tcl_Channel channel)
+}
+declare 416 generic {
+ void Tcl_SpliceChannel(Tcl_Channel channel)
+}
+declare 417 generic {
+ void Tcl_ClearChannelHandlers(Tcl_Channel channel)
+}
+declare 418 generic {
+ int Tcl_IsChannelExisting(CONST char* channelName)
+}
+
+declare 419 generic {
+ int Tcl_UniCharNcasecmp(CONST Tcl_UniChar *cs, CONST Tcl_UniChar *ct,
+ unsigned long n)
+}
+declare 420 generic {
+ int Tcl_UniCharCaseMatch(CONST Tcl_UniChar *ustr,
+ CONST Tcl_UniChar *pattern, int nocase)
+}
+
+declare 421 generic {
+ Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, CONST char *key)
+}
+
+declare 422 generic {
+ Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr,
+ CONST char *key, int *newPtr)
+}
+
+declare 423 generic {
+ void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
+ Tcl_HashKeyType *typePtr)
+}
+
+declare 424 generic {
+ void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
+}
+declare 425 generic {
+ ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, CONST char *varName,
+ int flags, Tcl_CommandTraceProc *procPtr,
+ ClientData prevClientData)
+}
+declare 426 generic {
+ int Tcl_TraceCommand(Tcl_Interp *interp, CONST char *varName, int flags,
+ Tcl_CommandTraceProc *proc, ClientData clientData)
+}
+declare 427 generic {
+ void Tcl_UntraceCommand(Tcl_Interp *interp, CONST char *varName,
+ int flags, Tcl_CommandTraceProc *proc, ClientData clientData)
+}
+declare 428 generic {
+ char * Tcl_AttemptAlloc(unsigned int size)
+}
+declare 429 generic {
+ char * Tcl_AttemptDbCkalloc(unsigned int size, CONST char *file, int line)
+}
+declare 430 generic {
+ char * Tcl_AttemptRealloc(char *ptr, unsigned int size)
+}
+declare 431 generic {
+ char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
+ CONST char *file, int line)
+}
+declare 432 generic {
+ int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length)
+}
+declare 433 generic {
+ Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
+}
+# introduced in 8.4a3
+declare 434 generic {
+ Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
+}
+declare 435 generic {
+ int Tcl_GetMathFuncInfo(Tcl_Interp *interp, CONST char *name,
+ int *numArgsPtr, Tcl_ValueType **argTypesPtr,
+ Tcl_MathProc **procPtr, ClientData *clientDataPtr)
+}
+declare 436 generic {
+ Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, CONST char *pattern)
+}
+declare 437 generic {
+ Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
+}
+declare 438 generic {
+ int Tcl_DetachChannel(Tcl_Interp* interp, Tcl_Channel channel)
+}
+declare 439 generic {
+ int Tcl_IsStandardChannel(Tcl_Channel channel)
+}
+# New functions due to TIP#17
+declare 440 generic {
+ int Tcl_FSCopyFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
+}
+declare 441 generic {
+ int Tcl_FSCopyDirectory(Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)
+}
+declare 442 generic {
+ int Tcl_FSCreateDirectory(Tcl_Obj *pathPtr)
+}
+declare 443 generic {
+ int Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
+}
+declare 444 generic {
+ int Tcl_FSLoadFile(Tcl_Interp * interp,
+ Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2,
+ Tcl_PackageInitProc ** proc1Ptr,
+ Tcl_PackageInitProc ** proc2Ptr,
+ Tcl_LoadHandle * handlePtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr)
+}
+declare 445 generic {
+ int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result,
+ Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)
+}
+declare 446 generic {
+ Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)
+}
+declare 447 generic {
+ int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
+ int recursive, Tcl_Obj **errorPtr)
+}
+declare 448 generic {
+ int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
+}
+declare 449 generic {
+ int Tcl_FSLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
+}
+declare 450 generic {
+ int Tcl_FSUtime(Tcl_Obj *pathPtr, struct utimbuf *tval)
+}
+declare 451 generic {
+ int Tcl_FSFileAttrsGet(Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)
+}
+declare 452 generic {
+ int Tcl_FSFileAttrsSet(Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)
+}
+declare 453 generic {
+ CONST char ** Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)
+}
+declare 454 generic {
+ int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
+}
+declare 455 generic {
+ int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode)
+}
+declare 456 generic {
+ Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ CONST char *modeString, int permissions)
+}
+declare 457 generic {
+ Tcl_Obj* Tcl_FSGetCwd(Tcl_Interp *interp)
+}
+declare 458 generic {
+ int Tcl_FSChdir(Tcl_Obj *pathPtr)
+}
+declare 459 generic {
+ int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr)
+}
+declare 460 generic {
+ Tcl_Obj* Tcl_FSJoinPath(Tcl_Obj *listObj, int elements)
+}
+declare 461 generic {
+ Tcl_Obj* Tcl_FSSplitPath(Tcl_Obj* pathPtr, int *lenPtr)
+}
+declare 462 generic {
+ int Tcl_FSEqualPaths(Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)
+}
+declare 463 generic {
+ Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr)
+}
+declare 464 generic {
+ Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc,
+ Tcl_Obj *CONST objv[])
+}
+declare 465 generic {
+ ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr,
+ Tcl_Filesystem *fsPtr)
+}
+declare 466 generic {
+ Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
+}
+declare 467 generic {
+ int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
+}
+declare 468 generic {
+ Tcl_Obj* Tcl_FSNewNativePath(Tcl_Filesystem* fromFilesystem,
+ ClientData clientData)
+}
+declare 469 generic {
+ CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr)
+}
+declare 470 generic {
+ Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr)
+}
+declare 471 generic {
+ Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr)
+}
+declare 472 generic {
+ Tcl_Obj* Tcl_FSListVolumes(void)
+}
+declare 473 generic {
+ int Tcl_FSRegister(ClientData clientData, Tcl_Filesystem *fsPtr)
+}
+declare 474 generic {
+ int Tcl_FSUnregister(Tcl_Filesystem *fsPtr)
+}
+declare 475 generic {
+ ClientData Tcl_FSData(Tcl_Filesystem *fsPtr)
+}
+declare 476 generic {
+ CONST char* Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
+ Tcl_Obj* pathPtr)
+}
+declare 477 generic {
+ Tcl_Filesystem* Tcl_FSGetFileSystemForPath(Tcl_Obj* pathObjPtr)
+}
+declare 478 generic {
+ Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathObjPtr)
+}
+# New function due to TIP#49
+declare 479 generic {
+ int Tcl_OutputBuffered(Tcl_Channel chan)
+}
+declare 480 generic {
+ void Tcl_FSMountsChanged(Tcl_Filesystem *fsPtr)
+}
+# New function due to TIP#56
+declare 481 generic {
+ int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
+ int count)
+}
+
+# New export due to TIP#73
+declare 482 generic {
+ void Tcl_GetTime(Tcl_Time* timeBuf)
+}
+
+# New exports due to TIP#32
+
+declare 483 generic {
+ Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp* interp, int level, int flags,
+ Tcl_CmdObjTraceProc* objProc, ClientData clientData,
+ Tcl_CmdObjTraceDeleteProc* delProc)
+}
+declare 484 generic {
+ int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo* infoPtr)
+}
+declare 485 generic {
+ int Tcl_SetCommandInfoFromToken(Tcl_Command token,
+ CONST Tcl_CmdInfo* infoPtr)
+}
+
+### New functions on 64-bit dev branch ###
+declare 486 generic {
+ Tcl_Obj * Tcl_DbNewWideIntObj(Tcl_WideInt wideValue,
+ CONST char *file, int line)
+}
+declare 487 generic {
+ int Tcl_GetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ Tcl_WideInt *widePtr)
+}
+declare 488 generic {
+ Tcl_Obj * Tcl_NewWideIntObj(Tcl_WideInt wideValue)
+}
+declare 489 generic {
+ void Tcl_SetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt wideValue)
+}
+declare 490 generic {
+ Tcl_StatBuf * Tcl_AllocStatBuf(void)
+}
+declare 491 generic {
+ Tcl_WideInt Tcl_Seek(Tcl_Channel chan, Tcl_WideInt offset, int mode)
+}
+declare 492 generic {
+ Tcl_WideInt Tcl_Tell(Tcl_Channel chan)
+}
+
+# New export due to TIP#91
+declare 493 generic {
+ Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc(
+ Tcl_ChannelType *chanTypePtr)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
char * Tcl_MacConvertTextResource(Handle resource)
}
declare 2 mac {
- int Tcl_MacEvalResource(Tcl_Interp *interp, char *resourceName, \
- int resourceNumber, char *fileName)
+ int Tcl_MacEvalResource(Tcl_Interp *interp, CONST char *resourceName,
+ int resourceNumber, CONST char *fileName)
}
declare 3 mac {
- Handle Tcl_MacFindResource(Tcl_Interp *interp, long resourceType, \
- char *resourceName, int resourceNumber, char *resFileRef, \
- int * releaseIt)
+ Handle Tcl_MacFindResource(Tcl_Interp *interp, long resourceType,
+ CONST char *resourceName, int resourceNumber,
+ CONST char *resFileRef, int * releaseIt)
}
# These routines support the new OSType object type (i.e. the packed 4
# character type and creator codes).
declare 4 mac {
- int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ int Tcl_GetOSTypeFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
OSType *osTypePtr)
}
declare 5 mac {
}
# These are not in MSL 2.1.2, so we need to export them from the
-# Tcl shared library. They are found in the compat directory
-# except the panic routine which is found in tclMacPanic.h.
+# Tcl shared library. They are found in the compat directory.
declare 7 mac {
int strncasecmp(CONST char *s1, CONST char *s2, size_t n)
int strcasecmp(CONST char *s1, CONST char *s2)
}
+##################
+# Mac OS X declarations
+#
+
+declare 0 macosx {
+ int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
+ CONST char *bundleName,
+ int hasResourceFile,
+ int maxPathLen,
+ char *libraryPath)
+}
* Copyright (c) 1993-1996 Lucent Technologies.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* win/configure.in (as above)
* win/tcl.m4 (not patchlevel)
* win/makefile.vc (not patchlevel) 2 LOC
- * win/pkgIndex.tcl (not patchlevel, for tclregNN.dll)
* README (sections 0 and 2)
* mac/README (2 LOC, not patchlevel)
+ * macosx/Tcl.pbproj/project.pbxproj
+ * (7 LOC total, 2 LOC patch)
* win/README.binary (sections 0-4)
* win/README (not patchlevel) (sections 0 and 2)
- * unix/README (not patchlevel) (part (h))
* unix/tcl.spec (2 LOC Major/Minor, 1 LOC patch)
- * tests/basic.test (not patchlevel) (version checks)
+ * tests/basic.test (1 LOC M/M, not patchlevel)
* tools/tcl.hpj.in (not patchlevel, for windows installer)
* tools/tcl.wse.in (for windows installer)
* tools/tclSplash.bmp (not patchlevel)
*/
-
#define TCL_MAJOR_VERSION 8
-#define TCL_MINOR_VERSION 3
+#define TCL_MINOR_VERSION 4
#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 2
+#define TCL_RELEASE_SERIAL 1
-#define TCL_VERSION "8.3"
-#define TCL_PATCH_LEVEL "8.3.2"
+#define TCL_VERSION "8.4"
+#define TCL_PATCH_LEVEL "8.4.1"
/*
* The following definitions set up the proper options for Windows
*/
#ifndef __WIN32__
-# if defined(_WIN32) || defined(WIN32)
+# if defined(_WIN32) || defined(WIN32) || defined(__MINGW32__) || defined(__BORLANDC__)
# define __WIN32__
+# ifndef WIN32
+# define WIN32
+# endif
# endif
#endif
+/*
+ * STRICT: See MSDN Article Q83456
+ */
#ifdef __WIN32__
# ifndef STRICT
# define STRICT
# endif
-# ifndef USE_PROTOTYPE
-# define USE_PROTOTYPE 1
-# endif
-# ifndef HAS_STDARG
-# define HAS_STDARG 1
-# endif
-# ifndef USE_PROTOTYPE
-# define USE_PROTOTYPE 1
-# endif
-
-/*
- * Under Windows we need to call Tcl_Alloc in all cases to avoid competing
- * C run-time library issues.
- */
-
-# if !defined(__CYGWIN__) || defined(__WIN32__)
-# ifndef USE_TCLALLOC
-# define USE_TCLALLOC 1
-# endif
-# endif /* __CYGWIN__ */
#endif /* __WIN32__ */
/*
*/
#ifdef MAC_TCL
-# ifndef HAS_STDARG
-# define HAS_STDARG 1
-# endif
+#include <ConditionalMacros.h>
# ifndef USE_TCLALLOC
# define USE_TCLALLOC 1
# endif
# define INLINE
#endif
+
/*
* Utility macros: STRINGIFY takes an argument and wraps it in "" (double
* quotation marks), JOIN joins two arguments.
*/
-
-#define VERBATIM(x) x
-#ifdef _MSC_VER
-# define STRINGIFY(x) STRINGIFY1(x)
-# define STRINGIFY1(x) #x
-# define JOIN(a,b) JOIN1(a,b)
-# define JOIN1(a,b) a##b
-#else
-# ifdef RESOURCE_INCLUDED
+#ifndef STRINGIFY
# define STRINGIFY(x) STRINGIFY1(x)
# define STRINGIFY1(x) #x
+#endif
+#ifndef JOIN
# define JOIN(a,b) JOIN1(a,b)
# define JOIN1(a,b) a##b
-# else
-# ifdef __STDC__
-# define STRINGIFY(x) #x
-# define JOIN(a,b) a##b
-# else
-# define STRINGIFY(x) "x"
-# define JOIN(a,b) VERBATIM(a)VERBATIM(b)
-# endif
-# endif
#endif
+/*
+ * A special definition used to allow this header file to be included
+ * from windows or mac resource files so that they can obtain version
+ * information. RC_INVOKED is defined by default by the windows RC tool
+ * and manually set for macintosh.
+ *
+ * Resource compilers don't like all the C stuff, like typedefs and
+ * procedure declarations, that occur below, so block them out.
+ */
+
+#ifndef RC_INVOKED
+
/*
* Special macro to define mutexes, that doesn't do anything
* if we are not using threads.
#define Tcl_ConditionFinalize(condPtr)
#endif /* TCL_THREADS */
-/*
- * A special definition used to allow this header file to be included
- * in resource files so that they can get obtain version information from
- * this file. Resource compilers don't like all the C stuff, like typedefs
- * and procedure declarations, that occur below.
- */
-
-#ifndef RESOURCE_INCLUDED
#ifndef BUFSIZ
-#include <stdio.h>
+# include <stdio.h>
#endif
+
/*
* Definitions that allow Tcl functions with variable numbers of
* arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS
* string for use in the function definition. TCL_VARARGS_START
* initializes the va_list data structure and returns the first argument.
*/
-
-#if defined(__STDC__) || defined(HAS_STDARG)
+#if !defined(NO_STDARG)
# include <stdarg.h>
-
# define TCL_VARARGS(type, name) (type name, ...)
# define TCL_VARARGS_DEF(type, name) (type name, ...)
# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
#else
# include <varargs.h>
-
-# ifdef __cplusplus
-# define TCL_VARARGS(type, name) (type name, ...)
-# define TCL_VARARGS_DEF(type, name) (type va_alist, ...)
-# else
-# define TCL_VARARGS(type, name) ()
-# define TCL_VARARGS_DEF(type, name) (va_alist)
-# endif
+# define TCL_VARARGS(type, name) ()
+# define TCL_VARARGS_DEF(type, name) (va_alist)
# define TCL_VARARGS_START(type, name, list) \
(va_start(list), va_arg(list, type))
#endif
*/
#ifdef STATIC_BUILD
-# define DLLIMPORT
-# define DLLEXPORT
+# define DLLIMPORT
+# define DLLEXPORT
#else
-# if defined(__WIN32__) && (defined(_MSC_VER) || ((defined(BUILD_tcl) || defined(BUILD_tk) || defined(USE_TCL_STUBS)) && defined(__declspec)))
-# define DLLIMPORT __declspec(dllimport)
-# define DLLEXPORT __declspec(dllexport)
-# else
-# define DLLIMPORT
-# define DLLEXPORT
-# endif
+# if (defined(__WIN32__) && (defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || (defined(__GNUC__) && defined(__declspec)))) || (defined(MAC_TCL) && FUNCTION_DECLSPEC)
+# define DLLIMPORT __declspec(dllimport)
+# define DLLEXPORT __declspec(dllexport)
+# else
+# define DLLIMPORT
+# define DLLEXPORT
+# endif
#endif
/*
* name of a library we are building, is set on the compile line for sources
* that are to be placed in the library. When this macro is set, the
* storage class will be set to DLLEXPORT. At the end of the header file, the
- * storage class will be reset to DLLIMPORt.
+ * storage class will be reset to DLLIMPORT.
*/
-
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
-# define TCL_STORAGE_CLASS DLLEXPORT
+# define TCL_STORAGE_CLASS DLLEXPORT
#else
-# ifdef USE_TCL_STUBS
-# define TCL_STORAGE_CLASS
-# else
-# define TCL_STORAGE_CLASS DLLIMPORT
-# endif
+# ifdef USE_TCL_STUBS
+# define TCL_STORAGE_CLASS
+# else
+# define TCL_STORAGE_CLASS DLLIMPORT
+# endif
#endif
+
/*
* Definitions that allow this header file to be used either with or
* without ANSI C features like function prototypes.
*/
-
#undef _ANSI_ARGS_
#undef CONST
#ifndef INLINE
# define INLINE
#endif
-#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE)
-# define _USING_PROTOTYPES_ 1
-# define _ANSI_ARGS_(x) x
+#ifndef NO_CONST
# define CONST const
#else
-# define _ANSI_ARGS_(x) ()
# define CONST
#endif
+#ifndef NO_PROTOTYPES
+# define _ANSI_ARGS_(x) x
+#else
+# define _ANSI_ARGS_(x) ()
+#endif
+
+#ifdef USE_NON_CONST
+# ifdef USE_COMPAT_CONST
+# error define at most one of USE_NON_CONST and USE_COMPAT_CONST
+# endif
+# define CONST84
+# define CONST84_RETURN
+#else
+# ifdef USE_COMPAT_CONST
+# define CONST84
+# define CONST84_RETURN CONST
+# else
+# define CONST84 CONST
+# define CONST84_RETURN CONST
+# endif
+#endif
+
+
/*
* Make sure EXTERN isn't defined elsewhere
*/
#ifdef EXTERN
-#undef EXTERN
+# undef EXTERN
#endif /* EXTERN */
#ifdef __cplusplus
# define EXTERN extern TCL_STORAGE_CLASS
#endif
+
/*
- * Macro to use instead of "void" for arguments that must have
- * type "void *" in ANSI C; maps them to type "char *" in
- * non-ANSI systems.
- */
-#ifndef __WIN32__
-#ifndef VOID
-# ifdef __STDC__
-# define VOID void
-# else
-# define VOID char
-# endif
-#endif
-#else /* __WIN32__ */
-/*
- * The following code is copied from winnt.h
+ * The following code is copied from winnt.h.
+ * If we don't replicate it here, then <windows.h> can't be included
+ * after tcl.h, since tcl.h also defines VOID.
*/
+#ifdef __WIN32__
#ifndef VOID
#define VOID void
typedef char CHAR;
#endif /* __WIN32__ */
/*
- * Miscellaneous declarations.
+ * Macro to use instead of "void" for arguments that must have
+ * type "void *" in ANSI C; maps them to type "char *" in
+ * non-ANSI systems.
*/
+#ifndef NO_VOID
+# define VOID void
+#else
+# define VOID char
+#endif
+
+/*
+ * Miscellaneous declarations.
+ */
#ifndef NULL
-#define NULL 0
+# define NULL 0
#endif
#ifndef _CLIENTDATA
-# if defined(__STDC__) || defined(__cplusplus)
- typedef void *ClientData;
+# ifndef NO_VOID
+ typedef void *ClientData;
# else
- typedef int *ClientData;
-# endif /* __STDC__ */
-#define _CLIENTDATA
+ typedef int *ClientData;
+# endif
+# define _CLIENTDATA
#endif
/*
+ * Define Tcl_WideInt to be a type that is (at least) 64-bits wide,
+ * and define Tcl_WideUInt to be the unsigned variant of that type
+ * (assuming that where we have one, we can have the other.)
+ *
+ * Also defines the following macros:
+ * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on
+ * a real 64-bit system.)
+ * Tcl_WideAsLong - forgetful converter from wideInt to long.
+ * Tcl_LongAsWide - sign-extending converter from long to wideInt.
+ * Tcl_WideAsDouble - converter from wideInt to double.
+ * Tcl_DoubleAsWide - converter from double to wideInt.
+ *
+ * The following invariant should hold for any long value 'longVal':
+ * longVal == Tcl_WideAsLong(Tcl_LongAsWide(longVal))
+ *
+ * Note on converting between Tcl_WideInt and strings. This
+ * implementation (in tclObj.c) depends on the functions strtoull()
+ * and sprintf(...,"%" TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE
+ * is the length of the modifier string, which is "ll" on most 32-bit
+ * Unix systems. It has to be split up like this to allow for the more
+ * complex formats sometimes needed (e.g. in the format(n) command.)
+ */
+
+#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
+# ifdef __CYGWIN__
+# define TCL_WIDE_INT_TYPE long long
+# define TCL_LL_MODIFIER "L"
+typedef struct stat Tcl_StatBuf;
+# define TCL_LL_MODIFIER_SIZE 1
+# elif defined(__WIN32__)
+# define TCL_WIDE_INT_TYPE __int64
+# ifdef __BORLANDC__
+typedef struct stati64 Tcl_StatBuf;
+# define TCL_LL_MODIFIER "L"
+# define TCL_LL_MODIFIER_SIZE 1
+# else /* __BORLANDC__ */
+typedef struct _stati64 Tcl_StatBuf;
+# define TCL_LL_MODIFIER "I64"
+# define TCL_LL_MODIFIER_SIZE 3
+# endif /* __BORLANDC__ */
+# else /* __WIN32__ */
+/*
+ * Don't know what platform it is and configure hasn't discovered what
+ * is going on for us. Try to guess...
+ */
+# ifdef NO_LIMITS_H
+# error please define either TCL_WIDE_INT_TYPE or TCL_WIDE_INT_IS_LONG
+# else /* !NO_LIMITS_H */
+# include <limits.h>
+# if (INT_MAX < LONG_MAX)
+# define TCL_WIDE_INT_IS_LONG 1
+# else
+# define TCL_WIDE_INT_TYPE long long
+# endif
+# endif /* NO_LIMITS_H */
+# endif /* __WIN32__ */
+#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
+#ifdef TCL_WIDE_INT_IS_LONG
+# undef TCL_WIDE_INT_TYPE
+# define TCL_WIDE_INT_TYPE long
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
+typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
+
+#ifdef TCL_WIDE_INT_IS_LONG
+typedef struct stat Tcl_StatBuf;
+# define Tcl_WideAsLong(val) ((long)(val))
+# define Tcl_LongAsWide(val) ((long)(val))
+# define Tcl_WideAsDouble(val) ((double)((long)(val)))
+# define Tcl_DoubleAsWide(val) ((long)((double)(val)))
+# ifndef TCL_LL_MODIFIER
+# define TCL_LL_MODIFIER "l"
+# define TCL_LL_MODIFIER_SIZE 1
+# endif /* !TCL_LL_MODIFIER */
+#else /* TCL_WIDE_INT_IS_LONG */
+/*
+ * The next short section of defines are only done when not running on
+ * Windows or some other strange platform.
+ */
+# ifndef TCL_LL_MODIFIER
+# ifdef HAVE_STRUCT_STAT64
+typedef struct stat64 Tcl_StatBuf;
+# else
+typedef struct stat Tcl_StatBuf;
+# endif /* HAVE_STRUCT_STAT64 */
+# define TCL_LL_MODIFIER "ll"
+# define TCL_LL_MODIFIER_SIZE 2
+# endif /* !TCL_LL_MODIFIER */
+# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
+# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
+# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
+# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+
+/*
+ * This flag controls whether binary compatability is maintained with
+ * extensions built against a previous version of Tcl. This is true
+ * by default.
+ */
+#ifndef TCL_PRESERVE_BINARY_COMPATABILITY
+# define TCL_PRESERVE_BINARY_COMPATABILITY 1
+#endif
+
+
+/*
* Data structures defined opaquely in this module. The definitions below
* just provide dummy types. A few fields are made visible in Tcl_Interp
* structures, namely those used for returning a string result from
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
+typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle;
/*
* Definition of the interface to procedures implementing threads.
* 'Tcl_CreateThread' and will be called as the main fuction of
* the new thread created by that call.
*/
-
#ifdef MAC_TCL
typedef pascal void *(Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
#elif defined __WIN32__
#endif
-
/*
* Definition of values for default stacksize and the possible flags to be
* given to Tcl_CreateThread.
*/
-
#define TCL_THREAD_STACK_DEFAULT (0) /* Use default size for stack */
#define TCL_THREAD_NOFLAGS (0000) /* Standard flags, default behaviour */
#define TCL_THREAD_JOINABLE (0001) /* Mark the thread as joinable */
/*
* Flag values passed to Tcl_GetRegExpFromObj.
*/
-
#define TCL_REG_BASIC 000000 /* BREs (convenience) */
#define TCL_REG_EXTENDED 000001 /* EREs */
#define TCL_REG_ADVF 000002 /* advanced features in EREs */
* The following flag is experimental and only intended for use by Expect. It
* will probably go away in a later release.
*/
-
#define TCL_REG_BOSONLY 002000 /* prepend \A to pattern so it only
* matches at the beginning of the
* string. */
/*
* Flags values passed to Tcl_RegExpExecObj.
*/
-
#define TCL_REG_NOTBOL 0001 /* Beginning of string does not match ^. */
#define TCL_REG_NOTEOL 0002 /* End of string does not match $. */
* relative to the start of the match string, not the beginning of the
* entire string.
*/
-
typedef struct Tcl_RegExpIndices {
long start; /* character offset of first character in match */
long end; /* character offset of first character after the
* Picky compilers complain if this typdef doesn't appear before the
* struct's reference in tclDecls.h.
*/
-
-typedef struct stat *Tcl_Stat_;
+typedef Tcl_StatBuf *Tcl_Stat_;
+typedef struct stat *Tcl_OldStat_;
/*
* When a TCL command returns, the interpreter contains a result from the
* TCL_CONTINUE Go on to the next iteration of the current loop;
* the interpreter's result is meaningless.
*/
-
#define TCL_OK 0
#define TCL_ERROR 1
#define TCL_RETURN 2
#define TCL_RESULT_SIZE 200
/*
- * Argument descriptors for math function callbacks in expressions:
+ * Flags to control what substitutions are performed by Tcl_SubstObj():
*/
+#define TCL_SUBST_COMMANDS 001
+#define TCL_SUBST_VARIABLES 002
+#define TCL_SUBST_BACKSLASHES 004
+#define TCL_SUBST_ALL 007
+
-typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} Tcl_ValueType;
+/*
+ * Argument descriptors for math function callbacks in expressions:
+ */
+typedef enum {
+ TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
+#ifdef TCL_WIDE_INT_IS_LONG
+ = TCL_INT
+#endif
+} Tcl_ValueType;
typedef struct Tcl_Value {
Tcl_ValueType type; /* Indicates intValue or doubleValue is
* valid, or both. */
long intValue; /* Integer value. */
double doubleValue; /* Double-precision floating value. */
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
+#endif
} Tcl_Value;
/*
* reference to Tcl_Obj is encountered in the procedure types declared
* below.
*/
-
struct Tcl_Obj;
+
/*
* Procedure types defined by Tcl:
*/
typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char *argv[]));
+ Tcl_Interp *interp, int argc, CONST84 char *argv[]));
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
- ClientData cmdClientData, int argc, char *argv[]));
+ ClientData cmdClientData, int argc, CONST84 char *argv[]));
+typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int level, CONST char *command,
+ Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv));
+typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr));
typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, struct Tcl_Obj *CONST objv[]));
+ Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
-typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(char *, format));
+typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, char *part1, char *part2, int flags));
+ Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, int flags));
+typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
+ int flags));
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
+typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
+typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
+typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));
+
/*
* The following structure represents a type of object, which is a
* failure. */
} Tcl_ObjType;
+
/*
* One of the following structures exists for each object in the Tcl
* system. An object stores a value as either a string, some internal
long longValue; /* - an long integer value */
double doubleValue; /* - a double-precision floating value */
VOID *otherValuePtr; /* - another, type-specific value */
+ Tcl_WideInt wideValue; /* - a long long value */
struct { /* - internal rep as two pointers */
VOID *ptr1;
VOID *ptr2;
} internalRep;
} Tcl_Obj;
+
/*
* Macros to increment and decrement a Tcl_Obj's reference count, and to
* test whether an object is shared (i.e. has reference count > 1).
* "obj" twice. This means that you should avoid calling it with an
* expression that is expensive to compute or has side effects.
*/
-
void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
Tcl_DbNewObj(__FILE__, __LINE__)
# define Tcl_NewStringObj(bytes, len) \
Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__)
+# define Tcl_NewWideIntObj(val) \
+ Tcl_DbNewWideIntObj(val, __FILE__, __LINE__)
#endif /* TCL_MEM_DEBUG */
+
/*
* The following structure contains the state needed by
* Tcl_SaveResult. No-one outside of Tcl should access any of these
* fields. This structure is typically allocated on the stack.
*/
-
typedef struct Tcl_SavedResult {
char *result;
Tcl_FreeProc *freeProc;
* namespace. */
} Tcl_Namespace;
+
/*
* The following structure represents a call frame, or activation record.
* A call frame defines a naming context for a procedure call: its local
char* dummy10;
} Tcl_CallFrame;
+
/*
* Information about commands that is returned by Tcl_GetCommandInfo and
* passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based
* does string-to-object or object-to-string argument conversions then
* calls the other procedure.
*/
-
+
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 0 otherwise.
/*
* The structure defined below is used to hold dynamic strings. The only
- * field that clients should use is the string field, and they should
- * never modify it.
+ * field that clients should use is the string field, accessible via the
+ * macro Tcl_DStringValue.
*/
-
#define TCL_DSTRING_STATIC_SIZE 200
typedef struct Tcl_DString {
char *string; /* Points to beginning of string: either
* be specified in the "tcl_precision" variable, and the number of
* bytes of buffer space required by Tcl_PrintDouble.
*/
-
#define TCL_MAX_PREC 17
#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)
* string representation of an integer in base 10 (assuming the existence
* of 64-bit integers).
*/
-
#define TCL_INTEGER_SPACE 24
/*
* output braces (careful! if you change this flag be sure to change
* the definitions at the front of tclUtil.c).
*/
-
#define TCL_DONT_USE_BRACES 1
/*
* Flag that may be passed to Tcl_GetIndexFromObj to force it to disallow
* abbreviated strings.
*/
-
#define TCL_EXACT 1
/*
* WARNING: these bit choices must not conflict with the bit choices
* for evalFlag bits in tclInt.h!!
*/
-
#define TCL_NO_EVAL 0x10000
#define TCL_EVAL_GLOBAL 0x20000
#define TCL_EVAL_DIRECT 0x40000
+#define TCL_EVAL_INVOKE 0x80000
/*
* Special freeProc values that may be passed to Tcl_SetResult (see
* the man page for details):
*/
-
#define TCL_VOLATILE ((Tcl_FreeProc *) 1)
#define TCL_STATIC ((Tcl_FreeProc *) 0)
#define TCL_DYNAMIC ((Tcl_FreeProc *) 3)
/*
* Flag values passed to variable-related procedures.
*/
-
#define TCL_GLOBAL_ONLY 1
#define TCL_NAMESPACE_ONLY 2
#define TCL_APPEND_VALUE 4
#define TCL_INTERP_DESTROYED 0x100
#define TCL_LEAVE_ERR_MSG 0x200
#define TCL_TRACE_ARRAY 0x800
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+/* Required to support old variable/vdelete/vinfo traces */
+#define TCL_TRACE_OLD_STYLE 0x1000
+#endif
+/* Indicate the semantics of the result of a trace */
+#define TCL_TRACE_RESULT_DYNAMIC 0x8000
+#define TCL_TRACE_RESULT_OBJECT 0x10000
+
+/*
+ * Flag values passed to command-related procedures.
+ */
+
+#define TCL_TRACE_RENAME 0x2000
+#define TCL_TRACE_DELETE 0x4000
+
+#define TCL_ALLOW_INLINE_COMPILATION 0x20000
+
+/*
+ * Flag values passed to Tcl_CreateObjTrace, and used internally
+ * by command execution traces. Slots 4,8,16 and 32 are
+ * used internally by execution traces (see tclCmdMZ.c)
+ */
+#define TCL_TRACE_ENTER_EXEC 1
+#define TCL_TRACE_LEAVE_EXEC 2
/*
* The TCL_PARSE_PART1 flag is deprecated and has no effect.
* flag)
*/
#ifndef TCL_NO_DEPRECATED
-#define TCL_PARSE_PART1 0x400
+# define TCL_PARSE_PART1 0x400
#endif
/*
* Types for linked variables:
*/
-
#define TCL_LINK_INT 1
#define TCL_LINK_DOUBLE 2
#define TCL_LINK_BOOLEAN 3
#define TCL_LINK_STRING 4
+#define TCL_LINK_WIDE_INT 5
#define TCL_LINK_READ_ONLY 0x80
+
/*
- * Forward declaration of Tcl_HashTable. Needed by some C++ compilers
- * to prevent errors when the forward reference to Tcl_HashTable is
- * encountered in the Tcl_HashEntry structure.
+ * Forward declarations of Tcl_HashTable and related types.
*/
+typedef struct Tcl_HashKeyType Tcl_HashKeyType;
+typedef struct Tcl_HashTable Tcl_HashTable;
+typedef struct Tcl_HashEntry Tcl_HashEntry;
-#ifdef __cplusplus
-struct Tcl_HashTable;
+typedef unsigned int (Tcl_HashKeyProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+typedef int (Tcl_CompareHashKeysProc) _ANSI_ARGS_((VOID *keyPtr,
+ Tcl_HashEntry *hPtr));
+typedef Tcl_HashEntry *(Tcl_AllocHashEntryProc) _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr, VOID *keyPtr));
+typedef void (Tcl_FreeHashEntryProc) _ANSI_ARGS_((Tcl_HashEntry *hPtr));
+
+/*
+ * This flag controls whether the hash table stores the hash of a key, or
+ * recalculates it. There should be no reason for turning this flag off
+ * as it is completely binary and source compatible unless you directly
+ * access the bucketPtr member of the Tcl_HashTableEntry structure. This
+ * member has been removed and the space used to store the hash value.
+ */
+#ifndef TCL_HASH_KEY_STORE_HASH
+# define TCL_HASH_KEY_STORE_HASH 1
#endif
/*
* defined below.
*/
-typedef struct Tcl_HashEntry {
- struct Tcl_HashEntry *nextPtr; /* Pointer to next entry in this
+struct Tcl_HashEntry {
+ Tcl_HashEntry *nextPtr; /* Pointer to next entry in this
* hash bucket, or NULL for end of
* chain. */
- struct Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
- struct Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to
+ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
+#if TCL_HASH_KEY_STORE_HASH
+# if TCL_PRESERVE_BINARY_COMPATABILITY
+ VOID *hash; /* Hash value, stored as pointer to
+ * ensure that the offsets of the
+ * fields in this structure are not
+ * changed. */
+# else
+ unsigned int hash; /* Hash value. */
+# endif
+#else
+ Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to
* first entry in this entry's chain:
* used for deleting the entry. */
+#endif
ClientData clientData; /* Application stores something here
* with Tcl_SetHashValue. */
union { /* Key has one of these forms: */
char *oneWordValue; /* One-word value for key. */
+ Tcl_Obj *objPtr; /* Tcl_Obj * key value. */
int words[1]; /* Multiple integer words for key.
* The actual size will be as large
* as necessary for this table's
* will be as large as needed to hold
* the key. */
} key; /* MUST BE LAST FIELD IN RECORD!! */
-} Tcl_HashEntry;
+};
+
+/*
+ * Flags used in Tcl_HashKeyType.
+ *
+ * TCL_HASH_KEY_RANDOMIZE_HASH:
+ * There are some things, pointers for example
+ * which don't hash well because they do not use
+ * the lower bits. If this flag is set then the
+ * hash table will attempt to rectify this by
+ * randomising the bits and then using the upper
+ * N bits as the index into the table.
+ */
+#define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
+
+/*
+ * Structure definition for the methods associated with a hash table
+ * key type.
+ */
+#define TCL_HASH_KEY_TYPE_VERSION 1
+struct Tcl_HashKeyType {
+ int version; /* Version of the table. If this structure is
+ * extended in future then the version can be
+ * used to distinguish between different
+ * structures.
+ */
+
+ int flags; /* Flags, see above for details. */
+
+ /* Calculates a hash value for the key. If this is NULL then the pointer
+ * itself is used as a hash value.
+ */
+ Tcl_HashKeyProc *hashKeyProc;
+
+ /* Compares two keys and returns zero if they do not match, and non-zero
+ * if they do. If this is NULL then the pointers are compared.
+ */
+ Tcl_CompareHashKeysProc *compareKeysProc;
+
+ /* Called to allocate memory for a new entry, i.e. if the key is a
+ * string then this could allocate a single block which contains enough
+ * space for both the entry and the string. Only the key field of the
+ * allocated Tcl_HashEntry structure needs to be filled in. If something
+ * else needs to be done to the key, i.e. incrementing a reference count
+ * then that should be done by this function. If this is NULL then Tcl_Alloc
+ * is used to allocate enough space for a Tcl_HashEntry and the key pointer
+ * is assigned to key.oneWordValue.
+ */
+ Tcl_AllocHashEntryProc *allocEntryProc;
+
+ /* Called to free memory associated with an entry. If something else needs
+ * to be done to the key, i.e. decrementing a reference count then that
+ * should be done by this function. If this is NULL then Tcl_Free is used
+ * to free the Tcl_HashEntry.
+ */
+ Tcl_FreeHashEntryProc *freeEntryProc;
+};
/*
* Structure definition for a hash table. Must be in tcl.h so clients
*/
#define TCL_SMALL_HASH_TABLE 4
-typedef struct Tcl_HashTable {
+struct Tcl_HashTable {
Tcl_HashEntry **buckets; /* Pointer to bucket array. Each
* element points to first entry in
* bucket's hash chain, or NULL. */
int mask; /* Mask value used in hashing
* function. */
int keyType; /* Type of keys used in this table.
- * It's either TCL_STRING_KEYS,
- * TCL_ONE_WORD_KEYS, or an integer
- * giving the number of ints that
- * is the size of the key.
+ * It's either TCL_CUSTOM_KEYS,
+ * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
+ * or an integer giving the number of
+ * ints that is the size of the key.
*/
- Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr,
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ Tcl_HashEntry *(*findProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key));
- Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr,
+ Tcl_HashEntry *(*createProc) _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key, int *newPtr));
-} Tcl_HashTable;
+#endif
+ Tcl_HashKeyType *typePtr; /* Type of the keys used in the
+ * Tcl_HashTable. */
+};
/*
* Structure definition for information used to keep track of searches
/*
* Acceptable key types for hash tables:
+ *
+ * TCL_STRING_KEYS: The keys are strings, they are copied into
+ * the entry.
+ * TCL_ONE_WORD_KEYS: The keys are pointers, the pointer is stored
+ * in the entry.
+ * TCL_CUSTOM_TYPE_KEYS: The keys are arbitrary types which are copied
+ * into the entry.
+ * TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the
+ * pointer is stored in the entry.
+ *
+ * While maintaining binary compatability the above have to be distinct
+ * values as they are used to differentiate between old versions of the
+ * hash table which don't have a typePtr and new ones which do. Once binary
+ * compatability is discarded in favour of making more wide spread changes
+ * TCL_STRING_KEYS can be the same as TCL_CUSTOM_TYPE_KEYS, and
+ * TCL_ONE_WORD_KEYS can be the same as TCL_CUSTOM_PTR_KEYS because they
+ * simply determine how the key is accessed from the entry and not the
+ * behaviour.
*/
#define TCL_STRING_KEYS 0
#define TCL_ONE_WORD_KEYS 1
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# define TCL_CUSTOM_TYPE_KEYS -2
+# define TCL_CUSTOM_PTR_KEYS -1
+#else
+# define TCL_CUSTOM_TYPE_KEYS TCL_STRING_KEYS
+# define TCL_CUSTOM_PTR_KEYS TCL_ONE_WORD_KEYS
+#endif
+
/*
* Macros for clients to use to access fields of hash entries:
*/
#define Tcl_GetHashValue(h) ((h)->clientData)
#define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value))
-#define Tcl_GetHashKey(tablePtr, h) \
- ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \
- : (h)->key.string))
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# define Tcl_GetHashKey(tablePtr, h) \
+ ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \
+ (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \
+ ? (h)->key.oneWordValue \
+ : (h)->key.string))
+#else
+# define Tcl_GetHashKey(tablePtr, h) \
+ ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) \
+ ? (h)->key.oneWordValue \
+ : (h)->key.string))
+#endif
/*
* Macros to use for clients to use to invoke find and create procedures
* for hash tables:
*/
-#define Tcl_FindHashEntry(tablePtr, key) \
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# define Tcl_FindHashEntry(tablePtr, key) \
(*((tablePtr)->findProc))(tablePtr, key)
-#define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
+# define Tcl_CreateHashEntry(tablePtr, key, newPtr) \
(*((tablePtr)->createProc))(tablePtr, key, newPtr)
+#else /* !TCL_PRESERVE_BINARY_COMPATABILITY */
+/*
+ * Macro to use new extended version of Tcl_InitHashTable.
+ */
+# define Tcl_InitHashTable(tablePtr, keyType) \
+ Tcl_InitHashTableEx(tablePtr, keyType, NULL)
+#endif /* TCL_PRESERVE_BINARY_COMPATABILITY */
+
/*
* Flag values to pass to Tcl_DoOneEvent to disable searches
* for some kinds of events:
*/
-
#define TCL_DONT_WAIT (1<<1)
#define TCL_WINDOW_EVENTS (1<<2)
#define TCL_FILE_EVENTS (1<<3)
* a Tcl_Event header followed by additional information specific to that
* event.
*/
-
struct Tcl_Event {
Tcl_EventProc *proc; /* Procedure to call to service this event. */
struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */
/*
* Positions to pass to Tcl_QueueEvent:
*/
-
typedef enum {
TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
} Tcl_QueuePosition;
* Values to pass to Tcl_SetServiceMode to specify the behavior of notifier
* event routines.
*/
-
#define TCL_SERVICE_NONE 0
#define TCL_SERVICE_ALL 1
+
/*
* The following structure keeps is used to hold a time value, either as
* an absolute time (the number of seconds from the epoch) or as an
* elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
* On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT.
*/
-
typedef struct Tcl_Time {
long sec; /* Seconds. */
long usec; /* Microseconds. */
typedef void (Tcl_SetTimerProc) _ANSI_ARGS_((Tcl_Time *timePtr));
typedef int (Tcl_WaitForEventProc) _ANSI_ARGS_((Tcl_Time *timePtr));
+
/*
* Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler
* to indicate what sorts of events are of interest:
*/
-
#define TCL_READABLE (1<<1)
#define TCL_WRITABLE (1<<2)
#define TCL_EXCEPTION (1<<3)
* disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR,
* are also used in Tcl_GetStdChannel.
*/
-
#define TCL_STDIN (1<<1)
#define TCL_STDOUT (1<<2)
#define TCL_STDERR (1<<3)
* Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel
* should be closed.
*/
-
#define TCL_CLOSE_READ (1<<1)
-#define TCL_CLOSE_WRITE (1<<2)
+#define TCL_CLOSE_WRITE (1<<2)
/*
* Value to use as the closeProc for a channel that supports the
* close2Proc interface.
*/
-
#define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1)
/*
* Channel version tag. This was introduced in 8.3.2/8.4.
*/
-
#define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1)
#define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2)
+#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3)
/*
* Typedefs for the various operations in a channel type:
*/
-
typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((
ClientData instanceData, int mode));
typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCodePtr));
typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCodePtr));
+ CONST84 char *buf, int toWrite, int *errorCodePtr));
typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
long offset, int mode, int *errorCodePtr));
typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
- char *optionName, char *value));
+ CONST char *optionName, CONST char *value));
typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
- char *optionName, Tcl_DString *dsPtr));
+ CONST84 char *optionName, Tcl_DString *dsPtr));
typedef void (Tcl_DriverWatchProc) _ANSI_ARGS_((
ClientData instanceData, int mask));
typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_((
ClientData instanceData));
typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_((
ClientData instanceData, int interestMask));
+typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_((
+ ClientData instanceData, Tcl_WideInt offset,
+ int mode, int *errorCodePtr));
+
/*
* The following declarations either map ckalloc and ckfree to
* malloc and free, or they map them to procedures with all sorts
* of debugging hooks defined in tclCkalloc.c.
*/
-
#ifdef TCL_MEM_DEBUG
# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
-
+# define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__)
+# define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)
#else /* !TCL_MEM_DEBUG */
/*
* is using the same memory allocator both inside and outside of the
* Tcl library.
*/
-
# define ckalloc(x) Tcl_Alloc(x)
# define ckfree(x) Tcl_Free(x)
# define ckrealloc(x,y) Tcl_Realloc(x,y)
+# define attemptckalloc(x) Tcl_AttemptAlloc(x)
+# define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y)
# define Tcl_InitMemory(x)
# define Tcl_DumpActiveMemory(x)
# define Tcl_ValidateAllMemory(x,y)
#endif /* !TCL_MEM_DEBUG */
/*
- * Enum for different end of line translation and recognition modes.
- */
-
-typedef enum Tcl_EolTranslation {
- TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */
- TCL_TRANSLATE_CR, /* Eol == \r. */
- TCL_TRANSLATE_LF, /* Eol == \n. */
- TCL_TRANSLATE_CRLF /* Eol == \r\n. */
-} Tcl_EolTranslation;
-
-/*
* struct Tcl_ChannelType:
*
* One such structure exists for each type (kind) of channel.
* It is recommend that the Tcl_Channel* functions are used to access
* elements of this structure, instead of direct accessing.
*/
-
typedef struct Tcl_ChannelType {
char *typeName; /* The name of the channel type in Tcl
- * commands. This storage is owned by
- * channel type. */
+ * commands. This storage is owned by
+ * channel type. */
Tcl_ChannelTypeVersion version; /* Version of the channel type. */
Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the
* channel, or TCL_CLOSE2PROC if the
/* Set blocking mode for the
* raw channel. May be NULL. */
/*
- * Only valid in TCL_CHANNEL_VERSION_2 channels
+ * Only valid in TCL_CHANNEL_VERSION_2 channels or later
*/
Tcl_DriverFlushProc *flushProc; /* Procedure to call to flush a
* channel. May be NULL. */
Tcl_DriverHandlerProc *handlerProc; /* Procedure to call to handle a
* channel event. This will be passed
* up the stacked channel chain. */
+ /*
+ * Only valid in TCL_CHANNEL_VERSION_3 channels or later
+ */
+ Tcl_DriverWideSeekProc *wideSeekProc;
+ /* Procedure to call to seek
+ * on the channel which can
+ * handle 64-bit offsets. May be
+ * NULL, and must be NULL if
+ * seekProc is NULL. */
} Tcl_ChannelType;
/*
* set the channel into blocking or nonblocking mode. They are passed
* as arguments to the blockModeProc procedure in the above structure.
*/
-
-#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */
-#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking
+#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */
+#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking
* mode. */
/*
* Enum for different types of file paths.
*/
-
typedef enum Tcl_PathType {
TCL_PATH_ABSOLUTE,
TCL_PATH_RELATIVE,
TCL_PATH_VOLUME_RELATIVE
} Tcl_PathType;
+
+/*
+ * The following structure is used to pass glob type data amongst
+ * the various glob routines and Tcl_FSMatchInDirectory.
+ */
+typedef struct Tcl_GlobTypeData {
+ /* Corresponds to bcdpfls as in 'find -t' */
+ int type;
+ /* Corresponds to file permissions */
+ int perm;
+ /* Acceptable mac type */
+ Tcl_Obj* macType;
+ /* Acceptable mac creator */
+ Tcl_Obj* macCreator;
+} Tcl_GlobTypeData;
+
+/*
+ * type and permission definitions for glob command
+ */
+#define TCL_GLOB_TYPE_BLOCK (1<<0)
+#define TCL_GLOB_TYPE_CHAR (1<<1)
+#define TCL_GLOB_TYPE_DIR (1<<2)
+#define TCL_GLOB_TYPE_PIPE (1<<3)
+#define TCL_GLOB_TYPE_FILE (1<<4)
+#define TCL_GLOB_TYPE_LINK (1<<5)
+#define TCL_GLOB_TYPE_SOCK (1<<6)
+
+#define TCL_GLOB_PERM_RONLY (1<<0)
+#define TCL_GLOB_PERM_HIDDEN (1<<1)
+#define TCL_GLOB_PERM_R (1<<2)
+#define TCL_GLOB_PERM_W (1<<3)
+#define TCL_GLOB_PERM_X (1<<4)
+
+
+/*
+ * Typedefs for the various filesystem operations:
+ */
+typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
+typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode));
+typedef Tcl_Channel (Tcl_FSOpenFileChannelProc)
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ int mode, int permissions));
+typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern,
+ Tcl_GlobTypeData * types));
+typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp));
+typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_StatBuf *buf));
+typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
+typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ int recursive, Tcl_Obj **errorPtr));
+typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
+typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void));
+/* We have to declare the utime structure here. */
+struct utimbuf;
+typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ struct utimbuf *tval));
+typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int nextCheckpoint));
+typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj **objPtrRef));
+typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_Obj** objPtrRef));
+typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ int index, Tcl_Obj *pathPtr,
+ Tcl_Obj *objPtr));
+typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_Obj *toPtr, int linkType));
+typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj *pathPtr,
+ Tcl_LoadHandle *handlePtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr));
+typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ ClientData *clientDataPtr));
+typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc)
+ _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc)
+ _ANSI_ARGS_((Tcl_Obj *pathPtr));
+typedef void (Tcl_FSFreeInternalRepProc) _ANSI_ARGS_((ClientData clientData));
+typedef ClientData (Tcl_FSDupInternalRepProc)
+ _ANSI_ARGS_((ClientData clientData));
+typedef Tcl_Obj* (Tcl_FSInternalToNormalizedProc)
+ _ANSI_ARGS_((ClientData clientData));
+typedef ClientData (Tcl_FSCreateInternalRepProc) _ANSI_ARGS_((Tcl_Obj *pathPtr));
+
+typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
+
+/*
+ *----------------------------------------------------------------
+ * Data structures related to hooking into the filesystem
+ *----------------------------------------------------------------
+ */
+
+/*
+ * Filesystem version tag. This was introduced in 8.4.
+ */
+#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1)
+
+/*
+ * struct Tcl_Filesystem:
+ *
+ * One such structure exists for each type (kind) of filesystem.
+ * It collects together in one place all the functions that are
+ * part of the specific filesystem. Tcl always accesses the
+ * filesystem through one of these structures.
+ *
+ * Not all entries need be non-NULL; any which are NULL are simply
+ * ignored. However, a complete filesystem should provide all of
+ * these functions. The explanations in the structure show
+ * the importance of each function.
+ */
+
+typedef struct Tcl_Filesystem {
+ CONST char *typeName; /* The name of the filesystem. */
+ int structureLength; /* Length of this structure, so future
+ * binary compatibility can be assured. */
+ Tcl_FSVersion version;
+ /* Version of the filesystem type. */
+ Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
+ /* Function to check whether a path is in
+ * this filesystem. This is the most
+ * important filesystem procedure. */
+ Tcl_FSDupInternalRepProc *dupInternalRepProc;
+ /* Function to duplicate internal fs rep. May
+ * be NULL (but then fs is less efficient). */
+ Tcl_FSFreeInternalRepProc *freeInternalRepProc;
+ /* Function to free internal fs rep. Must
+ * be implemented, if internal representations
+ * need freeing, otherwise it can be NULL. */
+ Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
+ /* Function to convert internal representation
+ * to a normalized path. Only required if
+ * the fs creates pure path objects with no
+ * string/path representation. */
+ Tcl_FSCreateInternalRepProc *createInternalRepProc;
+ /* Function to create a filesystem-specific
+ * internal representation. May be NULL
+ * if paths have no internal representation,
+ * or if the Tcl_FSPathInFilesystemProc
+ * for this filesystem always immediately
+ * creates an internal representation for
+ * paths it accepts. */
+ Tcl_FSNormalizePathProc *normalizePathProc;
+ /* Function to normalize a path. Should
+ * be implemented for all filesystems
+ * which can have multiple string
+ * representations for the same path
+ * object. */
+ Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
+ /* Function to determine the type of a
+ * path in this filesystem. May be NULL. */
+ Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
+ /* Function to return the separator
+ * character(s) for this filesystem. Must
+ * be implemented. */
+ Tcl_FSStatProc *statProc;
+ /*
+ * Function to process a 'Tcl_FSStat()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tcl_FSAccessProc *accessProc;
+ /*
+ * Function to process a 'Tcl_FSAccess()'
+ * call. Must be implemented for any
+ * reasonable filesystem.
+ */
+ Tcl_FSOpenFileChannelProc *openFileChannelProc;
+ /*
+ * Function to process a
+ * 'Tcl_FSOpenFileChannel()' call. Must be
+ * implemented for any reasonable
+ * filesystem.
+ */
+ Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSMatchInDirectory()'. If not
+ * implemented, then glob and recursive
+ * copy functionality will be lacking in
+ * the filesystem. */
+ Tcl_FSUtimeProc *utimeProc;
+ /* Function to process a
+ * 'Tcl_FSUtime()' call. Required to
+ * allow setting (not reading) of times
+ * with 'file mtime', 'file atime' and
+ * the open-r/open-w/fcopy implementation
+ * of 'file copy'. */
+ Tcl_FSLinkProc *linkProc;
+ /* Function to process a
+ * 'Tcl_FSLink()' call. Should be
+ * implemented only if the filesystem supports
+ * links (reading or creating). */
+ Tcl_FSListVolumesProc *listVolumesProc;
+ /* Function to list any filesystem volumes
+ * added by this filesystem. Should be
+ * implemented only if the filesystem adds
+ * volumes at the head of the filesystem. */
+ Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
+ /* Function to list all attributes strings
+ * which are valid for this filesystem.
+ * If not implemented the filesystem will
+ * not support the 'file attributes' command.
+ * This allows arbitrary additional information
+ * to be attached to files in the filesystem. */
+ Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
+ /* Function to process a
+ * 'Tcl_FSFileAttrsGet()' call, used by
+ * 'file attributes'. */
+ Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
+ /* Function to process a
+ * 'Tcl_FSFileAttrsSet()' call, used by
+ * 'file attributes'. */
+ Tcl_FSCreateDirectoryProc *createDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSCreateDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSRemoveDirectory()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSDeleteFileProc *deleteFileProc;
+ /* Function to process a
+ * 'Tcl_FSDeleteFile()' call. Should
+ * be implemented unless the FS is
+ * read-only. */
+ Tcl_FSCopyFileProc *copyFileProc;
+ /* Function to process a
+ * 'Tcl_FSCopyFile()' call. If not
+ * implemented Tcl will fall back
+ * on open-r, open-w and fcopy as
+ * a copying mechanism, for copying
+ * actions initiated in Tcl (not C). */
+ Tcl_FSRenameFileProc *renameFileProc;
+ /* Function to process a
+ * 'Tcl_FSRenameFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy and delete mechanism, for
+ * rename actions initiated in Tcl (not C). */
+ Tcl_FSCopyDirectoryProc *copyDirectoryProc;
+ /* Function to process a
+ * 'Tcl_FSCopyDirectory()' call. If
+ * not implemented, Tcl will fall back
+ * on a recursive create-dir, file copy
+ * mechanism, for copying actions
+ * initiated in Tcl (not C). */
+ Tcl_FSLstatProc *lstatProc;
+ /* Function to process a
+ * 'Tcl_FSLstat()' call. If not implemented,
+ * Tcl will attempt to use the 'statProc'
+ * defined above instead. */
+ Tcl_FSLoadFileProc *loadFileProc;
+ /* Function to process a
+ * 'Tcl_FSLoadFile()' call. If not
+ * implemented, Tcl will fall back on
+ * a copy to native-temp followed by a
+ * Tcl_FSLoadFile on that temporary copy. */
+ Tcl_FSGetCwdProc *getCwdProc;
+ /*
+ * Function to process a 'Tcl_FSGetCwd()'
+ * call. Most filesystems need not
+ * implement this. It will usually only be
+ * called once, if 'getcwd' is called
+ * before 'chdir'. May be NULL.
+ */
+ Tcl_FSChdirProc *chdirProc;
+ /*
+ * Function to process a 'Tcl_FSChdir()'
+ * call. If filesystems do not implement
+ * this, it will be emulated by a series of
+ * directory access checks. Otherwise,
+ * virtual filesystems which do implement
+ * it need only respond with a positive
+ * return result if the dirName is a valid
+ * directory in their filesystem. They
+ * need not remember the result, since that
+ * will be automatically remembered for use
+ * by GetCwd. Real filesystems should
+ * carry out the correct action (i.e. call
+ * the correct system 'chdir' api). If not
+ * implemented, then 'cd' and 'pwd' will
+ * fail inside the filesystem.
+ */
+} Tcl_Filesystem;
+
+/*
+ * The following definitions are used as values for the 'linkAction' flag
+ * to Tcl_FSLink, or the linkProc of any filesystem. Any combination
+ * of flags can be given. For link creation, the linkProc should create
+ * a link which matches any of the types given.
+ *
+ * TCL_CREATE_SYMBOLIC_LINK: Create a symbolic or soft link.
+ * TCL_CREATE_HARD_LINK: Create a hard link.
+ */
+#define TCL_CREATE_SYMBOLIC_LINK 0x01
+#define TCL_CREATE_HARD_LINK 0x02
+
/*
* The following structure represents the Notifier functions that
* you can override with the Tcl_SetNotifier call.
*/
-
typedef struct Tcl_NotifierProcs {
Tcl_SetTimerProc *setTimerProc;
Tcl_WaitForEventProc *waitForEventProc;
Tcl_CreateFileHandlerProc *createFileHandlerProc;
Tcl_DeleteFileHandlerProc *deleteFileHandlerProc;
+ Tcl_InitNotifierProc *initNotifierProc;
+ Tcl_FinalizeNotifierProc *finalizeNotifierProc;
+ Tcl_AlertNotifierProc *alertNotifierProc;
+ Tcl_ServiceModeHookProc *serviceModeHookProc;
} Tcl_NotifierProcs;
+
/*
* The following structure represents a user-defined encoding. It collects
* together all the functions that are used by the specific encoding.
*/
-
typedef struct Tcl_EncodingType {
CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp".
* This name is the unique key for this
* in the destination buffer and then continue
* to sonvert the source.
*/
-
#define TCL_ENCODING_START 0x01
#define TCL_ENCODING_END 0x02
#define TCL_ENCODING_STOPONERROR 0x04
+
/*
- *----------------------------------------------------------------
- * The following data structures and declarations are for the new
- * Tcl parser. This stuff should all move to tcl.h eventually.
- *----------------------------------------------------------------
+ * The following data structures and declarations are for the new Tcl
+ * parser.
*/
/*
* variable reference, one of the following structures is created to
* describe the token.
*/
-
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD;
* see below for valid types. */
- char *start; /* First character in token. */
+ CONST char *start; /* First character in token. */
int size; /* Number of bytes in token. */
int numComponents; /* If this token is composed of other
* tokens, this field tells how many of
* operator's operands. NumComponents is
* always 0.
*/
-
#define TCL_TOKEN_WORD 1
#define TCL_TOKEN_SIMPLE_WORD 2
#define TCL_TOKEN_TEXT 4
* will be stored in the error field of the Tcl_Parse structure
* defined below.
*/
-
#define TCL_PARSE_SUCCESS 0
#define TCL_PARSE_QUOTE_EXTRA 1
#define TCL_PARSE_BRACE_EXTRA 2
* A structure of the following type is filled in by Tcl_ParseCommand.
* It describes a single command parsed from an input string.
*/
-
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
- char *commentStart; /* Pointer to # that begins the first of
+ CONST char *commentStart; /* Pointer to # that begins the first of
* one or more comments preceding the
* command. */
int commentSize; /* Number of bytes in comments (up through
* newline character that terminates the
* last comment). If there were no
* comments, this field is 0. */
- char *commandStart; /* First character in first word of command. */
+ CONST char *commandStart; /* First character in first word of command. */
int commandSize; /* Number of bytes in command, including
* first character of first word, up
* through the terminating newline,
* Tcl_ParseCommand.
*/
- char *string; /* The original command string passed to
+ CONST char *string; /* The original command string passed to
* Tcl_ParseCommand. */
- char *end; /* Points to the character just after the
+ CONST char *end; /* Points to the character just after the
* last one in the command string. */
Tcl_Interp *interp; /* Interpreter to use for error reporting,
* or NULL. */
- char *term; /* Points to character in string that
+ CONST char *term; /* Points to character in string that
* terminated most recent token. Filled in
* by ParseTokens. If an error occurs,
* points to beginning of region where the
* encoding. This error is reported only if
* TCL_ENCODING_STOPONERROR was specified.
*/
-
#define TCL_CONVERT_MULTIBYTE -1
#define TCL_CONVERT_SYNTAX -2
#define TCL_CONVERT_UNKNOWN -3
#define TCL_CONVERT_NOSPACE -4
+
/*
* The maximum number of bytes that are necessary to represent a single
* Unicode character in UTF-8.
*/
-
#define TCL_UTF_MAX 3
/*
- * This represents a Unicode character.
+ * This represents a Unicode character. Any changes to this should
+ * also be reflected in regcustom.h.
*/
-
typedef unsigned short Tcl_UniChar;
+
/*
* Deprecated Tcl procedures:
*/
-
#ifndef TCL_NO_DEPRECATED
-#define Tcl_EvalObj(interp,objPtr) Tcl_EvalObjEx((interp),(objPtr),0)
-#define Tcl_GlobalEvalObj(interp,objPtr) \
+# define Tcl_EvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),0)
+# define Tcl_GlobalEvalObj(interp,objPtr) \
Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
#endif
+
/*
* These function have been renamed. The old names are deprecated, but we
* define these macros for backwards compatibilty.
*/
-
#define Tcl_Ckalloc Tcl_Alloc
#define Tcl_Ckfree Tcl_Free
#define Tcl_Ckrealloc Tcl_Realloc
#define panic Tcl_Panic
#define panicVA Tcl_PanicVA
+
/*
* The following constant is used to test for older versions of Tcl
* in the stubs tables.
* value since the stubs tables don't match.
*/
-#define TCL_STUB_MAGIC 0xFCA3BACF
+#define TCL_STUB_MAGIC ((int)0xFCA3BACF)
/*
* The following function is required to be defined in all stubs aware
* linked into an application.
*/
-EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
- char *version, int exact));
+EXTERN CONST char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *version, int exact));
#ifndef USE_TCL_STUBS
#include "tclDecls.h"
/*
+ * Include platform specific public function declarations that are
+ * accessible via the stubs table.
+ */
+
+/*
+ * tclPlatDecls.h can't be included here on the Mac, as we need
+ * Mac specific headers to define the Mac types used in this file,
+ * but these Mac haders conflict with a number of tk types
+ * and thus can't be included in the globally read tcl.h
+ * This header was originally added here as a fix for bug 5241
+ * (stub link error for symbols in TclPlatStubs table), as a work-
+ * around for the bug on the mac, tclMac.h is included immediately
+ * after tcl.h in the tcl precompiled header (with DLLEXPORT set).
+ */
+
+#if !defined(MAC_TCL)
+#include "tclPlatDecls.h"
+#endif
+
+/*
* Public functions that are not accessible via the stubs table.
*/
* This function is not *implemented* by the tcl library, so the storage
* class is neither DLLEXPORT nor DLLIMPORT
*/
-
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS
EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));
-#endif /* RESOURCE_INCLUDED */
-
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
+#endif /* RC_INVOKED */
+
/*
* end block for C++
*/
-
#ifdef __cplusplus
}
#endif
-
-#endif /* _TCL */
+#endif /* _TCL */
* RCS: @(#) $Id$
*/
+/*
+ * Windows and Unix use an alternative allocator when building with threads
+ * that has significantly reduced lock contention.
+ */
+
+#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)
+
#include "tclInt.h"
#include "tclPort.h"
#endif
/*
- * With gcc this will already be defined. This should really
- * make use of AC_CHECK_TYPE(caddr_t) but that can wait
- * until we use config.h properly.
+ * We should really make use of AC_CHECK_TYPE(caddr_t)
+ * here, but it can wait until Tcl uses config.h properly.
*/
-
-#if defined(MAC_TCL) || defined(_MSC_VER) || defined(__MINGW32__)
+#if defined(MAC_TCL) || defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__)
typedef unsigned long caddr_t;
#endif
}
#endif /* !USE_TCLALLOC */
-
+#endif /* !TCL_THREADS */
#include "tclInt.h"
#include "tclPort.h"
+/* Forward declaration */
+struct ThreadSpecificData;
+
/*
* One of the following structures exists for each asynchronous
* handler:
* is invoked. */
ClientData clientData; /* Value to pass to handler when it
* is invoked. */
+ struct ThreadSpecificData *originTsd;
+ /* Used in Tcl_AsyncMark to modify thread-
+ * specific data from outside the thread
+ * it is associated to. */
+ Tcl_ThreadId originThrdId; /* Origin thread where this token was
+ * created and where it will be
+ * yielded. */
} AsyncHandler;
-/*
- * The variables below maintain a list of all existing handlers.
- */
-static AsyncHandler *firstHandler; /* First handler defined for process,
- * or NULL if none. */
-static AsyncHandler *lastHandler; /* Last handler or NULL. */
+typedef struct ThreadSpecificData {
+ /*
+ * The variables below maintain a list of all existing handlers
+ * specific to the calling thread.
+ */
+ AsyncHandler *firstHandler; /* First handler defined for process,
+ * or NULL if none. */
+ AsyncHandler *lastHandler; /* Last handler or NULL. */
-TCL_DECLARE_MUTEX(asyncMutex) /* Process-wide async handler lock */
+ /*
+ * The variable below is set to 1 whenever a handler becomes ready and
+ * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be
+ * checked elsewhere in the application by calling Tcl_AsyncReady to see
+ * if Tcl_AsyncInvoke should be invoked.
+ */
-/*
- * The variable below is set to 1 whenever a handler becomes ready and
- * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be
- * checked elsewhere in the application by calling Tcl_AsyncReady to see
- * if Tcl_AsyncInvoke should be invoked.
- */
+ int asyncReady;
+
+ /*
+ * The variable below indicates whether Tcl_AsyncInvoke is currently
+ * working. If so then we won't set asyncReady again until
+ * Tcl_AsyncInvoke returns.
+ */
-static int asyncReady = 0;
+ int asyncActive;
+ Tcl_Mutex asyncMutex; /* Thread-specific AsyncHandler linked-list lock */
+
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+\f
/*
- * The variable below indicates whether Tcl_AsyncInvoke is currently
- * working. If so then we won't set asyncReady again until
- * Tcl_AsyncInvoke returns.
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeAsync --
+ *
+ * Finalizes the mutex in the thread local data structure for the
+ * async subsystem.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Forgets knowledge of the mutex should it have been created.
+ *
+ *----------------------------------------------------------------------
*/
-static int asyncActive = 0;
+void
+TclFinalizeAsync()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (tsdPtr->asyncMutex != NULL) {
+ Tcl_MutexFinalize(&tsdPtr->asyncMutex);
+ }
+}
\f
/*
*----------------------------------------------------------------------
ClientData clientData; /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
- Tcl_MutexLock(&asyncMutex);
- if (firstHandler == NULL) {
- firstHandler = asyncPtr;
+ asyncPtr->originTsd = tsdPtr;
+ asyncPtr->originThrdId = Tcl_GetCurrentThread();
+
+ Tcl_MutexLock(&tsdPtr->asyncMutex);
+ if (tsdPtr->firstHandler == NULL) {
+ tsdPtr->firstHandler = asyncPtr;
} else {
- lastHandler->nextPtr = asyncPtr;
+ tsdPtr->lastHandler->nextPtr = asyncPtr;
}
- lastHandler = asyncPtr;
- Tcl_MutexUnlock(&asyncMutex);
+ tsdPtr->lastHandler = asyncPtr;
+ Tcl_MutexUnlock(&tsdPtr->asyncMutex);
return (Tcl_AsyncHandler) asyncPtr;
}
\f
Tcl_AsyncMark(async)
Tcl_AsyncHandler async; /* Token for handler. */
{
- Tcl_MutexLock(&asyncMutex);
- ((AsyncHandler *) async)->ready = 1;
- if (!asyncActive) {
- asyncReady = 1;
- TclpAsyncMark(async);
+ AsyncHandler *token = (AsyncHandler *) async;
+
+ Tcl_MutexLock(&token->originTsd->asyncMutex);
+ token->ready = 1;
+ if (!token->originTsd->asyncActive) {
+ token->originTsd->asyncReady = 1;
+ Tcl_ThreadAlert(token->originThrdId);
}
- Tcl_MutexUnlock(&asyncMutex);
+ Tcl_MutexUnlock(&token->originTsd->asyncMutex);
}
\f
/*
* just completed. */
{
AsyncHandler *asyncPtr;
- Tcl_MutexLock(&asyncMutex);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ Tcl_MutexLock(&tsdPtr->asyncMutex);
- if (asyncReady == 0) {
- Tcl_MutexUnlock(&asyncMutex);
+ if (tsdPtr->asyncReady == 0) {
+ Tcl_MutexUnlock(&tsdPtr->asyncMutex);
return code;
}
- asyncReady = 0;
- asyncActive = 1;
+ tsdPtr->asyncReady = 0;
+ tsdPtr->asyncActive = 1;
if (interp == NULL) {
code = 0;
}
*/
while (1) {
- for (asyncPtr = firstHandler; asyncPtr != NULL;
+ for (asyncPtr = tsdPtr->firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->ready) {
break;
break;
}
asyncPtr->ready = 0;
- Tcl_MutexUnlock(&asyncMutex);
+ Tcl_MutexUnlock(&tsdPtr->asyncMutex);
code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code);
- Tcl_MutexLock(&asyncMutex);
+ Tcl_MutexLock(&tsdPtr->asyncMutex);
}
- asyncActive = 0;
- Tcl_MutexUnlock(&asyncMutex);
+ tsdPtr->asyncActive = 0;
+ Tcl_MutexUnlock(&tsdPtr->asyncMutex);
return code;
}
\f
Tcl_AsyncDelete(async)
Tcl_AsyncHandler async; /* Token for handler to delete. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
AsyncHandler *asyncPtr = (AsyncHandler *) async;
AsyncHandler *prevPtr;
- Tcl_MutexLock(&asyncMutex);
- if (firstHandler == asyncPtr) {
- firstHandler = asyncPtr->nextPtr;
- if (firstHandler == NULL) {
- lastHandler = NULL;
+ Tcl_MutexLock(&tsdPtr->asyncMutex);
+ if (tsdPtr->firstHandler == asyncPtr) {
+ tsdPtr->firstHandler = asyncPtr->nextPtr;
+ if (tsdPtr->firstHandler == NULL) {
+ tsdPtr->lastHandler = NULL;
}
} else {
- prevPtr = firstHandler;
+ prevPtr = tsdPtr->firstHandler;
while (prevPtr->nextPtr != asyncPtr) {
prevPtr = prevPtr->nextPtr;
}
prevPtr->nextPtr = asyncPtr->nextPtr;
- if (lastHandler == asyncPtr) {
- lastHandler = prevPtr;
+ if (tsdPtr->lastHandler == asyncPtr) {
+ tsdPtr->lastHandler = prevPtr;
}
}
- Tcl_MutexUnlock(&asyncMutex);
+ Tcl_MutexUnlock(&tsdPtr->asyncMutex);
ckfree((char *) asyncPtr);
}
\f
*
* This procedure can be used to tell whether Tcl_AsyncInvoke
* needs to be called. This procedure is the external interface
- * for checking the internal asyncReady variable.
+ * for checking the thread-specific asyncReady variable.
*
* Results:
* The return value is 1 whenever a handler is ready and is 0
int
Tcl_AsyncReady()
{
- return asyncReady;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ return tsdPtr->asyncReady;
}
*
* Contains the basic facilities for TCL command interpretation,
* including interpreter creation and deletion, command creation
- * and deletion, and command parsing and execution.
+ * and deletion, and command/script execution.
*
* Copyright (c) 1987-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* Static procedures in this file:
*/
+static char * CallCommandTraces _ANSI_ARGS_((Interp *iPtr,
+ Command *cmdPtr, CONST char *oldName,
+ CONST char* newName, int flags));
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
static void ProcessUnexpectedResult _ANSI_ARGS_((
Tcl_Interp *interp, int returnCode));
-static void RecordTracebackInfo _ANSI_ARGS_((
- Tcl_Interp *interp, Tcl_Obj *objPtr,
- int numSrcBytes));
+static int StringTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp* interp,
+ int level,
+ CONST char* command,
+ Tcl_Command commandInfo,
+ int objc,
+ Tcl_Obj *CONST objv[]));
+static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData));
extern TclStubs tclStubs;
*/
{"append", (Tcl_CmdProc *) NULL, Tcl_AppendObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileAppendCmd, 1},
{"array", (Tcl_CmdProc *) NULL, Tcl_ArrayObjCmd,
(CompileProc *) NULL, 1},
{"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
{"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
(CompileProc *) NULL, 1},
{"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileLappendCmd, 1},
{"lindex", (Tcl_CmdProc *) NULL, Tcl_LindexObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileLindexCmd, 1},
{"linsert", (Tcl_CmdProc *) NULL, Tcl_LinsertObjCmd,
(CompileProc *) NULL, 1},
{"list", (Tcl_CmdProc *) NULL, Tcl_ListObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileListCmd, 1},
{"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileLlengthCmd, 1},
{"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
(CompileProc *) NULL, 0},
{"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
(CompileProc *) NULL, 1},
{"lsearch", (Tcl_CmdProc *) NULL, Tcl_LsearchObjCmd,
(CompileProc *) NULL, 1},
+ {"lset", (Tcl_CmdProc *) NULL, Tcl_LsetObjCmd,
+ TclCompileLsetCmd, 1},
{"lsort", (Tcl_CmdProc *) NULL, Tcl_LsortObjCmd,
(CompileProc *) NULL, 1},
{"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
{"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
(CompileProc *) NULL, 1},
{"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileRegexpCmd, 1},
{"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd,
(CompileProc *) NULL, 1},
{"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
(CompileProc *) NULL, 1},
{"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileReturnCmd, 1},
{"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd,
(CompileProc *) NULL, 1},
{"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd,
{"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
(CompileProc *) NULL, 1},
{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
- (CompileProc *) NULL, 1},
+ TclCompileStringCmd, 1},
{"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd,
(CompileProc *) NULL, 1},
{"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
(CompileProc *) NULL, 0}
};
+/*
+ * The following structure holds the client data for string-based
+ * trace procs
+ */
+
+typedef struct StringTraceData {
+ ClientData clientData; /* Client data from Tcl_CreateTrace */
+ Tcl_CmdTraceProc* proc; /* Trace procedure from Tcl_CreateTrace */
+} StringTraceData;
\f
/*
*----------------------------------------------------------------------
* Tcl_DeleteInterp.
*
* Side effects:
- * The command interpreter is initialized with an empty variable
- * table and the built-in commands.
+ * The command interpreter is initialized with the built-in commands
+ * and with the variables documented in tclvars(n).
*
*----------------------------------------------------------------------
*/
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
- iPtr->maxNestingDepth = 1000;
+ iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL;
iPtr->varFramePtr = NULL;
- iPtr->activeTracePtr = NULL;
+ iPtr->activeVarTracePtr = NULL;
iPtr->returnCode = TCL_OK;
iPtr->errorInfo = NULL;
iPtr->errorCode = NULL;
iPtr->scriptFile = NULL;
iPtr->flags = 0;
iPtr->tracePtr = NULL;
+ iPtr->tracesForbiddingInline = 0;
+ iPtr->activeCmdTracePtr = NULL;
+ iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = (Tcl_HashTable *) NULL;
iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
}
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = (ClientData) NULL;
- cmdPtr->deleted = 0;
+ cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
+ cmdPtr->tracePtr = NULL;
Tcl_SetHashValue(hPtr, cmdPtr);
}
}
*/
i = 0;
- for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL;
+ for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize",
+ Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY);
+
/*
* Set up other variables such as tcl_version and tcl_library
*/
void
Tcl_SetAssocData(interp, name, proc, clientData)
Tcl_Interp *interp; /* Interpreter to associate with. */
- char *name; /* Name for association. */
+ CONST char *name; /* Name for association. */
Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
* about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
void
Tcl_DeleteAssocData(interp, name)
Tcl_Interp *interp; /* Interpreter to associate with. */
- char *name; /* Name of association. */
+ CONST char *name; /* Name of association. */
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
ClientData
Tcl_GetAssocData(interp, name, procPtr)
Tcl_Interp *interp; /* Interpreter associated with. */
- char *name; /* Name of association. */
+ CONST char *name; /* Name of association. */
Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
* of current deletion callback. */
{
}
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
- Trace *nextPtr = iPtr->tracePtr->nextPtr;
-
- ckfree((char *) iPtr->tracePtr);
- iPtr->tracePtr = nextPtr;
+ Tcl_DeleteTrace( (Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr );
}
if (iPtr->execEnvPtr != NULL) {
TclDeleteExecEnv(iPtr->execEnvPtr);
int
Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
Tcl_Interp *interp; /* Interpreter in which to hide command. */
- char *cmdName; /* Name of command to hide. */
- char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
+ CONST char *cmdName; /* Name of command to hide. */
+ CONST char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Command cmd;
Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
Tcl_Interp *interp; /* Interpreter in which to make command
* callable. */
- char *hiddenCmdToken; /* Name of hidden command. */
- char *cmdName; /* Name of to-be-exposed command. */
+ CONST char *hiddenCmdToken; /* Name of hidden command. */
+ CONST char *cmdName; /* Name of to-be-exposed command. */
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr;
Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
Tcl_Interp *interp; /* Token for command interpreter returned by
* a previous call to Tcl_CreateInterp. */
- char *cmdName; /* Name of command. If it contains namespace
+ CONST char *cmdName; /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put
* in the global namespace. */
Namespace *nsPtr, *dummy1, *dummy2;
Command *cmdPtr, *refCmdPtr;
Tcl_HashEntry *hPtr;
- char *tail;
+ CONST char *tail;
int new;
ImportedCmdData *dataPtr;
cmdPtr->clientData = clientData;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
- cmdPtr->deleted = 0;
+ cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
+ cmdPtr->tracePtr = NULL;
/*
* Plug in any existing import references found above. Be sure
Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by previous call to Tcl_CreateInterp). */
- char *cmdName; /* Name of command. If it contains namespace
+ CONST char *cmdName; /* Name of command. If it contains namespace
* qualifiers, the new command is put in the
* specified namespace; otherwise it is put
* in the global namespace. */
Namespace *nsPtr, *dummy1, *dummy2;
Command *cmdPtr, *refCmdPtr;
Tcl_HashEntry *hPtr;
- char *tail;
+ CONST char *tail;
int new;
ImportedCmdData *dataPtr;
cmdPtr->clientData = (ClientData) cmdPtr;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
- cmdPtr->deleted = 0;
+ cmdPtr->flags = 0;
cmdPtr->importRefPtr = NULL;
+ cmdPtr->tracePtr = NULL;
/*
* Plug in any existing import references found above. Be sure
*/
#define NUM_ARGS 20
- char *(argStorage[NUM_ARGS]);
- char **argv = argStorage;
+ CONST char *(argStorage[NUM_ARGS]);
+ CONST char **argv = argStorage;
/*
* Create the string argument array "argv". Make sure argv is large
*/
if ((objc + 1) > NUM_ARGS) {
- argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
+ argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
}
for (i = 0; i < objc; i++) {
ClientData clientData; /* Points to command's Command structure. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- register char **argv; /* Argument strings. */
+ register CONST char **argv; /* Argument strings. */
{
Command *cmdPtr = (Command *) clientData;
register Tcl_Obj *objPtr;
char *newName; /* New command name. */
{
Interp *iPtr = (Interp *) interp;
- char *newTail;
+ CONST char *newTail;
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
Tcl_Command cmd;
Command *cmdPtr;
}
/*
+ * Script for rename traces can delete the command "oldName".
+ * Therefore increment the reference count for cmdPtr so that
+ * it's Command structure is freed only towards the end of this
+ * function by calling TclCleanupCommand.
+ */
+ cmdPtr->refCount++;
+ CallCommandTraces(iPtr,cmdPtr,oldName,newName,TCL_TRACE_RENAME);
+
+ /*
* The new command name is okay, so remove the command from its
* current namespace. This is like deleting the command, so bump
* the cmdEpoch to invalidate any cached references to the command.
iPtr->compileEpoch++;
}
+ /*
+ * Now free the Command structure, if the "oldName" command has
+ * been deleted by invocation of rename traces.
+ */
+ TclCleanupCommand(cmdPtr);
+
return TCL_OK;
}
\f
Tcl_SetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
- char *cmdName; /* Name of desired command. */
- Tcl_CmdInfo *infoPtr; /* Where to find information
+ CONST char *cmdName; /* Name of desired command. */
+ CONST Tcl_CmdInfo *infoPtr; /* Where to find information
* to store in the command. */
{
Tcl_Command cmd;
- Command *cmdPtr;
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
+
+ return Tcl_SetCommandInfoFromToken( cmd, infoPtr );
+
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetCommandInfoFromToken --
+ *
+ * Modifies various information about a Tcl command. Note that
+ * this procedure will not change a command's namespace; use
+ * Tcl_RenameCommand to do that. Also, the isNativeObjectProc
+ * member of *infoPtr is ignored.
+ *
+ * Results:
+ * If cmdName exists in interp, then the information at *infoPtr
+ * is stored with the command in place of the current information
+ * and 1 is returned. If the command doesn't exist then 0 is
+ * returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_SetCommandInfoFromToken( cmd, infoPtr )
+ Tcl_Command cmd;
+ CONST Tcl_CmdInfo* infoPtr;
+{
+ Command* cmdPtr; /* Internal representation of the command */
+
if (cmd == (Tcl_Command) NULL) {
return 0;
}
Tcl_GetCommandInfo(interp, cmdName, infoPtr)
Tcl_Interp *interp; /* Interpreter in which to look
* for command. */
- char *cmdName; /* Name of desired command. */
+ CONST char *cmdName; /* Name of desired command. */
Tcl_CmdInfo *infoPtr; /* Where to store information about
* command. */
{
Tcl_Command cmd;
- Command *cmdPtr;
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
/*flags*/ 0);
- if (cmd == (Tcl_Command) NULL) {
+
+ return Tcl_GetCommandInfoFromToken( cmd, infoPtr );
+
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetCommandInfoFromToken --
+ *
+ * Returns various information about a Tcl command.
+ *
+ * Results:
+ * Copies information from the command identified by 'cmd' into
+ * a caller-supplied structure and returns 1. If the 'cmd' is
+ * NULL, leaves the structure untouched and returns 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetCommandInfoFromToken( cmd, infoPtr )
+ Tcl_Command cmd;
+ Tcl_CmdInfo* infoPtr;
+{
+
+ Command* cmdPtr; /* Internal representation of the command */
+
+ if ( cmd == (Tcl_Command) NULL ) {
return 0;
}
infoPtr->deleteProc = cmdPtr->deleteProc;
infoPtr->deleteData = cmdPtr->deleteData;
infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr;
+
return 1;
+
}
\f
/*
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetCommandName(interp, command)
Tcl_Interp *interp; /* Interpreter containing the command. */
Tcl_Command command; /* Token for command returned by a previous
Tcl_DeleteCommand(interp, cmdName)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by a previous Tcl_CreateInterp call). */
- char *cmdName; /* Name of command to remove. */
+ CONST char *cmdName; /* Name of command to remove. */
{
Tcl_Command cmd;
* flag allows us to detect these cases and skip nested deletes.
*/
- if (cmdPtr->deleted) {
+ if (cmdPtr->flags & CMD_IS_DELETED) {
/*
* Another deletion is already in progress. Remove the hash
* table entry now, but don't invoke a callback or free the
return 0;
}
+ /*
+ * We must delete this command, even though both traces and
+ * delete procs may try to avoid this (renaming the command etc).
+ * Also traces and delete procs may try to delete the command
+ * themsevles. This flag declares that a delete is in progress
+ * and that recursive deletes should be ignored.
+ */
+ cmdPtr->flags |= CMD_IS_DELETED;
+
+ /*
+ * Call trace procedures for the command being deleted. Then delete
+ * its traces.
+ */
+
+ if (cmdPtr->tracePtr != NULL) {
+ CommandTrace *tracePtr;
+ CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
+ /* Now delete these traces */
+ tracePtr = cmdPtr->tracePtr;
+ while (tracePtr != NULL) {
+ CommandTrace *nextPtr = tracePtr->nextPtr;
+ Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
+ tracePtr = nextPtr;
+ }
+ cmdPtr->tracePtr = NULL;
+ }
+
/*
* If the command being deleted has a compile procedure, increment the
* interpreter's compileEpoch to invalidate its compiled code. This
iPtr->compileEpoch++;
}
- cmdPtr->deleted = 1;
if (cmdPtr->deleteProc != NULL) {
/*
* Delete the command's client data. If this was an imported command
TclCleanupCommand(cmdPtr);
return 0;
}
+static char *
+CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
+ Interp *iPtr; /* Interpreter containing command. */
+ Command *cmdPtr; /* Command whose traces are to be
+ * invoked. */
+ CONST char *oldName; /* Command's old name, or NULL if we
+ * must get the name from cmdPtr */
+ CONST char *newName; /* Command's new name, or NULL if
+ * the command is not being renamed */
+ int flags; /* Flags passed to trace procedures:
+ * indicates what's happening to command,
+ * plus other stuff like TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, and
+ * TCL_INTERP_DESTROYED. */
+{
+ register CommandTrace *tracePtr;
+ ActiveCommandTrace active;
+ char *result;
+ Tcl_Obj *oldNamePtr = NULL;
+
+ if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
+ /*
+ * While a rename trace is active, we will not process any more
+ * rename traces; while a delete trace is active we will never
+ * reach here -- because Tcl_DeleteCommandFromToken checks for the
+ * condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately
+ * when a command deletion is in progress. For all other traces,
+ * delete traces will not be invoked but a call to TraceCommandProc
+ * will ensure that tracePtr->clientData is freed whenever the
+ * command "oldName" is deleted.
+ */
+ if (cmdPtr->flags & TCL_TRACE_RENAME) {
+ flags &= ~TCL_TRACE_RENAME;
+ }
+ if (flags == 0) {
+ return NULL;
+ }
+ }
+ cmdPtr->flags |= CMD_TRACE_ACTIVE;
+ cmdPtr->refCount++;
+
+ result = NULL;
+ active.nextPtr = iPtr->activeCmdTracePtr;
+ iPtr->activeCmdTracePtr = &active;
+
+ if (flags & TCL_TRACE_DELETE) {
+ flags |= TCL_TRACE_DESTROYED;
+ }
+ active.cmdPtr = cmdPtr;
+ Tcl_Preserve((ClientData) iPtr);
+ for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
+ tracePtr = active.nextTracePtr) {
+ active.nextTracePtr = tracePtr->nextPtr;
+ if (!(tracePtr->flags & flags)) {
+ continue;
+ }
+ cmdPtr->flags |= tracePtr->flags;
+ if (oldName == NULL) {
+ TclNewObj(oldNamePtr);
+ Tcl_IncrRefCount(oldNamePtr);
+ Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
+ (Tcl_Command) cmdPtr, oldNamePtr);
+ oldName = TclGetString(oldNamePtr);
+ }
+ Tcl_Preserve((ClientData) tracePtr);
+ (*tracePtr->traceProc)(tracePtr->clientData,
+ (Tcl_Interp *) iPtr, oldName, newName, flags);
+ cmdPtr->flags &= ~tracePtr->flags;
+ Tcl_Release((ClientData) tracePtr);
+ }
+
+ /*
+ * If a new object was created to hold the full oldName,
+ * free it now.
+ */
+
+ if (oldNamePtr != NULL) {
+ TclDecrRefCount(oldNamePtr);
+ }
+
+ /*
+ * Restore the variable's flags, remove the record of our active
+ * traces, and then return.
+ */
+
+ cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
+ cmdPtr->refCount--;
+ iPtr->activeCmdTracePtr = active.nextPtr;
+ Tcl_Release((ClientData) iPtr);
+ return result;
+}
+
\f
/*
*----------------------------------------------------------------------
Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which function is
* to be available. */
- char *name; /* Name of function (e.g. "sin"). */
+ CONST char *name; /* Name of function (e.g. "sin"). */
int numArgs; /* Nnumber of arguments required by
* function. */
Tcl_ValueType *argTypes; /* Array of types acceptable for
/*
*----------------------------------------------------------------------
*
- * Tcl_EvalObjEx --
+ * Tcl_GetMathFuncInfo --
*
- * Execute Tcl commands stored in a Tcl object. These commands are
- * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
- * is specified.
+ * Discovers how a particular math function was created in a given
+ * interpreter.
*
* Results:
- * The return value is one of the return codes defined in tcl.h
- * (such as TCL_OK), and the interpreter's result contains a value
- * to supplement the return code.
+ * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message
+ * in the interpreter result if that happens.)
*
* Side effects:
- * The object is converted, if necessary, to a ByteCode object that
- * holds the bytecode instructions for the commands. Executing the
- * commands will almost certainly have side effects that depend
- * on those commands.
- *
- * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
- * last character executed in the objPtr's string.
+ * If this function succeeds, the variables pointed to by the
+ * numArgsPtr and argTypePtr arguments will be updated to detail the
+ * arguments allowed by the function. The variable pointed to by the
+ * procPtr argument will be set to NULL if the function is a builtin
+ * function, and will be set to the address of the C function used to
+ * implement the math function otherwise (in which case the variable
+ * pointed to by the clientDataPtr argument will also be updated.)
*
*----------------------------------------------------------------------
*/
int
-Tcl_EvalObjEx(interp, objPtr, flags)
- Tcl_Interp *interp; /* Token for command interpreter
- * (returned by a previous call to
- * Tcl_CreateInterp). */
- register Tcl_Obj *objPtr; /* Pointer to object containing
- * commands to execute. */
- int flags; /* Collection of OR-ed bits that
- * control the evaluation of the
- * script. Supported values are
- * TCL_EVAL_GLOBAL and
- * TCL_EVAL_DIRECT. */
+Tcl_GetMathFuncInfo(interp, name, numArgsPtr, argTypesPtr, procPtr,
+ clientDataPtr)
+ Tcl_Interp *interp;
+ CONST char *name;
+ int *numArgsPtr;
+ Tcl_ValueType **argTypesPtr;
+ Tcl_MathProc **procPtr;
+ ClientData *clientDataPtr;
{
- register Interp *iPtr = (Interp *) interp;
- int evalFlags; /* Interp->evalFlags value when the
- * procedure was called. */
- register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
- int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
- * at all were executed. */
- int numSrcBytes;
- int result;
- CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
- * in case TCL_EVAL_GLOBAL was set. */
- Namespace *namespacePtr;
-
- Tcl_IncrRefCount(objPtr);
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ MathFunc *mathFuncPtr;
+ Tcl_ValueType *argTypes;
+ int i,numArgs;
- if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
- /*
- * We're not supposed to use the compiler or byte-code interpreter.
- * Let Tcl_EvalEx evaluate the command directly (and probably
- * more slowly).
- *
- * Pure List Optimization (no string representation). In this
- * case, we can safely use Tcl_EvalObjv instead and get an
- * appreciable improvement in execution speed. This is because it
- * allows us to avoid a setFromAny step that would just pack
- * everything into a string and back out again.
- *
- * USE_EVAL_DIRECT is a special flag used for testing purpose only
- * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
- */
- if (!(iPtr->flags & USE_EVAL_DIRECT) &&
- (objPtr->typePtr == &tclListType) && /* is a list... */
- (objPtr->bytes == NULL) /* ...without a string rep */) {
- register List *listRepPtr =
- (List *) objPtr->internalRep.otherValuePtr;
- result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
- listRepPtr->elements, flags);
- } else {
- register char *p;
- p = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = Tcl_EvalEx(interp, p, numSrcBytes, flags);
- }
- Tcl_DecrRefCount(objPtr);
- return result;
+ hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, name);
+ if (hPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "math function \"", name, "\" not known in this interpreter",
+ (char *) NULL);
+ return TCL_ERROR;
}
+ mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
- /*
- * Prevent the object from being deleted as a side effect of evaling it.
- */
-
- savedVarFramePtr = iPtr->varFramePtr;
- if (flags & TCL_EVAL_GLOBAL) {
- iPtr->varFramePtr = NULL;
+ *numArgsPtr = numArgs = mathFuncPtr->numArgs;
+ if (numArgs == 0) {
+ /* Avoid doing zero-sized allocs... */
+ numArgs = 1;
+ }
+ *argTypesPtr = argTypes =
+ (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
+ for (i = 0; i < mathFuncPtr->numArgs; i++) {
+ argTypes[i] = mathFuncPtr->argTypes[i];
}
- /*
- * Reset both the interpreter's string and object results and clear out
- * any error information. This makes sure that we return an empty
- * result if there are no commands in the command string.
- */
-
- Tcl_ResetResult(interp);
+ if (mathFuncPtr->builtinFuncIndex == -1) {
+ *procPtr = (Tcl_MathProc *) NULL;
+ } else {
+ *procPtr = mathFuncPtr->proc;
+ *clientDataPtr = mathFuncPtr->clientData;
+ }
- /*
- * Check depth of nested calls to Tcl_Eval: if this gets too large,
- * it's probably because of an infinite loop somewhere.
- */
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ListMathFuncs --
+ *
+ * Produces a list of all the math functions defined in a given
+ * interpreter.
+ *
+ * Results:
+ * A pointer to a Tcl_Obj structure with a reference count of zero,
+ * or NULL in the case of an error (in which case a suitable error
+ * message will be left in the interpreter result.)
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- iPtr->numLevels++;
- if (iPtr->numLevels > iPtr->maxNestingDepth) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
- result = TCL_ERROR;
- goto done;
+Tcl_Obj *
+Tcl_ListMathFuncs(interp, pattern)
+ Tcl_Interp *interp;
+ CONST char *pattern;
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *resultList = Tcl_NewObj();
+ register Tcl_HashEntry *hPtr;
+ Tcl_HashSearch hSearch;
+ CONST char *name;
+
+ for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
+ name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr);
+ if ((pattern == NULL || Tcl_StringMatch(name, pattern)) &&
+ /* I don't expect this to fail, but... */
+ Tcl_ListObjAppendElement(interp, resultList,
+ Tcl_NewStringObj(name,-1)) != TCL_OK) {
+ Tcl_DecrRefCount(resultList);
+ return NULL;
+ }
}
+ return resultList;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInterpReady --
+ *
+ * Check if an interpreter is ready to eval commands or scripts,
+ * i.e., if it was not deleted and if the nesting level is not
+ * too high.
+ *
+ * Results:
+ * The return value is TCL_OK if it the interpreter is ready,
+ * TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * The interpreters object and string results are cleared.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInterpReady(interp)
+ Tcl_Interp *interp;
+{
+ register Interp *iPtr = (Interp *) interp;
/*
- * On the Mac, we will never reach the default recursion limit before
- * blowing the stack. So we need to do a check here.
+ * Reset both the interpreter's string and object results and clear
+ * out any previous error information.
*/
-
- if (TclpCheckStackSpace() == 0) {
- /*NOTREACHED*/
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
- result = TCL_ERROR;
- goto done;
- }
+
+ Tcl_ResetResult(interp);
/*
* If the interpreter has been deleted, return an error.
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
"attempt to call eval in deleted interpreter",
(char *) NULL);
- result = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
/*
- * Get the ByteCode from the object. If it exists, make sure it hasn't
- * been invalidated by, e.g., someone redefining a command with a
- * compile procedure (this might make the compiled code wrong). If
- * necessary, convert the object to be a ByteCode object and compile it.
- * Also, if the code was compiled in/for a different interpreter,
- * or for a different namespace, or for the same namespace but
- * with different name resolution rules, we recompile it.
- *
- * Precompiled objects, however, are immutable and therefore
- * they are not recompiled, even if the epoch has changed.
- *
- * To be pedantically correct, we should also check that the
- * originating procPtr is the same as the current context procPtr
- * (assuming one exists at all - none for global level). This
- * code is #def'ed out because [info body] was changed to never
- * return a bytecode type object, which should obviate us from
- * the extra checks here.
+ * Check depth of nested calls to Tcl_Eval: if this gets too large,
+ * it's probably because of an infinite loop somewhere.
*/
- if (iPtr->varFramePtr != NULL) {
- namespacePtr = iPtr->varFramePtr->nsPtr;
- } else {
- namespacePtr = iPtr->globalNsPtr;
+ if (((iPtr->numLevels) >= iPtr->maxNestingDepth)
+ || (TclpCheckStackSpace() == 0)) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too many nested evaluations (infinite loop?)", -1);
+ return TCL_ERROR;
}
- if (objPtr->typePtr == &tclByteCodeType) {
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
-
- if (((Interp *) *codePtr->interpHandle != iPtr)
- || (codePtr->compileEpoch != iPtr->compileEpoch)
-#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
- || (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
- iPtr->varFramePtr->procPtr == codePtr->procPtr))
-#endif
- || (codePtr->nsPtr != namespacePtr)
- || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
- if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if ((Interp *) *codePtr->interpHandle != iPtr) {
- panic("Tcl_EvalObj: compiled script jumped interps");
- }
- codePtr->compileEpoch = iPtr->compileEpoch;
- } else {
- tclByteCodeType.freeIntRepProc(objPtr);
- }
- }
- }
- if (objPtr->typePtr != &tclByteCodeType) {
- iPtr->errorLine = 1;
- result = tclByteCodeType.setFromAnyProc(interp, objPtr);
- if (result != TCL_OK) {
- goto done;
- }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclEvalObjvInternal --
+ *
+ * This procedure evaluates a Tcl command that has already been
+ * parsed into words, with one Tcl_Obj holding each word. The caller
+ * is responsible for checking that the interpreter is ready to
+ * evaluate (by calling TclInterpReady), and also to manage the
+ * iPtr->numLevels.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR. A result or error message is left in
+ * interp's result. If an error occurs, this procedure does
+ * NOT add any information to the errorInfo variable.
+ *
+ * Side effects:
+ * Depends on the command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclEvalObjvInternal(interp, objc, objv, command, length, flags)
+ Tcl_Interp *interp; /* Interpreter in which to evaluate the
+ * command. Also used for error
+ * reporting. */
+ int objc; /* Number of words in command. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
+ * the words that make up the command. */
+ CONST char *command; /* Points to the beginning of the string
+ * representation of the command; this
+ * is used for traces. If the string
+ * representation of the command is
+ * unknown, an empty string should be
+ * supplied. If it is NULL, no traces will
+ * be called. */
+ int length; /* Number of bytes in command; if -1, all
+ * characters up to the first null byte are
+ * used. */
+ int flags; /* Collection of OR-ed bits that control
+ * the evaluation of the script. Only
+ * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
+ * currently supported. */
+
+{
+ Command *cmdPtr;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj **newObjv;
+ int i;
+ CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
+ * in case TCL_EVAL_GLOBAL was set. */
+ int code = TCL_OK;
+ int traceCode = TCL_OK;
+ int checkTraces = 1;
+
+ if (objc == 0) {
+ return TCL_OK;
+ }
+
+ /*
+ * If any execution traces rename or delete the current command,
+ * we may need (at most) two passes here.
+ */
+ while (1) {
+
+ /*
+ * Find the procedure to execute this command. If there isn't one,
+ * then see if there is a command "unknown". If so, create a new
+ * word array with "unknown" as the first word and the original
+ * command words as arguments. Then call ourselves recursively
+ * to execute it.
+ */
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_INVOKE) {
+ iPtr->varFramePtr = NULL;
+ }
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
+ iPtr->varFramePtr = savedVarFramePtr;
+
+ if (cmdPtr == NULL) {
+ newObjv = (Tcl_Obj **) ckalloc((unsigned)
+ ((objc + 1) * sizeof (Tcl_Obj *)));
+ for (i = objc-1; i >= 0; i--) {
+ newObjv[i+1] = objv[i];
+ }
+ newObjv[0] = Tcl_NewStringObj("::unknown", -1);
+ Tcl_IncrRefCount(newObjv[0]);
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
+ if (cmdPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "invalid command name \"", Tcl_GetString(objv[0]), "\"",
+ (char *) NULL);
+ code = TCL_ERROR;
+ } else if (TclInterpReady(interp) == TCL_ERROR) {
+ code = TCL_ERROR;
+ } else {
+ iPtr->numLevels++;
+ code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);
+ iPtr->numLevels--;
+ }
+ Tcl_DecrRefCount(newObjv[0]);
+ ckfree((char *) newObjv);
+ goto done;
+ }
+
+ /*
+ * Call trace procedures if needed.
+ */
+ if ((checkTraces) && (command != NULL)) {
+ int cmdEpoch = cmdPtr->cmdEpoch;
+ cmdPtr->refCount++;
+ /* If the first set of traces modifies/deletes the command or
+ * any existing traces, then the set checkTraces to 0 and
+ * go through this while loop one more time.
+ */
+ if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
+ traceCode = TclCheckInterpTraces(interp, command, length,
+ cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
+ }
+ if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES)
+ && (traceCode == TCL_OK)) {
+ traceCode = TclCheckExecutionTraces(interp, command, length,
+ cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
+ }
+ cmdPtr->refCount--;
+ if (cmdEpoch != cmdPtr->cmdEpoch) {
+ /* The command has been modified in some way */
+ checkTraces = 0;
+ continue;
+ }
+ }
+ break;
+ }
+
+ /*
+ * Finally, invoke the command's Tcl_ObjCmdProc.
+ */
+ cmdPtr->refCount++;
+ iPtr->cmdCount++;
+ if ( code == TCL_OK && traceCode == TCL_OK) {
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
+ code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
+ iPtr->varFramePtr = savedVarFramePtr;
+ }
+ if (Tcl_AsyncReady()) {
+ code = Tcl_AsyncInvoke(interp, code);
+ }
+
+ /*
+ * Call 'leave' command traces
+ */
+ if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
+ traceCode = TclCheckExecutionTraces (interp, command, length,
+ cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
+ }
+ if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
+ traceCode = TclCheckInterpTraces(interp, command, length,
+ cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
+ }
+ }
+ TclCleanupCommand(cmdPtr);
+
+ /*
+ * If one of the trace invocation resulted in error, then
+ * change the result code accordingly. Note, that the
+ * interp->result should already be set correctly by the
+ * call to TraceExecutionProc.
+ */
+
+ if (traceCode != TCL_OK) {
+ code = traceCode;
+ }
+
+ /*
+ * If the interpreter has a non-empty string result, the result
+ * object is either empty or stale because some procedure set
+ * interp->result directly. If so, move the string result to the
+ * result object, then reset the string result.
+ */
+
+ if (*(iPtr->result) != 0) {
+ (void) Tcl_GetObjResult(interp);
+ }
+
+ done:
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalObjv --
+ *
+ * This procedure evaluates a Tcl command that has already been
+ * parsed into words, with one Tcl_Obj holding each word.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR. A result or error message is left in
+ * interp's result.
+ *
+ * Side effects:
+ * Depends on the command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_EvalObjv(interp, objc, objv, flags)
+ Tcl_Interp *interp; /* Interpreter in which to evaluate the
+ * command. Also used for error
+ * reporting. */
+ int objc; /* Number of words in command. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
+ * the words that make up the command. */
+ int flags; /* Collection of OR-ed bits that control
+ * the evaluation of the script. Only
+ * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
+ * are currently supported. */
+{
+ Interp *iPtr = (Interp *)interp;
+ Trace *tracePtr;
+ Tcl_DString cmdBuf;
+ char *cmdString = ""; /* A command string is only necessary for
+ * command traces or error logs; it will be
+ * generated to replace this default value if
+ * necessary. */
+ int cmdLen = 0; /* a non-zero value indicates that a command
+ * string was generated. */
+ int code = TCL_OK;
+ int i;
+ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
+
+ for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
+ if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {
+ /*
+ * The command may be needed for an execution trace. Generate a
+ * command string.
+ */
+
+ Tcl_DStringInit(&cmdBuf);
+ for (i = 0; i < objc; i++) {
+ Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
+ }
+ cmdString = Tcl_DStringValue(&cmdBuf);
+ cmdLen = Tcl_DStringLength(&cmdBuf);
+ break;
+ }
+ }
+
+ code = TclInterpReady(interp);
+ if (code == TCL_OK) {
+ iPtr->numLevels++;
+ code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen,
+ flags);
+ iPtr->numLevels--;
+ }
+
+ /*
+ * If we are again at the top level, process any unusual
+ * return code returned by the evaluated code.
+ */
+
+ if (iPtr->numLevels == 0) {
+ if (code == TCL_RETURN) {
+ code = TclUpdateReturnInfo(iPtr);
+ }
+ if ((code != TCL_OK) && (code != TCL_ERROR)
+ && !allowExceptions) {
+ ProcessUnexpectedResult(interp, code);
+ code = TCL_ERROR;
+ }
+ }
+
+ if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
+
+ /*
+ * If there was an error, a command string will be needed for the
+ * error log: generate it now if it was not done previously.
+ */
+
+ if (cmdLen == 0) {
+ Tcl_DStringInit(&cmdBuf);
+ for (i = 0; i < objc; i++) {
+ Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
+ }
+ cmdString = Tcl_DStringValue(&cmdBuf);
+ cmdLen = Tcl_DStringLength(&cmdBuf);
+ }
+ Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
+ }
+
+ if (cmdLen != 0) {
+ Tcl_DStringFree(&cmdBuf);
+ }
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_LogCommandInfo --
+ *
+ * This procedure is invoked after an error occurs in an interpreter.
+ * It adds information to the "errorInfo" variable to describe the
+ * command that was being executed when the error occurred.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Information about the command is added to errorInfo and the
+ * line number stored internally in the interpreter is set. If this
+ * is the first call to this procedure or Tcl_AddObjErrorInfo since
+ * an error occurred, then old information in errorInfo is
+ * deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_LogCommandInfo(interp, script, command, length)
+ Tcl_Interp *interp; /* Interpreter in which to log information. */
+ CONST char *script; /* First character in script containing
+ * command (must be <= command). */
+ CONST char *command; /* First character in command that
+ * generated the error. */
+ int length; /* Number of bytes in command (-1 means
+ * use all bytes up to first null byte). */
+{
+ char buffer[200];
+ register CONST char *p;
+ char *ellipsis = "";
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->flags & ERR_ALREADY_LOGGED) {
+ /*
+ * Someone else has already logged error information for this
+ * command; we shouldn't add anything more.
+ */
+
+ return;
+ }
+
+ /*
+ * Compute the line number where the error occurred.
+ */
+
+ iPtr->errorLine = 1;
+ for (p = script; p != command; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
+ /*
+ * Create an error message to add to errorInfo, including up to a
+ * maximum number of characters of the command.
+ */
+
+ if (length < 0) {
+ length = strlen(command);
+ }
+ if (length > 150) {
+ length = 150;
+ ellipsis = "...";
+ }
+ if (!(iPtr->flags & ERR_IN_PROGRESS)) {
+ sprintf(buffer, "\n while executing\n\"%.*s%s\"",
+ length, command, ellipsis);
} else {
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if (((Interp *) *codePtr->interpHandle != iPtr)
- || (codePtr->compileEpoch != iPtr->compileEpoch)) {
- (*tclByteCodeType.freeIntRepProc)(objPtr);
- iPtr->errorLine = 1;
- result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr);
- if (result != TCL_OK) {
+ sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
+ length, command, ellipsis);
+ }
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalTokensStandard --
+ *
+ * Given an array of tokens parsed from a Tcl command (e.g., the
+ * tokens that make up a word or the index for an array variable)
+ * this procedure evaluates the tokens and concatenates their
+ * values to form a single result value.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR. A result or error message is left in
+ * interp's result.
+ *
+ * Side effects:
+ * Depends on the array of tokens being evaled.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_EvalTokensStandard(interp, tokenPtr, count)
+ Tcl_Interp *interp; /* Interpreter in which to lookup
+ * variables, execute nested commands,
+ * and report errors. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * to evaluate and concatenate. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
+{
+ Tcl_Obj *resultPtr, *indexPtr, *valuePtr;
+ char buffer[TCL_UTF_MAX];
+#ifdef TCL_MEM_DEBUG
+# define MAX_VAR_CHARS 5
+#else
+# define MAX_VAR_CHARS 30
+#endif
+ char nameBuffer[MAX_VAR_CHARS+1];
+ char *varName, *index;
+ CONST char *p = NULL; /* Initialized to avoid compiler warning. */
+ int length, code;
+
+ /*
+ * The only tricky thing about this procedure is that it attempts to
+ * avoid object creation and string copying whenever possible. For
+ * example, if the value is just a nested command, then use the
+ * command's result object directly.
+ */
+
+ code = TCL_OK;
+ resultPtr = NULL;
+ Tcl_ResetResult(interp);
+ for ( ; count > 0; count--, tokenPtr++) {
+ valuePtr = NULL;
+
+ /*
+ * The switch statement below computes the next value to be
+ * concat to the result, as either a range of text or an
+ * object.
+ */
+
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_TEXT:
+ p = tokenPtr->start;
+ length = tokenPtr->size;
+ break;
+
+ case TCL_TOKEN_BS:
+ length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
+ buffer);
+ p = buffer;
+ break;
+
+ case TCL_TOKEN_COMMAND:
+ code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
+ 0);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ valuePtr = Tcl_GetObjResult(interp);
+ break;
+
+ case TCL_TOKEN_VARIABLE:
+ if (tokenPtr->numComponents == 1) {
+ indexPtr = NULL;
+ index = NULL;
+ } else {
+ code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
+ tokenPtr->numComponents - 1);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ indexPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(indexPtr);
+ index = Tcl_GetString(indexPtr);
+ }
+
+ /*
+ * We have to make a copy of the variable name in order
+ * to have a null-terminated string. We can't make a
+ * temporary modification to the script to null-terminate
+ * the name, because a trace callback might potentially
+ * reuse the script and be affected by the null character.
+ */
+
+ if (tokenPtr[1].size <= MAX_VAR_CHARS) {
+ varName = nameBuffer;
+ } else {
+ varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
+ }
+ strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
+ varName[tokenPtr[1].size] = 0;
+ valuePtr = Tcl_GetVar2Ex(interp, varName, index,
+ TCL_LEAVE_ERR_MSG);
+ if (varName != nameBuffer) {
+ ckfree(varName);
+ }
+ if (indexPtr != NULL) {
+ Tcl_DecrRefCount(indexPtr);
+ }
+ if (valuePtr == NULL) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ count -= tokenPtr->numComponents;
+ tokenPtr += tokenPtr->numComponents;
+ break;
+
+ default:
+ panic("unexpected token type in Tcl_EvalTokensStandard");
+ }
+
+ /*
+ * If valuePtr isn't NULL, the next piece of text comes from that
+ * object; otherwise, take length bytes starting at p.
+ */
+
+ if (resultPtr == NULL) {
+ if (valuePtr != NULL) {
+ resultPtr = valuePtr;
+ } else {
+ resultPtr = Tcl_NewStringObj(p, length);
+ }
+ Tcl_IncrRefCount(resultPtr);
+ } else {
+ if (Tcl_IsShared(resultPtr)) {
+ Tcl_DecrRefCount(resultPtr);
+ resultPtr = Tcl_DuplicateObj(resultPtr);
+ Tcl_IncrRefCount(resultPtr);
+ }
+ if (valuePtr != NULL) {
+ p = Tcl_GetStringFromObj(valuePtr, &length);
+ }
+ Tcl_AppendToObj(resultPtr, p, length);
+ }
+ }
+ if (resultPtr != NULL) {
+ Tcl_SetObjResult(interp, resultPtr);
+ } else {
+ code = TCL_ERROR;
+ }
+
+ done:
+ if (resultPtr != NULL) {
+ Tcl_DecrRefCount(resultPtr);
+ }
+ return code;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalTokens --
+ *
+ * Given an array of tokens parsed from a Tcl command (e.g., the
+ * tokens that make up a word or the index for an array variable)
+ * this procedure evaluates the tokens and concatenates their
+ * values to form a single result value.
+ *
+ * Results:
+ * The return value is a pointer to a newly allocated Tcl_Obj
+ * containing the value of the array of tokens. The reference
+ * count of the returned object has been incremented. If an error
+ * occurs in evaluating the tokens then a NULL value is returned
+ * and an error message is left in interp's result.
+ *
+ * Side effects:
+ * A new object is allocated to hold the result.
+ *
+ *----------------------------------------------------------------------
+ *
+ * This uses a non-standard return convention; its use is now deprecated.
+ * It is a wrapper for the new function Tcl_EvalTokensStandard, and is not
+ * used in the core any longer. It is only kept for backward compatibility.
+ */
+
+Tcl_Obj *
+Tcl_EvalTokens(interp, tokenPtr, count)
+ Tcl_Interp *interp; /* Interpreter in which to lookup
+ * variables, execute nested commands,
+ * and report errors. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * to evaluate and concatenate. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
+{
+ int code;
+ Tcl_Obj *resPtr;
+
+ code = Tcl_EvalTokensStandard(interp, tokenPtr, count);
+ if (code == TCL_OK) {
+ resPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resPtr);
+ Tcl_ResetResult(interp);
+ return resPtr;
+ } else {
+ return NULL;
+ }
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalEx --
+ *
+ * This procedure evaluates a Tcl script without using the compiler
+ * or byte-code interpreter. It just parses the script, creates
+ * values for each word of each command, then calls EvalObjv
+ * to execute each command.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR. A result or error message is left in
+ * interp's result.
+ *
+ * Side effects:
+ * Depends on the script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_EvalEx(interp, script, numBytes, flags)
+ Tcl_Interp *interp; /* Interpreter in which to evaluate the
+ * script. Also used for error reporting. */
+ CONST char *script; /* First character of script to evaluate. */
+ int numBytes; /* Number of bytes in script. If < 0, the
+ * script consists of all bytes up to the
+ * first null character. */
+ int flags; /* Collection of OR-ed bits that control
+ * the evaluation of the script. Only
+ * TCL_EVAL_GLOBAL is currently
+ * supported. */
+{
+ Interp *iPtr = (Interp *) interp;
+ CONST char *p, *next;
+ Tcl_Parse parse;
+#define NUM_STATIC_OBJS 20
+ Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
+ Tcl_Token *tokenPtr;
+ int i, code, commandLength, bytesLeft, nested;
+ CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
+ * in case TCL_EVAL_GLOBAL was set. */
+ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
+
+ /* For nested scripts, this variable will be set to point to the first
+ * char after the end of the script - needed only to compare pointers,
+ * nothing will be read nor written there.
+ */
+
+ CONST char *onePast = NULL;
+
+ /*
+ * The variables below keep track of how much state has been
+ * allocated while evaluating the script, so that it can be freed
+ * properly if an error occurs.
+ */
+
+ int gotParse = 0, objectsUsed = 0;
+
+ if (numBytes < 0) {
+ numBytes = strlen(script);
+ }
+ Tcl_ResetResult(interp);
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
+
+ /*
+ * Each iteration through the following loop parses the next
+ * command from the script and then executes it.
+ */
+
+ objv = staticObjArray;
+ p = script;
+ bytesLeft = numBytes;
+ if (iPtr->evalFlags & TCL_BRACKET_TERM) {
+ nested = 1;
+ onePast = script + numBytes;
+ } else {
+ nested = 0;
+ }
+ iPtr->evalFlags = 0;
+ do {
+ if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
+ != TCL_OK) {
+ code = TCL_ERROR;
+ goto error;
+ }
+ gotParse = 1;
+
+ /*
+ * A nested script can only terminate in ']'. If the script is not
+ * nested, onePast is NULL and the second test is not performed.
+ */
+
+ next = parse.commandStart + parse.commandSize;
+ if ((next == onePast) && (onePast[-1] != ']')) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("missing close-bracket", -1));
+ code = TCL_ERROR;
+ goto error;
+ }
+
+ if (parse.numWords > 0) {
+ /*
+ * Generate an array of objects for the words of the command.
+ */
+
+ if (parse.numWords <= NUM_STATIC_OBJS) {
+ objv = staticObjArray;
+ } else {
+ objv = (Tcl_Obj **) ckalloc((unsigned)
+ (parse.numWords * sizeof (Tcl_Obj *)));
+ }
+ for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
+ objectsUsed < parse.numWords;
+ objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
+ tokenPtr->numComponents);
+ if (code == TCL_OK) {
+ objv[objectsUsed] = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(objv[objectsUsed]);
+ } else {
+ goto error;
+ }
+ }
+
+ /*
+ * Execute the command and free the objects for its words.
+ */
+
+ if (TclInterpReady(interp) == TCL_ERROR) {
+ code = TCL_ERROR;
+ } else {
+ iPtr->numLevels++;
+ code = TclEvalObjvInternal(interp, objectsUsed, objv, p,
+ parse.commandStart + parse.commandSize - p, 0);
iPtr->numLevels--;
- return result;
+ }
+ if (code != TCL_OK) {
+ if (iPtr->numLevels == 0) {
+ if (code == TCL_RETURN) {
+ code = TclUpdateReturnInfo(iPtr);
+ }
+ if ((code != TCL_OK) && (code != TCL_ERROR)
+ && !allowExceptions) {
+ ProcessUnexpectedResult(interp, code);
+ code = TCL_ERROR;
+ }
+ }
+ goto error;
+ }
+ for (i = 0; i < objectsUsed; i++) {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ objectsUsed = 0;
+ if (objv != staticObjArray) {
+ ckfree((char *) objv);
+ objv = staticObjArray;
}
}
+
+ /*
+ * Advance to the next command in the script.
+ */
+
+ bytesLeft -= next - p;
+ p = next;
+ Tcl_FreeParse(&parse);
+ gotParse = 0;
+ if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+ /*
+ * We get here in the special case where the TCL_BRACKET_TERM
+ * flag was set in the interpreter and we reached a close
+ * bracket in the script. Return immediately.
+ */
+
+ iPtr->termOffset = (p - 1) - script;
+ iPtr->varFramePtr = savedVarFramePtr;
+ return TCL_OK;
+ }
+ } while (bytesLeft > 0);
+ iPtr->termOffset = p - script;
+ iPtr->varFramePtr = savedVarFramePtr;
+ return TCL_OK;
+
+ error:
+ /*
+ * Generate various pieces of error information, such as the line
+ * number where the error occurred and information to add to the
+ * errorInfo variable. Then free resources that had been allocated
+ * to the command.
+ */
+
+ if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ commandLength = parse.commandSize;
+ if ((parse.commandStart + commandLength) != (script + numBytes)) {
+ /*
+ * The command where the error occurred didn't end at the end
+ * of the script (i.e. it ended at a terminator character such
+ * as ";". Reduce the length by one so that the error message
+ * doesn't include the terminator character.
+ */
+
+ commandLength -= 1;
+ }
+ Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
+ }
+
+ for (i = 0; i < objectsUsed; i++) {
+ Tcl_DecrRefCount(objv[i]);
}
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if (gotParse) {
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= next - p;
+ p = next;
+ Tcl_FreeParse(&parse);
+
+ if ((nested != 0) && (p > script)) {
+ CONST char *nextCmd = NULL; /* pointer to start of next command */
+
+ /*
+ * We get here in the special case where the TCL_BRACKET_TERM
+ * flag was set in the interpreter.
+ *
+ * At this point, we want to find the end of the script
+ * (either end of script or the closing ']').
+ */
+
+ while ((p[-1] != ']') && bytesLeft) {
+ if (Tcl_ParseCommand(NULL, p, bytesLeft, nested, &parse)
+ != TCL_OK) {
+ /*
+ * We were looking for the ']' to close the script.
+ * But if we find a syntax error, it is ok to quit
+ * early since in that case we no longer need to know
+ * where the ']' is (if there was one). We reset the
+ * pointer to the start of the command that after the
+ * one causing the return. -- hobbs
+ */
+
+ p = (nextCmd == NULL) ? parse.commandStart : nextCmd;
+ break;
+ }
+
+ if (nextCmd == NULL) {
+ nextCmd = parse.commandStart;
+ }
+
+ /*
+ * Advance to the next command in the script.
+ */
+
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= next - p;
+ p = next;
+ Tcl_FreeParse(&parse);
+ }
+ iPtr->termOffset = (p - 1) - script;
+ } else {
+ iPtr->termOffset = p - script;
+ }
+ }
+ if (objv != staticObjArray) {
+ ckfree((char *) objv);
+ }
+ iPtr->varFramePtr = savedVarFramePtr;
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Eval --
+ *
+ * Execute a Tcl command in a string. This procedure executes the
+ * script directly, rather than compiling it to bytecodes. Before
+ * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
+ * the main procedure used for executing Tcl commands, but nowadays
+ * it isn't used much.
+ *
+ * Results:
+ * The return value is one of the return codes defined in tcl.h
+ * (such as TCL_OK), and interp's result contains a value
+ * to supplement the return code. The value of the result
+ * will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
+ * you must copy it or lose it!
+ *
+ * Side effects:
+ * Can be almost arbitrary, depending on the commands in the script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Eval(interp, string)
+ Tcl_Interp *interp; /* Token for command interpreter (returned
+ * by previous call to Tcl_CreateInterp). */
+ CONST char *string; /* Pointer to TCL command to execute. */
+{
+ int code = Tcl_EvalEx(interp, string, -1, 0);
/*
- * Extract then reset the compilation flags in the interpreter.
- * Resetting the flags must be done after any compilation.
+ * For backwards compatibility with old C code that predates the
+ * object system in Tcl 8.0, we have to mirror the object result
+ * back into the string result (some callers may expect it there).
*/
- evalFlags = iPtr->evalFlags;
- iPtr->evalFlags = 0;
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
+ TCL_VOLATILE);
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalObj, Tcl_GlobalEvalObj --
+ *
+ * These functions are deprecated but we keep them around for backwards
+ * compatibility reasons.
+ *
+ * Results:
+ * See the functions they call.
+ *
+ * Side effects:
+ * See the functions they call.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_EvalObj
+int
+Tcl_EvalObj(interp, objPtr)
+ Tcl_Interp * interp;
+ Tcl_Obj * objPtr;
+{
+ return Tcl_EvalObjEx(interp, objPtr, 0);
+}
+
+#undef Tcl_GlobalEvalObj
+int
+Tcl_GlobalEvalObj(interp, objPtr)
+ Tcl_Interp * interp;
+ Tcl_Obj * objPtr;
+{
+ return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalObjEx --
+ *
+ * Execute Tcl commands stored in a Tcl object. These commands are
+ * compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
+ * is specified.
+ *
+ * Results:
+ * The return value is one of the return codes defined in tcl.h
+ * (such as TCL_OK), and the interpreter's result contains a value
+ * to supplement the return code.
+ *
+ * Side effects:
+ * The object is converted, if necessary, to a ByteCode object that
+ * holds the bytecode instructions for the commands. Executing the
+ * commands will almost certainly have side effects that depend
+ * on those commands.
+ *
+ * Just as in Tcl_Eval, interp->termOffset is set to the offset of the
+ * last character executed in the objPtr's string.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_EvalObjEx(interp, objPtr, flags)
+ Tcl_Interp *interp; /* Token for command interpreter
+ * (returned by a previous call to
+ * Tcl_CreateInterp). */
+ register Tcl_Obj *objPtr; /* Pointer to object containing
+ * commands to execute. */
+ int flags; /* Collection of OR-ed bits that
+ * control the evaluation of the
+ * script. Supported values are
+ * TCL_EVAL_GLOBAL and
+ * TCL_EVAL_DIRECT. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ char *script;
+ int numSrcBytes;
+ int result;
+ CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
+ * in case TCL_EVAL_GLOBAL was set. */
+ int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
- /*
- * Execute the commands. If the code was compiled from an empty string,
- * don't bother executing the code.
- */
+ Tcl_IncrRefCount(objPtr);
- numSrcBytes = codePtr->numSrcBytes;
- if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
+ if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
/*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
+ * We're not supposed to use the compiler or byte-code interpreter.
+ * Let Tcl_EvalEx evaluate the command directly (and probably
+ * more slowly).
+ *
+ * Pure List Optimization (no string representation). In this
+ * case, we can safely use Tcl_EvalObjv instead and get an
+ * appreciable improvement in execution speed. This is because it
+ * allows us to avoid a setFromAny step that would just pack
+ * everything into a string and back out again.
+ *
+ * USE_EVAL_DIRECT is a special flag used for testing purpose only
+ * (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
*/
-
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
+ if (!(iPtr->flags & USE_EVAL_DIRECT) &&
+ (objPtr->typePtr == &tclListType) && /* is a list... */
+ (objPtr->bytes == NULL) /* ...without a string rep */) {
+ register List *listRepPtr =
+ (List *) objPtr->internalRep.twoPtrValue.ptr1;
+ result = Tcl_EvalObjv(interp, listRepPtr->elemCount,
+ listRepPtr->elements, flags);
+ } else {
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
}
} else {
- result = TCL_OK;
- }
-
- /*
- * If no commands at all were executed, check for asynchronous
- * handlers so that they at least get one change to execute.
- * This is needed to handle event loops written in Tcl with
- * empty bodies.
- */
-
- if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
- result = Tcl_AsyncInvoke(interp, result);
- }
-
- /*
- * Update the interpreter's evaluation level count. If we are again at
- * the top level, process any unusual return code returned by the
- * evaluated code.
- */
+ /*
+ * Let the compiler/engine subsystem do the evaluation.
+ */
- if (iPtr->numLevels == 1) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo(iPtr);
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
}
- if ((result != TCL_OK) && (result != TCL_ERROR)
- && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
- ProcessUnexpectedResult(interp, result);
- result = TCL_ERROR;
- }
- }
- /*
- * If an error occurred, record information about what was being
- * executed when the error occurred.
- */
+ result = TclCompEvalObj(interp, objPtr);
- if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- RecordTracebackInfo(interp, objPtr, numSrcBytes);
- }
+ /*
+ * If we are again at the top level, process any unusual
+ * return code returned by the evaluated code.
+ */
+
+ if (iPtr->numLevels == 0) {
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
+ }
+ if ((result != TCL_OK) && (result != TCL_ERROR)
+ && !allowExceptions) {
+ ProcessUnexpectedResult(interp, result);
+ result = TCL_ERROR;
- /*
- * Set the interpreter's termOffset member to the offset of the
- * character just after the last one executed. We approximate the offset
- * of the last character executed by using the number of characters
- * compiled.
- */
+ /*
+ * If an error was created here, record information about
+ * what was being executed when the error occurred.
+ */
- iPtr->termOffset = numSrcBytes;
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ }
+ }
+ }
+ iPtr->evalFlags = 0;
+ iPtr->varFramePtr = savedVarFramePtr;
+ }
- done:
TclDecrRefCount(objPtr);
- iPtr->varFramePtr = savedVarFramePtr;
- iPtr->numLevels--;
return result;
}
\f
}
\f
/*
- *----------------------------------------------------------------------
- *
- * RecordTracebackInfo --
- *
- * Procedure called by Tcl_EvalObj to record information about what was
- * being executed when the error occurred.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Appends information about the script being evaluated to the
- * interpreter's "errorInfo" variable.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RecordTracebackInfo(interp, objPtr, numSrcBytes)
- Tcl_Interp *interp; /* The interpreter in which the error
- * occurred. */
- Tcl_Obj *objPtr; /* Points to object containing script whose
- * evaluation resulted in an error. */
- int numSrcBytes; /* Number of bytes compiled in script. */
-{
- Interp *iPtr = (Interp *) interp;
- char buf[200];
- char *ellipsis, *bytes;
- int length;
-
- /*
- * Decide how much of the command to print in the error message
- * (up to a certain number of bytes).
- */
-
- bytes = Tcl_GetStringFromObj(objPtr, &length);
- length = TclMin(numSrcBytes, length);
-
- ellipsis = "";
- if (length > 150) {
- length = 150;
- ellipsis = " ...";
- }
-
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buf, "\n while executing\n\"%.*s%s\"",
- length, bytes, ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- length, bytes, ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
-}
-\f
-/*
*---------------------------------------------------------------------------
*
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
Tcl_ExprLong(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
- char *string; /* Expression to evaluate. */
+ CONST char *string; /* Expression to evaluate. */
long *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
Tcl_ExprDouble(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
- char *string; /* Expression to evaluate. */
+ CONST char *string; /* Expression to evaluate. */
double *ptr; /* Where to store result. */
{
register Tcl_Obj *exprPtr;
Tcl_ExprBoolean(interp, string, ptr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
- char *string; /* Expression to evaluate. */
+ CONST char *string; /* Expression to evaluate. */
int *ptr; /* Where to store 0/1 result. */
{
register Tcl_Obj *exprPtr;
TclInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
- register char **argv; /* The arg strings; argv[0] is the name of
+ register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
TclGlobalInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
- register char **argv; /* The arg strings; argv[0] is the name of
+ register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
Tcl_ExprString(interp, string)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
- char *string; /* Expression to evaluate. */
+ CONST char *string; /* Expression to evaluate. */
{
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
}
\f
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
- * Tcl_ExprObj --
+ * Tcl_CreateObjTrace --
*
- * Evaluate an expression in a Tcl_Obj.
+ * Arrange for a procedure to be called to trace command execution.
*
* Results:
- * A standard Tcl object result. If the result is other than TCL_OK,
- * then the interpreter's result contains an error message. If the
- * result is TCL_OK, then a pointer to the expression's result value
- * object is stored in resultPtrPtr. In that case, the object's ref
- * count is incremented to reflect the reference returned to the
- * caller; the caller is then responsible for the resulting object
- * and must, for example, decrement the ref count when it is finished
- * with the object.
+ * The return value is a token for the trace, which may be passed
+ * to Tcl_DeleteTrace to eliminate the trace.
*
* Side effects:
- * Any side effects caused by subcommands in the expression, if any.
- * The interpreter result is not modified unless there is an error.
+ * From now on, proc will be called just before a command procedure
+ * is called to execute a Tcl command. Calls to proc will have the
+ * following form:
*
- *--------------------------------------------------------------
+ * void proc( ClientData clientData,
+ * Tcl_Interp* interp,
+ * int level,
+ * CONST char* command,
+ * Tcl_Command commandInfo,
+ * int objc,
+ * Tcl_Obj *CONST objv[] );
+ *
+ * The 'clientData' and 'interp' arguments to 'proc' will be the
+ * same as the arguments to Tcl_CreateObjTrace. The 'level'
+ * argument gives the nesting depth of command interpretation within
+ * the interpreter. The 'command' argument is the ASCII text of
+ * the command being evaluated -- before any substitutions are
+ * performed. The 'commandInfo' argument gives a handle to the
+ * command procedure that will be evaluated. The 'objc' and 'objv'
+ * parameters give the parameter vector that will be passed to the
+ * command procedure. proc does not return a value.
+ *
+ * It is permissible for 'proc' to call Tcl_SetCommandTokenInfo
+ * to change the command procedure or client data for the command
+ * being evaluated, and these changes will take effect with the
+ * current evaluation.
+ *
+ * The 'level' argument specifies the maximum nesting level of calls
+ * to be traced. If the execution depth of the interpreter exceeds
+ * 'level', the trace callback is not executed.
+ *
+ * The 'flags' argument is either zero or the value,
+ * TCL_ALLOW_INLINE_COMPILATION. If the TCL_ALLOW_INLINE_COMPILATION
+ * flag is not present, the bytecode compiler will not generate inline
+ * code for Tcl's built-in commands. This behavior will have a significant
+ * impact on performance, but will ensure that all command evaluations are
+ * traced. If the TCL_ALLOW_INLINE_COMPILATION flag is present, the
+ * bytecode compiler will have its normal behavior of compiling in-line
+ * code for some of Tcl's built-in commands. In this case, the tracing
+ * will be imprecise -- in-line code will not be traced -- but run-time
+ * performance will be improved. The latter behavior is desired for
+ * many applications such as profiling of run time.
+ *
+ * When the trace is deleted, the 'delProc' procedure will be invoked,
+ * passing it the original client data.
+ *
+ *----------------------------------------------------------------------
*/
-int
-Tcl_ExprObj(interp, objPtr, resultPtrPtr)
- Tcl_Interp *interp; /* Context in which to evaluate the
- * expression. */
- register Tcl_Obj *objPtr; /* Points to Tcl object containing
- * expression to evaluate. */
- Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
- * result is stored if no errors occur. */
+Tcl_Trace
+Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc )
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int level; /* Maximum nesting level */
+ int flags; /* Flags, see above */
+ Tcl_CmdObjTraceProc* proc; /* Trace callback */
+ ClientData clientData; /* Client data for the callback */
+ Tcl_CmdObjTraceDeleteProc* delProc;
+ /* Procedure to call when trace is deleted */
{
- Interp *iPtr = (Interp *) interp;
- CompileEnv compEnv; /* Compilation environment structure
- * allocated in frame. */
- LiteralTable *localTablePtr = &(compEnv.localLitTable);
- register ByteCode *codePtr = NULL;
- /* Tcl Internal type of bytecode.
- * Initialized to avoid compiler warning. */
- AuxData *auxDataPtr;
- LiteralEntry *entryPtr;
- Tcl_Obj *saveObjPtr;
- char *string;
- int length, i, result;
-
- /*
- * First handle some common expressions specially.
- */
-
- string = Tcl_GetStringFromObj(objPtr, &length);
- if (length == 1) {
- if (*string == '0') {
- *resultPtrPtr = Tcl_NewLongObj(0);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- } else if (*string == '1') {
- *resultPtrPtr = Tcl_NewLongObj(1);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- }
- } else if ((length == 2) && (*string == '!')) {
- if (*(string+1) == '0') {
- *resultPtrPtr = Tcl_NewLongObj(1);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- } else if (*(string+1) == '1') {
- *resultPtrPtr = Tcl_NewLongObj(0);
- Tcl_IncrRefCount(*resultPtrPtr);
- return TCL_OK;
- }
- }
+ register Trace *tracePtr;
+ register Interp *iPtr = (Interp *) interp;
- /*
- * Get the ByteCode from the object. If it exists, make sure it hasn't
- * been invalidated by, e.g., someone redefining a command with a
- * compile procedure (this might make the compiled code wrong). If
- * necessary, convert the object to be a ByteCode object and compile it.
- * Also, if the code was compiled in/for a different interpreter, we
- * recompile it.
- *
- * Precompiled expressions, however, are immutable and therefore
- * they are not recompiled, even if the epoch has changed.
- *
- */
+ /* Test if this trace allows inline compilation of commands */
- if (objPtr->typePtr == &tclByteCodeType) {
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if (((Interp *) *codePtr->interpHandle != iPtr)
- || (codePtr->compileEpoch != iPtr->compileEpoch)) {
- if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if ((Interp *) *codePtr->interpHandle != iPtr) {
- panic("Tcl_ExprObj: compiled expression jumped interps");
- }
- codePtr->compileEpoch = iPtr->compileEpoch;
- } else {
- (*tclByteCodeType.freeIntRepProc)(objPtr);
- objPtr->typePtr = (Tcl_ObjType *) NULL;
- }
- }
- }
- if (objPtr->typePtr != &tclByteCodeType) {
- TclInitCompileEnv(interp, &compEnv, string, length);
- result = TclCompileExpr(interp, string, length, &compEnv);
+ if ( ! ( flags & TCL_ALLOW_INLINE_COMPILATION ) ) {
- /*
- * Free the compilation environment's literal table bucket array if
- * it was dynamically allocated.
- */
+ if ( iPtr->tracesForbiddingInline == 0 ) {
- if (localTablePtr->buckets != localTablePtr->staticBuckets) {
- ckfree((char *) localTablePtr->buckets);
- }
-
- if (result != TCL_OK) {
/*
- * Compilation errors. Free storage allocated for compilation.
+ * When the first trace forbidding inline compilation is
+ * created, invalidate existing compiled code for this
+ * interpreter and arrange (by setting the
+ * DONT_COMPILE_CMDS_INLINE flag) that when compiling new
+ * code, no commands will be compiled inline (i.e., into
+ * an inline sequence of instructions). We do this because
+ * commands that were compiled inline will never result in
+ * a command trace being called.
*/
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyLocalLiteralTable(&compEnv);
-#endif /*TCL_COMPILE_DEBUG*/
- entryPtr = compEnv.literalArrayPtr;
- for (i = 0; i < compEnv.literalArrayNext; i++) {
- TclReleaseLiteral(interp, entryPtr->objPtr);
- entryPtr++;
- }
-#ifdef TCL_COMPILE_DEBUG
- TclVerifyGlobalLiteralTable(iPtr);
-#endif /*TCL_COMPILE_DEBUG*/
-
- auxDataPtr = compEnv.auxDataArrayPtr;
- for (i = 0; i < compEnv.auxDataArrayNext; i++) {
- if (auxDataPtr->type->freeProc != NULL) {
- auxDataPtr->type->freeProc(auxDataPtr->clientData);
- }
- auxDataPtr++;
- }
- TclFreeCompileEnv(&compEnv);
- return result;
- }
-
- /*
- * Successful compilation. If the expression yielded no
- * instructions, push an zero object as the expression's result.
- */
-
- if (compEnv.codeNext == compEnv.codeStart) {
- TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
- &compEnv);
- }
-
- /*
- * Add a "done" instruction as the last instruction and change the
- * object into a ByteCode object. Ownership of the literal objects
- * and aux data items is given to the ByteCode object.
- */
-
- compEnv.numSrcBytes = iPtr->termOffset;
- TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- TclFreeCompileEnv(&compEnv);
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
-#ifdef TCL_COMPILE_DEBUG
- if (tclTraceCompile == 2) {
- TclPrintByteCodeObj(interp, objPtr);
+ iPtr->compileEpoch++;
+ iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
-#endif /* TCL_COMPILE_DEBUG */
+ ++ iPtr->tracesForbiddingInline;
}
-
- /*
- * Execute the expression after first saving the interpreter's result.
- */
- saveObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(saveObjPtr);
- Tcl_ResetResult(interp);
+ tracePtr = (Trace *) ckalloc(sizeof(Trace));
+ tracePtr->level = level;
+ tracePtr->proc = proc;
+ tracePtr->clientData = clientData;
+ tracePtr->delProc = delProc;
+ tracePtr->nextPtr = iPtr->tracePtr;
+ tracePtr->flags = flags;
+ iPtr->tracePtr = tracePtr;
- /*
- * Increment the code's ref count while it is being executed. If
- * afterwards no references to it remain, free the code.
- */
-
- codePtr->refCount++;
- result = TclExecuteByteCode(interp, codePtr);
- codePtr->refCount--;
- if (codePtr->refCount <= 0) {
- TclCleanupByteCode(codePtr);
- objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
- }
-
- /*
- * If the expression evaluated successfully, store a pointer to its
- * value object in resultPtrPtr then restore the old interpreter result.
- * We increment the object's ref count to reflect the reference that we
- * are returning to the caller. We also decrement the ref count of the
- * interpreter's result object after calling Tcl_SetResult since we
- * next store into that field directly.
- */
-
- if (result == TCL_OK) {
- *resultPtrPtr = iPtr->objResultPtr;
- Tcl_IncrRefCount(iPtr->objResultPtr);
-
- Tcl_SetObjResult(interp, saveObjPtr);
- }
- Tcl_DecrRefCount(saveObjPtr);
- return result;
+ return (Tcl_Trace) tracePtr;
}
\f
/*
* command. */
ClientData clientData; /* Arbitrary value word to pass to proc. */
{
- register Trace *tracePtr;
- register Interp *iPtr = (Interp *) interp;
+ StringTraceData* data;
+ data = (StringTraceData*) ckalloc( sizeof( *data ));
+ data->clientData = clientData;
+ data->proc = proc;
+ return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
+ (ClientData) data, StringTraceDeleteProc );
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringTraceProc --
+ *
+ * Invoke a string-based trace procedure from an object-based
+ * callback.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Whatever the string-based trace procedure does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+StringTraceProc( clientData, interp, level, command, commandInfo, objc, objv )
+ ClientData clientData;
+ Tcl_Interp* interp;
+ int level;
+ CONST char* command;
+ Tcl_Command commandInfo;
+ int objc;
+ Tcl_Obj *CONST *objv;
+{
+ StringTraceData* data = (StringTraceData*) clientData;
+ Command* cmdPtr = (Command*) commandInfo;
+
+ CONST char** argv; /* Args to pass to string trace proc */
+
+ int i;
/*
- * Invalidate existing compiled code for this interpreter and arrange
- * (by setting the DONT_COMPILE_CMDS_INLINE flag) that when compiling
- * new code, no commands will be compiled inline (i.e., into an inline
- * sequence of instructions). We do this because commands that were
- * compiled inline will never result in a command trace being called.
+ * This is a bit messy because we have to emulate the old trace
+ * interface, which uses strings for everything.
*/
+
+ argv = (CONST char **) ckalloc((unsigned) ( (objc + 1)
+ * sizeof(CONST char *) ));
+ for (i = 0; i < objc; i++) {
+ argv[i] = Tcl_GetString(objv[i]);
+ }
+ argv[objc] = 0;
- iPtr->compileEpoch++;
- iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
+ /*
+ * Invoke the command procedure. Note that we cast away const-ness
+ * on two parameters for compatibility with legacy code; the code
+ * MUST NOT modify either command or argv.
+ */
+
+ ( data->proc )( data->clientData, interp, level,
+ (char*) command, cmdPtr->proc, cmdPtr->clientData,
+ objc, argv );
+ ckfree( (char*) argv );
- tracePtr = (Trace *) ckalloc(sizeof(Trace));
- tracePtr->level = level;
- tracePtr->proc = proc;
- tracePtr->clientData = clientData;
- tracePtr->nextPtr = iPtr->tracePtr;
- iPtr->tracePtr = tracePtr;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * StringTraceDeleteProc --
+ *
+ * Clean up memory when a string-based trace is deleted.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocated memory is returned to the system.
+ *
+ *----------------------------------------------------------------------
+ */
- return (Tcl_Trace) tracePtr;
+static void
+StringTraceDeleteProc( clientData )
+ ClientData clientData;
+{
+ ckfree( (char*) clientData );
}
\f
/*
Tcl_Trace trace; /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
- register Interp *iPtr = (Interp *) interp;
- register Trace *tracePtr = (Trace *) trace;
- register Trace *tracePtr2;
+ Interp *iPtr = (Interp *) interp;
+ Trace *tracePtr = (Trace *) trace;
+ register Trace **tracePtr2 = &( iPtr->tracePtr );
- if (iPtr->tracePtr == tracePtr) {
- iPtr->tracePtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
- } else {
- for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL;
- tracePtr2 = tracePtr2->nextPtr) {
- if (tracePtr2->nextPtr == tracePtr) {
- tracePtr2->nextPtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
- break;
- }
+ /*
+ * Locate the trace entry in the interpreter's trace list,
+ * and remove it from the list.
+ */
+
+ while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) {
+ tracePtr2 = &((*tracePtr2)->nextPtr);
+ }
+ if ( *tracePtr2 == NULL ) {
+ return;
+ }
+ (*tracePtr2) = (*tracePtr2)->nextPtr;
+
+ /*
+ * If the trace forbids bytecode compilation, change the interpreter's
+ * state. If bytecode compilation is now permitted, flag the fact and
+ * advance the compilation epoch so that procs will be recompiled to
+ * take advantage of it.
+ */
+
+ if ( ! (tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION ) ) {
+ -- iPtr->tracesForbiddingInline;
+ if ( iPtr->tracesForbiddingInline == 0 ) {
+ iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
+ ++ iPtr->compileEpoch;
}
}
- if (iPtr->tracePtr == NULL) {
- /*
- * When compiling new code, allow commands to be compiled inline.
- */
+ /*
+ * Execute any delete callback.
+ */
- iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE;
+ if ( tracePtr->delProc != NULL ) {
+ ( tracePtr->delProc )( tracePtr->clientData );
}
+
+ /* Delete the trace object */
+
+ Tcl_EventuallyFree( (char*) tracePtr, TCL_DYNAMIC);
}
\f
/*
iPtr->flags |= ERR_IN_PROGRESS;
if (iPtr->result[0] == 0) {
- (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr,
- TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
+ iPtr->objResultPtr, TCL_GLOBAL_ONLY);
} else { /* use the string result */
- Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
- TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
+ Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY);
}
/*
*/
if (!(iPtr->flags & ERROR_CODE_SET)) {
- (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE",
- TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
+ Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY);
}
}
if (length != 0) {
messagePtr = Tcl_NewStringObj(message, length);
Tcl_IncrRefCount(messagePtr);
- Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr,
- (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
+ Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
+ messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
}
}
int
Tcl_GlobalEval(interp, command)
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
- char *command; /* Command to evaluate. */
+ CONST char *command; /* Command to evaluate. */
{
register Interp *iPtr = (Interp *) interp;
int result;
*----------------------------------------------------------------------
*/
-void Tcl_GetVersion(majorV, minorV, patchLevelV, type)
+void
+Tcl_GetVersion(majorV, minorV, patchLevelV, type)
int *majorV;
int *minorV;
int *patchLevelV;
}
}
-
* RCS: @(#) $Id$
*/
-#include <math.h>
#include "tclInt.h"
#include "tclPort.h"
+#include <math.h>
/*
* The following constants are used by GetFormatSpec to indicate various
#define BINARY_NOCOUNT -2 /* No count was specified in format. */
/*
+ * The following defines the maximum number of different (integer)
+ * numbers placed in the object cache by 'binary scan' before it bails
+ * out and switches back to Plan A (creating a new object for each
+ * value.) Theoretically, it would be possible to keep the cache
+ * about for the values that are already in it, but that makes the
+ * code slower in practise when overflow happens, and makes little
+ * odds the rest of the time (as measured on my machine.) It is also
+ * slower (on the sample I tried at least) to grow the cache to hold
+ * all items we might want to put in it; presumably the extra cost of
+ * managing the memory for the enlarged table outweighs the benefit
+ * from allocating fewer objects. This is probably because as the
+ * number of objects increases, the likelihood of reuse of any
+ * particular one drops, and there is very little gain from larger
+ * maximum cache sizes (the value below is chosen to allow caching to
+ * work in full with conversion of bytes.) - DKF
+ */
+
+#define BINARY_SCAN_MAX_CACHE 260
+
+/*
* Prototypes for local procedures defined in this file:
*/
static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
char *cmdPtr, int *countPtr));
-static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type));
+static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer,
+ int type, Tcl_HashTable **numberCachePtr));
static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
- unsigned char *bytes; /* The array of bytes used to initialize
+ CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
- unsigned char *bytes; /* The array of bytes used to initialize
+ CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
* TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj
* above except that it calls Tcl_DbCkalloc directly with the file name
* and line number from its caller. This simplifies debugging since then
- * the checkmem command will report the correct file name and line number
- * when reporting objects that haven't been freed.
+ * the [memory active] command will report the correct file name and line
+ * number when reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewByteArrayObj.
Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
- unsigned char *bytes; /* The array of bytes used to initialize
+ CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
Tcl_Obj *
Tcl_DbNewByteArrayObj(bytes, length, file, line)
- unsigned char *bytes; /* The array of bytes used to initialize
+ CONST unsigned char *bytes; /* The array of bytes used to initialize
* the new object. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
void
Tcl_SetByteArrayObj(objPtr, bytes, length)
Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */
- unsigned char *bytes; /* The array of bytes to use as the new
+ CONST unsigned char *bytes; /* The array of bytes to use as the new
* value. */
int length; /* Length of the array of bytes, which must
* be >= 0. */
* cursor has visited.*/
char *errorString, *errorValue, *str;
int offset, size, length, index;
- static char *options[] = {
+ static CONST char *options[] = {
"format", "scan", NULL
};
enum options {
size = 4;
goto doNumbers;
}
+ case 'w':
+ case 'W': {
+ size = 8;
+ goto doNumbers;
+ }
case 'f': {
size = sizeof(float);
goto doNumbers;
case 'S':
case 'i':
case 'I':
+ case 'w':
+ case 'W':
case 'd':
case 'f': {
int listc, i;
case BINARY_SCAN: {
int i;
Tcl_Obj *valuePtr, *elementPtr;
+ Tcl_HashTable numberCacheHash;
+ Tcl_HashTable *numberCachePtr;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"value formatString ?varName varName ...?");
return TCL_ERROR;
}
+ numberCachePtr = &numberCacheHash;
+ Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
format = Tcl_GetString(objv[3]);
cursor = buffer;
unsigned char *src;
if (arg >= objc) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
goto badIndex;
}
if (count == BINARY_ALL) {
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
char *dest;
if (arg >= objc) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
goto badIndex;
}
if (count == BINARY_ALL) {
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
static char hexdigit[] = "0123456789abcdef";
if (arg >= objc) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
goto badIndex;
}
if (count == BINARY_ALL) {
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
size = 4;
goto scanNumber;
}
+ case 'w':
+ case 'W': {
+ size = 8;
+ goto scanNumber;
+ }
case 'f': {
size = sizeof(float);
goto scanNumber;
scanNumber:
if (arg >= objc) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
if ((length - offset) < size) {
goto done;
}
- valuePtr = ScanNumber(buffer+offset, cmd);
+ valuePtr = ScanNumber(buffer+offset, cmd,
+ &numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
valuePtr = Tcl_NewObj();
src = buffer+offset;
for (i = 0; i < count; i++) {
- elementPtr = ScanNumber(src, cmd);
+ elementPtr = ScanNumber(src, cmd,
+ &numberCachePtr);
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr,
elementPtr);
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
}
case '@': {
if (count == BINARY_NOCOUNT) {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
goto badCount;
}
if ((count == BINARY_ALL) || (count > length)) {
break;
}
default: {
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
errorString = str;
goto badfield;
}
done:
Tcl_ResetResult(interp);
Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
+ if (numberCachePtr != NULL) {
+ Tcl_DeleteHashTable(numberCachePtr);
+ }
break;
}
}
Tcl_Obj *src; /* Number to format. */
unsigned char **cursorPtr; /* Pointer to index into destination buffer. */
{
- int value;
+ long value;
double dvalue;
+ Tcl_WideInt wvalue;
- if ((type == 'd') || (type == 'f')) {
+ switch (type) {
+ case 'd':
+ case 'f':
/*
* For floating point types, we need to copy the data using
* memcpy to avoid alignment issues.
memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
*cursorPtr += sizeof(float);
}
- } else {
- if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_OK;
+
+ /*
+ * Next cases separate from other integer cases because we
+ * need a different API to get a wide.
+ */
+ case 'w':
+ case 'W':
+ if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (type == 'w') {
+ *(*cursorPtr)++ = (unsigned char) wvalue;
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
+ } else {
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
+ *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
+ *(*cursorPtr)++ = (unsigned char) wvalue;
+ }
+ return TCL_OK;
+ default:
+ if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
if (type == 'c') {
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
}
+ return TCL_OK;
}
- return TCL_OK;
}
\f
/*
* This object has a ref count of zero.
*
* Side effects:
- * None.
+ * Might reuse an object in the number cache, place a new object
+ * in the cache, or delete the cache and set the reference to
+ * it (itself passed in by reference) to NULL.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
-ScanNumber(buffer, type)
+ScanNumber(buffer, type, numberCachePtrPtr)
unsigned char *buffer; /* Buffer to scan number from. */
int type; /* Format character from "binary scan" */
+ Tcl_HashTable **numberCachePtrPtr;
+ /* Place to look for cache of scanned
+ * value objects, or NULL if too many
+ * different numbers have been scanned. */
{
long value;
+ Tcl_WideInt wvalue;
/*
* We cannot rely on the compiler to properly sign extend integer values
*/
switch (type) {
- case 'c': {
+ case 'c':
/*
* Characters need special handling. We want to produce a
* signed result, but on some platforms (such as AIX) chars
if (value & 0x80) {
value |= -0x100;
}
- return Tcl_NewLongObj((long)value);
- }
- case 's': {
+ goto returnNumericObject;
+
+ case 's':
value = (long) (buffer[0] + (buffer[1] << 8));
goto shortValue;
- }
- case 'S': {
+ case 'S':
value = (long) (buffer[1] + (buffer[0] << 8));
shortValue:
if (value & 0x8000) {
value |= -0x10000;
}
- return Tcl_NewLongObj(value);
- }
- case 'i': {
+ goto returnNumericObject;
+
+ case 'i':
value = (long) (buffer[0]
+ (buffer[1] << 8)
+ (buffer[2] << 16)
+ (buffer[3] << 24));
goto intValue;
- }
- case 'I': {
+ case 'I':
value = (long) (buffer[3]
+ (buffer[2] << 8)
+ (buffer[1] << 16)
value -= (((unsigned int)1)<<31);
value -= (((unsigned int)1)<<31);
}
- return Tcl_NewLongObj(value);
- }
+ returnNumericObject:
+ if (*numberCachePtrPtr == NULL) {
+ return Tcl_NewLongObj(value);
+ } else {
+ register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
+ register Tcl_HashEntry *hPtr;
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
+ if (!isNew) {
+ return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+ }
+ if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {
+ /*
+ * We've overflowed the cache! Someone's parsing
+ * a LOT of varied binary data in a single call!
+ * Bail out by switching back to the old behaviour
+ * for the rest of the scan.
+ *
+ * Note that anyone just using the 'c' conversion
+ * (for bytes) cannot trigger this.
+ */
+ Tcl_DeleteHashTable(tablePtr);
+ *numberCachePtrPtr = NULL;
+ return Tcl_NewLongObj(value);
+ } else {
+ register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
+ /* Don't need to fiddle with refcount... */
+ Tcl_SetHashValue(hPtr, (ClientData) objPtr);
+ return objPtr;
+ }
+ }
+ case 'w':
+ value = (long) (buffer[4]
+ | (buffer[5] << 8)
+ | (buffer[6] << 16)
+ | (buffer[7] << 24));
+ wvalue = ((Tcl_WideInt) value) << 32 | (buffer[0]
+ | (buffer[1] << 8)
+ | (buffer[2] << 16)
+ | (buffer[3] << 24));
+ return Tcl_NewWideIntObj(wvalue);
+ case 'W':
+ value = (long) (buffer[3]
+ | (buffer[2] << 8)
+ | (buffer[1] << 16)
+ | (buffer[0] << 24));
+ wvalue = ((Tcl_WideInt) value) << 32 | (buffer[7]
+ | (buffer[6] << 8)
+ | (buffer[5] << 16)
+ | (buffer[4] << 24));
+ return Tcl_NewWideIntObj(wvalue);
case 'f': {
float fvalue;
memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
struct mem_header *blink;
MemTag *tagPtr; /* Tag from "memory tag" command; may be
* NULL. */
- char *file;
+ CONST char *file;
long length;
int line;
unsigned char low_guard[LOW_GUARD_SIZE];
char *tclMemDumpFileName = NULL;
+static char *onExitMemDumpFileName = NULL;
static char dumpFile[100]; /* Records where to dump memory allocation
* information. */
*/
static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char *argv[]));
+ Tcl_Interp *interp, int argc, CONST char *argv[]));
static int MemoryCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static void ValidateMemory _ANSI_ARGS_((
- struct mem_header *memHeaderP, char *file,
+ struct mem_header *memHeaderP, CONST char *file,
int line, int nukeGuards));
\f
/*
static void
ValidateMemory(memHeaderP, file, line, nukeGuards)
struct mem_header *memHeaderP; /* Memory chunk to validate */
- char *file; /* File containing the call to
+ CONST char *file; /* File containing the call to
* Tcl_ValidateAllMemory */
int line; /* Line number of call to
* Tcl_ValidateAllMemory */
*/
void
Tcl_ValidateAllMemory (file, line)
- char *file; /* File from which Tcl_ValidateAllMemory was called */
- int line; /* Line number of call to Tcl_ValidateAllMemory */
+ CONST char *file; /* File from which Tcl_ValidateAllMemory was called */
+ int line; /* Line number of call to Tcl_ValidateAllMemory */
{
struct mem_header *memScanP;
* information will be written to stderr.
*
* Results:
- * Return TCL_ERROR if an error accessing the file occures, `errno'
+ * Return TCL_ERROR if an error accessing the file occurs, `errno'
* will have the file error number left in it.
*----------------------------------------------------------------------
*/
int
Tcl_DumpActiveMemory (fileName)
- char *fileName; /* Name of the file to write info to */
+ CONST char *fileName; /* Name of the file to write info to */
{
FILE *fileP;
struct mem_header *memScanP;
char *
Tcl_DbCkalloc(size, file, line)
unsigned int size;
- char *file;
+ CONST char *file;
int line;
{
struct mem_header *result;
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo(stderr);
- panic("unable to alloc %d bytes, %s line %d", size, file, line);
+ panic("unable to alloc %ud bytes, %s line %d", size, file, line);
}
/*
}
if (alloc_tracing)
- fprintf(stderr,"ckalloc %lx %d %s %d\n",
+ fprintf(stderr,"ckalloc %lx %ud %s %d\n",
(long unsigned int) result->body, size, file, line);
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
return result->body;
}
+
+char *
+Tcl_AttemptDbCkalloc(size, file, line)
+ unsigned int size;
+ CONST char *file;
+ int line;
+{
+ struct mem_header *result;
+
+ if (validate_memory)
+ Tcl_ValidateAllMemory (file, line);
+
+ result = (struct mem_header *) TclpAlloc((unsigned)size +
+ sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ if (result == NULL) {
+ fflush(stdout);
+ TclDumpMemoryInfo(stderr);
+ return NULL;
+ }
+
+ /*
+ * Fill in guard zones and size. Also initialize the contents of
+ * the block with bogus bytes to detect uses of initialized data.
+ * Link into allocated list.
+ */
+ if (init_malloced_bodies) {
+ memset ((VOID *) result, GUARD_VALUE,
+ size + sizeof(struct mem_header) + HIGH_GUARD_SIZE);
+ } else {
+ memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
+ memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
+ }
+ if (!ckallocInit) {
+ TclInitDbCkalloc();
+ }
+ Tcl_MutexLock(ckallocMutexPtr);
+ result->length = size;
+ result->tagPtr = curTagPtr;
+ if (curTagPtr != NULL) {
+ curTagPtr->refCount++;
+ }
+ result->file = file;
+ result->line = line;
+ result->flink = allocHead;
+ result->blink = NULL;
+
+ if (allocHead != NULL)
+ allocHead->blink = result;
+ allocHead = result;
+
+ total_mallocs++;
+ if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
+ (void) fflush(stdout);
+ fprintf(stderr, "reached malloc trace enable point (%d)\n",
+ total_mallocs);
+ fflush(stderr);
+ alloc_tracing = TRUE;
+ trace_on_at_malloc = 0;
+ }
+
+ if (alloc_tracing)
+ fprintf(stderr,"ckalloc %lx %ud %s %d\n",
+ (long unsigned int) result->body, size, file, line);
+
+ if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
+ break_on_malloc = 0;
+ (void) fflush(stdout);
+ fprintf(stderr,"reached malloc break limit (%d)\n",
+ total_mallocs);
+ fprintf(stderr, "program will now enter C debugger\n");
+ (void) fflush(stderr);
+ abort();
+ }
+
+ current_malloc_packets++;
+ if (current_malloc_packets > maximum_malloc_packets)
+ maximum_malloc_packets = current_malloc_packets;
+ current_bytes_malloced += size;
+ if (current_bytes_malloced > maximum_bytes_malloced)
+ maximum_bytes_malloced = current_bytes_malloced;
+
+ Tcl_MutexUnlock(ckallocMutexPtr);
+
+ return result->body;
+}
+
\f
/*
*----------------------------------------------------------------------
int
Tcl_DbCkfree(ptr, file, line)
- char *ptr;
- char *file;
- int line;
+ char *ptr;
+ CONST char *file;
+ int line;
{
struct mem_header *memp;
*/
char *
Tcl_DbCkrealloc(ptr, size, file, line)
- char *ptr;
+ char *ptr;
unsigned int size;
- char *file;
- int line;
+ CONST char *file;
+ int line;
{
char *new;
unsigned int copySize;
return new;
}
+char *
+Tcl_AttemptDbCkrealloc(ptr, size, file, line)
+ char *ptr;
+ unsigned int size;
+ CONST char *file;
+ int line;
+{
+ char *new;
+ unsigned int copySize;
+ struct mem_header *memp;
+
+ if (ptr == NULL) {
+ return Tcl_AttemptDbCkalloc(size, file, line);
+ }
+
+ /*
+ * See comment from Tcl_DbCkfree before you change the following
+ * line.
+ */
+
+ memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET);
+
+ copySize = size;
+ if (copySize > (unsigned int) memp->length) {
+ copySize = memp->length;
+ }
+ new = Tcl_AttemptDbCkalloc(size, file, line);
+ if (new == NULL) {
+ return NULL;
+ }
+ memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize);
+ Tcl_DbCkfree(ptr, file, line);
+ return new;
+}
+
\f
/*
*----------------------------------------------------------------------
#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
+#undef Tcl_AttemptAlloc
+#undef Tcl_AttemptRealloc
char *
Tcl_Alloc(size)
return Tcl_DbCkalloc(size, "unknown", 0);
}
+char *
+Tcl_AttemptAlloc(size)
+ unsigned int size;
+{
+ return Tcl_AttemptDbCkalloc(size, "unknown", 0);
+}
+
void
Tcl_Free(ptr)
char *ptr;
{
return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
}
+char *
+Tcl_AttemptRealloc(ptr, size)
+ char *ptr;
+ unsigned int size;
+{
+ return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
+}
\f
/*
*----------------------------------------------------------------------
* MemoryCmd --
* Implements the Tcl "memory" command, which provides Tcl-level
* control of Tcl memory debugging information.
+ * memory active $file
+ * memory break_on_malloc $count
* memory info
- * memory display
- * memory break_on_malloc count
- * memory trace_on_at_malloc count
+ * memory init on|off
+ * memory onexit $file
+ * memory tag $string
* memory trace on|off
+ * memory trace_on_at_malloc $count
* memory validate on|off
*
* Results:
ClientData clientData;
Tcl_Interp *interp;
int argc;
- char **argv;
+ CONST char **argv;
{
- char *fileName;
+ CONST char *fileName;
Tcl_DString buffer;
int result;
return TCL_ERROR;
}
- if (strcmp(argv[1],"active") == 0) {
+ if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " active file\"", (char *) NULL);
+ argv[0], " ", argv[1], " file\"", (char *) NULL);
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
- char buffer[400];
- sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
+ char buf[400];
+ sprintf(buf, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced);
- Tcl_SetResult(interp, buffer, TCL_VOLATILE);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
return TCL_OK;
}
if (strcmp(argv[1],"init") == 0) {
init_malloced_bodies = (strcmp(argv[2],"on") == 0);
return TCL_OK;
}
+ if (strcmp(argv[1],"onexit") == 0) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " onexit file\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ if (fileName == NULL) {
+ return TCL_ERROR;
+ }
+ onExitMemDumpFileName = dumpFile;
+ strcpy(onExitMemDumpFileName,fileName);
+ Tcl_DStringFree(&buffer);
+ return TCL_OK;
+ }
if (strcmp(argv[1],"tag") == 0) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
}
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be active, break_on_malloc, info, init, ",
+ "\": should be active, break_on_malloc, info, init, onexit, ",
"tag, trace, trace_on_at_malloc, or validate", (char *) NULL);
return TCL_ERROR;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for evaluation. */
int argc; /* Number of arguments. */
- char *argv[]; /* String values of arguments. */
+ CONST char *argv[]; /* String values of arguments. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
* a special pointer on failure, but we only check for NULL
*/
if ((result == NULL) && size) {
- panic("unable to alloc %d bytes", size);
+ panic("unable to alloc %ud bytes", size);
}
return result;
}
char *
Tcl_DbCkalloc(size, file, line)
unsigned int size;
- char *file;
+ CONST char *file;
int line;
{
char *result;
if ((result == NULL) && size) {
fflush(stdout);
- panic("unable to alloc %d bytes, %s line %d", size, file, line);
+ panic("unable to alloc %ud bytes, %s line %d", size, file, line);
}
return result;
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AttemptAlloc --
+ * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
+ * check that memory was actually allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_AttemptAlloc (size)
+ unsigned int size;
+{
+ char *result;
+
+ result = TclpAlloc(size);
+ return result;
+}
+
+char *
+Tcl_AttemptDbCkalloc(size, file, line)
+ unsigned int size;
+ CONST char *file;
+ int line;
+{
+ char *result;
+
+ result = (char *) TclpAlloc(size);
+ return result;
+}
\f
/*
result = TclpRealloc(ptr, size);
if ((result == NULL) && size) {
- panic("unable to realloc %d bytes", size);
+ panic("unable to realloc %ud bytes", size);
}
return result;
}
char *
Tcl_DbCkrealloc(ptr, size, file, line)
- char *ptr;
+ char *ptr;
unsigned int size;
- char *file;
- int line;
+ CONST char *file;
+ int line;
{
char *result;
if ((result == NULL) && size) {
fflush(stdout);
- panic("unable to realloc %d bytes, %s line %d", size, file, line);
+ panic("unable to realloc %ud bytes, %s line %d", size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_AttemptRealloc --
+ * Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does
+ * not check that memory was actually allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_AttemptRealloc(ptr, size)
+ char *ptr;
+ unsigned int size;
+{
+ char *result;
+
+ result = TclpRealloc(ptr, size);
+ return result;
+}
+
+char *
+Tcl_AttemptDbCkrealloc(ptr, size, file, line)
+ char *ptr;
+ unsigned int size;
+ CONST char *file;
+ int line;
+{
+ char *result;
+
+ result = (char *) TclpRealloc(ptr, size);
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_Free --
* Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here
* rather in the macro to keep some modules from being compiled with
int
Tcl_DbCkfree(ptr, file, line)
- char *ptr;
- char *file;
- int line;
+ char *ptr;
+ CONST char *file;
+ int line;
{
TclpFree(ptr);
return 0;
int
Tcl_DumpActiveMemory(fileName)
- char *fileName;
+ CONST char *fileName;
{
return TCL_OK;
}
void
Tcl_ValidateAllMemory(file, line)
- char *file;
- int line;
+ CONST char *file;
+ int line;
{
}
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
- Tcl_MutexLock(ckallocMutexPtr);
if (tclMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(tclMemDumpFileName);
+ } else if (onExitMemDumpFileName != NULL) {
+ Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
+ Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
TclpFree((char *) curTagPtr);
+ curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
TclFinalizeAllocSubsystem();
#endif
}
-
Tcl_Obj *baseObjPtr = NULL;
char *scanStr;
- static char *switches[] =
+ static CONST char *switches[] =
{"clicks", "format", "scan", "seconds", (char *) NULL};
enum command { COMMAND_CLICKS, COMMAND_FORMAT, COMMAND_SCAN,
COMMAND_SECONDS
};
- static char *formatSwitches[] = {"-format", "-gmt", (char *) NULL};
- static char *scanSwitches[] = {"-base", "-gmt", (char *) NULL};
+ static CONST char *formatSwitches[] = {"-format", "-gmt", (char *) NULL};
+ static CONST char *scanSwitches[] = {"-base", "-gmt", (char *) NULL};
resultPtr = Tcl_GetObjResult(interp);
if (objc < 2) {
* We can enforce at least millisecond granularity
*/
Tcl_Time time;
- TclpGetTime(&time);
+ Tcl_GetTime(&time);
Tcl_SetLongObj(resultPtr,
(long) (time.sec*1000 + time.usec/1000));
} else {
#ifndef HAVE_TM_ZONE
int savedTimeZone = 0; /* lint. */
char *savedTZEnv = NULL; /* lint. */
-# ifndef timezone
- int timezone=0;
-# endif
#endif
#ifdef HAVE_TZSET
return TCL_OK;
}
-#ifndef HAVE_TM_ZONE
+#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
/*
* This is a kludge for systems not having the timezone string in
* struct tm. No matter what was specified, they use the local
*/
if (useGMT) {
- char *varValue;
+ CONST char *varValue;
varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
if (varValue != NULL) {
bufSize++;
}
}
+ Tcl_DStringInit(&uniBuffer);
+ Tcl_UtfToExternalDString(NULL, format, -1, &uniBuffer);
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
Tcl_MutexLock(&clockMutex);
- result = TclpStrftime(buffer.string, (unsigned int) bufSize, format,
- timeDataPtr);
+ result = TclpStrftime(buffer.string, (unsigned int) bufSize,
+ Tcl_DStringValue(&uniBuffer), timeDataPtr, useGMT);
Tcl_MutexUnlock(&clockMutex);
+ Tcl_DStringFree(&uniBuffer);
-#ifndef HAVE_TM_ZONE
+#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
if (useGMT) {
if (savedTZEnv != NULL) {
Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
}
/*
- * Convert the time to external encoding, in case we asked for
- * a localized return value. [Bug: 3345]
+ * Convert the time to UTF from external encoding [Bug: 3345]
*/
Tcl_DStringInit(&uniBuffer);
Tcl_ExternalToUtfDString(NULL, buffer.string, -1, &uniBuffer);
return TCL_OK;
}
-
#include "tclPort.h"
#include <locale.h>
-typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));
-
/*
* Prototypes for local procedures defined in this file:
*/
static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, int mode));
static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, StatProc *statProc,
- struct stat *statPtr));
+ Tcl_Obj *objPtr, Tcl_FSStatProc *statProc,
+ Tcl_StatBuf *statPtr));
static char * GetTypeFromMode _ANSI_ARGS_((int mode));
-static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr));
static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
- char *varName, struct stat *statPtr));
-static char ** StringifyObjects _ANSI_ARGS_((int objc,
- Tcl_Obj *CONST objv[]));
+ char *varName, Tcl_StatBuf *statPtr));
\f
/*
*----------------------------------------------------------------------
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register int i;
- int body, result;
+ int body, result, caseObjc;
char *string, *arg;
- int caseObjc;
Tcl_Obj *CONST *caseObjv;
Tcl_Obj *armPtr;
for (i = 0; i < caseObjc; i += 2) {
int patObjc, j;
- char **patObjv;
+ CONST char **patObjv;
char *pat;
unsigned char *p;
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *dirName;
- Tcl_DString ds;
+ Tcl_Obj *dir;
int result;
if (objc > 2) {
}
if (objc == 2) {
- dirName = Tcl_GetString(objv[1]);
+ dir = objv[1];
} else {
- dirName = "~";
+ dir = Tcl_NewStringObj("~",1);
+ Tcl_IncrRefCount(dir);
}
- if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) {
- return TCL_ERROR;
+ if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) {
+ result = TCL_ERROR;
+ } else {
+ result = Tcl_FSChdir(dir);
+ if (result != TCL_OK) {
+ Tcl_AppendResult(interp, "couldn't change working directory to \"",
+ Tcl_GetString(dir), "\": ", Tcl_PosixError(interp), (char *) NULL);
+ result = TCL_ERROR;
+ }
}
-
- result = Tcl_Chdir(Tcl_DStringValue(&ds));
- Tcl_DStringFree(&ds);
-
- if (result != 0) {
- Tcl_AppendResult(interp, "couldn't change working directory to \"",
- dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
+ if (objc != 2) {
+ Tcl_DecrRefCount(dir);
}
- return TCL_OK;
+ return result;
}
\f
/*
Tcl_DString ds;
Tcl_Obj *resultPtr;
- static char *optionStrings[] = {
+ static CONST char *optionStrings[] = {
"convertfrom", "convertto", "names", "system",
NULL
};
return TCL_ERROR;
}
if (objc == 2) {
- Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC);
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ Tcl_GetEncodingName(NULL), -1);
} else {
return Tcl_SetSystemEncoding(interp,
Tcl_GetStringFromObj(objv[2], NULL));
* Create a new object holding the concatenated argument strings.
*/
+ /*** QUESTION: Do we need to copy the slow way? ***/
bytes = Tcl_GetStringFromObj(objv[1], &length);
objPtr = Tcl_NewStringObj(bytes, length);
Tcl_IncrRefCount(objPtr);
* See the user documentation for details on what it does.
* PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH
* EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC.
- *
+ * With the object-based Tcl_FS APIs, the above NOTE may no
+ * longer be true. In any case this assertion should be tested.
+ *
* Results:
* A standard Tcl result.
*
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Obj *resultPtr;
int index;
/*
* This list of constants should match the fileOption string array below.
*/
- static char *fileOptions[] = {
+ static CONST char *fileOptions[] = {
"atime", "attributes", "channels", "copy",
"delete",
"dirname", "executable", "exists", "extension",
- "isdirectory", "isfile", "join", "lstat",
- "mtime", "mkdir", "nativename", "owned",
+ "isdirectory", "isfile", "join", "link",
+ "lstat", "mtime", "mkdir", "nativename",
+ "normalize", "owned",
"pathtype", "readable", "readlink", "rename",
- "rootname", "size", "split", "stat",
+ "rootname", "separator", "size", "split",
+ "stat", "system",
"tail", "type", "volumes", "writable",
(char *) NULL
};
FILE_ATIME, FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY,
FILE_DELETE,
FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION,
- FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT,
- FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED,
+ FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LINK,
+ FILE_LSTAT, FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME,
+ FILE_NORMALIZE, FILE_OWNED,
FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME,
- FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT,
+ FILE_ROOTNAME, FILE_SEPARATOR, FILE_SIZE, FILE_SPLIT,
+ FILE_STAT, FILE_SYSTEM,
FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE
};
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
switch ((enum options) index) {
case FILE_ATIME: {
- struct stat buf;
- char *fileName;
+ Tcl_StatBuf buf;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
}
tval.actime = buf.st_atime;
tval.modtime = buf.st_mtime;
- fileName = Tcl_GetString(objv[2]);
- if (utime(fileName, &tval) != 0) {
- Tcl_AppendStringsToObj(resultPtr,
+ if (Tcl_FSUtime(objv[2], &tval) != 0) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not set access time for file \"",
- fileName, "\": ",
+ Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
* one we sent in. However, fs's like FAT don't
* even know what atime is.
*/
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
- Tcl_SetLongObj(resultPtr, (long) buf.st_atime);
+ Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime);
return TCL_OK;
}
case FILE_ATTRIBUTES: {
((objc == 2) ? NULL : Tcl_GetString(objv[2])));
}
case FILE_COPY: {
- int result;
- char **argv;
-
- argv = StringifyObjects(objc, objv);
- result = TclFileCopyCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileCopyCmd(interp, objc, objv);
}
case FILE_DELETE: {
- int result;
- char **argv;
-
- argv = StringifyObjects(objc, objv);
- result = TclFileDeleteCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileDeleteCmd(interp, objc, objv);
}
case FILE_DIRNAME: {
- int argc;
- char **argv;
-
+ Tcl_Obj *dirPtr;
if (objc != 3) {
goto only3Args;
}
- if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Return all but the last component. If there is only one
- * component, return it if the path was non-relative, otherwise
- * return the current directory.
- */
-
- if (argc > 1) {
- Tcl_DString ds;
-
- Tcl_DStringInit(&ds);
- Tcl_JoinPath(argc - 1, argv, &ds);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- } else if ((argc == 0)
- || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_SetStringObj(resultPtr,
- ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
+ dirPtr = TclFileDirname(interp, objv[2]);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
} else {
- Tcl_SetStringObj(resultPtr, argv[0], -1);
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ return TCL_OK;
}
- ckfree((char *) argv);
- return TCL_OK;
}
case FILE_EXECUTABLE: {
if (objc != 3) {
fileName = Tcl_GetString(objv[2]);
extension = TclGetExtension(fileName);
if (extension != NULL) {
- Tcl_SetStringObj(resultPtr, extension, -1);
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1);
}
return TCL_OK;
}
case FILE_ISDIRECTORY: {
int value;
- struct stat buf;
+ Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
- if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISDIR(buf.st_mode);
}
- Tcl_SetBooleanObj(resultPtr, value);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FILE_ISFILE: {
int value;
- struct stat buf;
+ Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
- if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISREG(buf.st_mode);
}
- Tcl_SetBooleanObj(resultPtr, value);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FILE_JOIN: {
- char **argv;
- Tcl_DString ds;
+ Tcl_Obj *resObj;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
- argv = StringifyObjects(objc - 2, objv + 2);
- Tcl_DStringInit(&ds);
- Tcl_JoinPath(objc - 2, argv, &ds);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- ckfree((char *) argv);
+ resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
+ Tcl_SetObjResult(interp, resObj);
+ return TCL_OK;
+ }
+ case FILE_LINK: {
+ Tcl_Obj *contents;
+ int index;
+
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-linktype? linkname ?target?");
+ return TCL_ERROR;
+ }
+
+ /* Index of the 'source' argument */
+ if (objc == 5) {
+ index = 3;
+ } else {
+ index = 2;
+ }
+
+ if (objc > 3) {
+ int linkAction;
+ if (objc == 5) {
+ /* We have a '-linktype' argument */
+ static CONST char *linkTypes[] = {
+ "-symbolic", "-hard", NULL
+ };
+ if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes,
+ "switch", 0, &linkAction) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (linkAction == 0) {
+ linkAction = TCL_CREATE_SYMBOLIC_LINK;
+ } else {
+ linkAction = TCL_CREATE_HARD_LINK;
+ }
+ } else {
+ linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
+ }
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /* Create link from source to target */
+ contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
+ if (contents == NULL) {
+ /*
+ * We handle two common error cases specially, and
+ * for all other errors, we use the standard posix
+ * error message.
+ */
+ if (errno == EEXIST) {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ Tcl_GetString(objv[index]),
+ "\": that path already exists", (char *) NULL);
+ } else if (errno == ENOENT) {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ Tcl_GetString(objv[index]),
+ "\" since target \"",
+ Tcl_GetString(objv[index+1]),
+ "\" doesn't exist",
+ (char *) NULL);
+ } else {
+ Tcl_AppendResult(interp, "could not create new link \"",
+ Tcl_GetString(objv[index]), "\" pointing to \"",
+ Tcl_GetString(objv[index+1]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /* Read link */
+ contents = Tcl_FSLink(objv[index], NULL, 0);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not read link \"",
+ Tcl_GetString(objv[index]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, contents);
+ if (objc == 3) {
+ /*
+ * If we are reading a link, we need to free this
+ * result refCount. If we are creating a link, this
+ * will just be objv[index+1], and so we don't own it.
+ */
+ Tcl_DecrRefCount(contents);
+ }
return TCL_OK;
}
case FILE_LSTAT: {
char *varName;
- struct stat buf;
+ Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name varName");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
return StoreStatData(interp, varName, &buf);
}
case FILE_MTIME: {
- struct stat buf;
- char *fileName;
+ Tcl_StatBuf buf;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
}
tval.actime = buf.st_atime;
tval.modtime = buf.st_mtime;
- fileName = Tcl_GetString(objv[2]);
- if (utime(fileName, &tval) != 0) {
- Tcl_AppendStringsToObj(resultPtr,
+ if (Tcl_FSUtime(objv[2], &tval) != 0) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not set modification time for file \"",
- fileName, "\": ",
+ Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
* one we sent in. However, fs's like FAT don't
* even know what atime is.
*/
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
- Tcl_SetLongObj(resultPtr, (long) buf.st_mtime);
+ Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime);
return TCL_OK;
}
case FILE_MKDIR: {
- char **argv;
- int result;
-
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
- argv = StringifyObjects(objc, objv);
- result = TclFileMakeDirsCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileMakeDirsCmd(interp, objc, objv);
}
case FILE_NATIVENAME: {
- char *fileName;
+ CONST char *fileName;
Tcl_DString ds;
if (objc != 3) {
if (fileName == NULL) {
return TCL_ERROR;
}
- Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds));
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
+ Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
return TCL_OK;
}
+ case FILE_NORMALIZE: {
+ Tcl_Obj *fileName;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "filename");
+ return TCL_ERROR;
+ }
+
+ fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ Tcl_SetObjResult(interp, fileName);
+ return TCL_OK;
+ }
case FILE_OWNED: {
int value;
- struct stat buf;
+ Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
- if (GetStatBuf(NULL, objv[2], TclStat, &buf) == TCL_OK) {
+ if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
/*
* For Windows and Macintosh, there are no user ids
* associated with a file, so we always return 1.
value = (geteuid() == buf.st_uid);
#endif
}
- Tcl_SetBooleanObj(resultPtr, value);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FILE_PATHTYPE: {
- char *fileName;
-
if (objc != 3) {
goto only3Args;
}
- fileName = Tcl_GetString(objv[2]);
- switch (Tcl_GetPathType(fileName)) {
+ switch (Tcl_FSGetPathType(objv[2])) {
case TCL_PATH_ABSOLUTE:
- Tcl_SetStringObj(resultPtr, "absolute", -1);
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
break;
case TCL_PATH_RELATIVE:
- Tcl_SetStringObj(resultPtr, "relative", -1);
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1);
break;
case TCL_PATH_VOLUME_RELATIVE:
- Tcl_SetStringObj(resultPtr, "volumerelative", -1);
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "volumerelative", -1);
break;
}
return TCL_OK;
return CheckAccess(interp, objv[2], R_OK);
}
case FILE_READLINK: {
- char *fileName, *contents;
- Tcl_DString name, link;
+ Tcl_Obj *contents;
if (objc != 3) {
goto only3Args;
}
- fileName = Tcl_GetString(objv[2]);
- fileName = Tcl_TranslateFileName(interp, fileName, &name);
- if (fileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
return TCL_ERROR;
}
- /*
- * If S_IFLNK isn't defined it means that the machine doesn't
- * support symbolic links, so the file can't possibly be a
- * symbolic link. Generate an EINVAL error, which is what
- * happens on machines that do support symbolic links when
- * you invoke readlink on a file that isn't a symbolic link.
- */
-
-#ifndef S_IFLNK
- contents = NULL;
- errno = EINVAL;
-#else
- contents = TclpReadlink(fileName, &link);
-#endif /* S_IFLNK */
+ contents = Tcl_FSLink(objv[2], NULL, 0);
- Tcl_DStringFree(&name);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not readlink \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
- Tcl_DStringResult(interp, &link);
+ Tcl_SetObjResult(interp, contents);
+ Tcl_DecrRefCount(contents);
return TCL_OK;
}
case FILE_RENAME: {
- int result;
- char **argv;
-
- argv = StringifyObjects(objc, objv);
- result = TclFileRenameCmd(interp, objc, argv);
- ckfree((char *) argv);
- return result;
+ return TclFileRenameCmd(interp, objc, objv);
}
case FILE_ROOTNAME: {
int length;
if (extension == NULL) {
Tcl_SetObjResult(interp, objv[2]);
} else {
- Tcl_SetStringObj(resultPtr, fileName,
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
(int) (length - strlen(extension)));
}
return TCL_OK;
}
+ case FILE_SEPARATOR: {
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?name?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ char *separator = NULL; /* lint */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separator = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separator = "\\";
+ break;
+ case TCL_PLATFORM_MAC:
+ separator = ":";
+ break;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
+ } else {
+ Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
+ if (separatorObj != NULL) {
+ Tcl_SetObjResult(interp, separatorObj);
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Unrecognised path",-1));
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+ }
case FILE_SIZE: {
- struct stat buf;
+ Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_SetLongObj(resultPtr, (long) buf.st_size);
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp),
+ (Tcl_WideInt) buf.st_size);
return TCL_OK;
}
case FILE_SPLIT: {
- int i, argc;
- char **argv;
- char *fileName;
- Tcl_Obj *objPtr;
-
if (objc != 3) {
goto only3Args;
}
- fileName = Tcl_GetString(objv[2]);
- Tcl_SplitPath(fileName, &argc, &argv);
- for (i = 0; i < argc; i++) {
- objPtr = Tcl_NewStringObj(argv[i], -1);
- Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);
- }
- ckfree((char *) argv);
+ Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
return TCL_OK;
}
case FILE_STAT: {
char *varName;
- struct stat buf;
+ Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
return TCL_ERROR;
}
- if (GetStatBuf(interp, objv[2], TclStat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
return StoreStatData(interp, varName, &buf);
}
+ case FILE_SYSTEM: {
+ Tcl_Obj* fsInfo;
+ if (objc != 3) {
+ goto only3Args;
+ }
+ fsInfo = Tcl_FSFileSystemInfo(objv[2]);
+ if (fsInfo != NULL) {
+ Tcl_SetObjResult(interp, fsInfo);
+ return TCL_OK;
+ } else {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Unrecognised path",-1));
+ return TCL_ERROR;
+ }
+ }
case FILE_TAIL: {
- int argc;
- char **argv;
+ int splitElements;
+ Tcl_Obj *splitPtr;
if (objc != 3) {
goto only3Args;
}
- if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {
- return TCL_ERROR;
+ /*
+ * The behaviour we want here is slightly different to
+ * the standard Tcl_FSSplitPath in the handling of home
+ * directories; Tcl_FSSplitPath preserves the "~" while
+ * this code computes the actual full path name, if we
+ * had just a single component.
+ */
+ splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
+ if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
+ Tcl_DecrRefCount(splitPtr);
+ splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
+ if (splitPtr == NULL) {
+ return TCL_ERROR;
+ }
+ splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
}
/*
* and it is the root of an absolute path.
*/
- if (argc > 0) {
- if ((argc > 1)
- || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_SetStringObj(resultPtr, argv[argc - 1], -1);
+ if (splitElements > 0) {
+ if ((splitElements > 1)
+ || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
+
+ Tcl_Obj *tail = NULL;
+ Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
+ Tcl_SetObjResult(interp, tail);
}
}
- ckfree((char *) argv);
+ Tcl_DecrRefCount(splitPtr);
return TCL_OK;
}
case FILE_TYPE: {
- struct stat buf;
+ Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
- if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
+ if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_SetStringObj(resultPtr,
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
GetTypeFromMode((unsigned short) buf.st_mode), -1);
return TCL_OK;
}
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- return TclpListVolumes(interp);
+ Tcl_SetObjResult(interp, Tcl_FSListVolumes());
+ return TCL_OK;
}
case FILE_WRITABLE: {
if (objc != 3) {
/*
*---------------------------------------------------------------------------
*
- * SplitPath --
- *
- * Utility procedure used by Tcl_FileObjCmd() to split a path.
- * Differs from standard Tcl_SplitPath in its handling of home
- * directories; Tcl_SplitPath preserves the "~" while this
- * procedure computes the actual full path name.
- *
- * Results:
- * The return value is TCL_OK if the path could be split, TCL_ERROR
- * otherwise. If TCL_ERROR was returned, an error message is left
- * in interp. If TCL_OK was returned, *argvPtr is set to a newly
- * allocated array of strings that represent the individual
- * directories in the specified path, and *argcPtr is filled with
- * the length of that array.
- *
- * Side effects:
- * Memory allocated. The caller must eventually free this memory
- * by calling ckfree() on *argvPtr.
- *
- *---------------------------------------------------------------------------
- */
-
-static int
-SplitPath(interp, objPtr, argcPtr, argvPtr)
- Tcl_Interp *interp; /* Interp for error return. May be NULL. */
- Tcl_Obj *objPtr; /* Path to be split. */
- int *argcPtr; /* Filled with length of following array. */
- char ***argvPtr; /* Filled with array of strings representing
- * the elements of the specified path. */
-{
- char *fileName;
-
- fileName = Tcl_GetString(objPtr);
-
- /*
- * If there is only one element, and it starts with a tilde,
- * perform tilde substitution and resplit the path.
- */
-
- Tcl_SplitPath(fileName, argcPtr, argvPtr);
- if ((*argcPtr == 1) && (fileName[0] == '~')) {
- Tcl_DString ds;
-
- ckfree((char *) *argvPtr);
- fileName = Tcl_TranslateFileName(interp, fileName, &ds);
- if (fileName == NULL) {
- return TCL_ERROR;
- }
- Tcl_SplitPath(fileName, argcPtr, argvPtr);
- Tcl_DStringFree(&ds);
- }
- return TCL_OK;
-}
-\f
-/*
- *---------------------------------------------------------------------------
- *
* CheckAccess --
*
* Utility procedure used by Tcl_FileObjCmd() to query file
* access(). */
{
int value;
- char *fileName;
- Tcl_DString ds;
- fileName = Tcl_GetString(objPtr);
- fileName = Tcl_TranslateFileName(interp, fileName, &ds);
- if (fileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
value = 0;
} else {
- value = (TclAccess(fileName, mode) == 0);
- Tcl_DStringFree(&ds);
+ value = (Tcl_FSAccess(objPtr, mode) == 0);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
GetStatBuf(interp, objPtr, statProc, statPtr)
Tcl_Interp *interp; /* Interp for error return. May be NULL. */
Tcl_Obj *objPtr; /* Path name to examine. */
- StatProc *statProc; /* Either stat() or lstat() depending on
+ Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on
* desired behavior. */
- struct stat *statPtr; /* Filled with info about file obtained by
+ Tcl_StatBuf *statPtr; /* Filled with info about file obtained by
* calling (*statProc)(). */
{
- char *fileName;
- Tcl_DString ds;
int status;
- fileName = Tcl_GetString(objPtr);
- fileName = Tcl_TranslateFileName(interp, fileName, &ds);
- if (fileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
return TCL_ERROR;
}
- status = (*statProc)(Tcl_DStringValue(&ds), statPtr);
- Tcl_DStringFree(&ds);
+ status = (*statProc)(objPtr, statPtr);
if (status < 0) {
if (interp != NULL) {
Tcl_Interp *interp; /* Interpreter for error reports. */
char *varName; /* Name of associative array variable
* in which to store stat results. */
- struct stat *statPtr; /* Pointer to buffer containing
+ Tcl_StatBuf *statPtr; /* Pointer to buffer containing
* stat data to store in varName. */
{
- char string[TCL_INTEGER_SPACE];
+ Tcl_Obj *var = Tcl_NewStringObj(varName, -1);
+ Tcl_Obj *field = Tcl_NewObj();
+ Tcl_Obj *value;
+ register unsigned short mode;
- TclFormatInt(string, (long) statPtr->st_dev);
- if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (long) statPtr->st_ino);
- if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (unsigned short) statPtr->st_mode);
- if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (long) statPtr->st_nlink);
- if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (long) statPtr->st_uid);
- if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (long) statPtr->st_gid);
- if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- sprintf(string, "%lu", (unsigned long) statPtr->st_size);
- if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (long) statPtr->st_atime);
- if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (long) statPtr->st_mtime);
- if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- TclFormatInt(string, (long) statPtr->st_ctime);
- if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
- == NULL) {
- return TCL_ERROR;
- }
- if (Tcl_SetVar2(interp, varName, "type",
- GetTypeFromMode((unsigned short) statPtr->st_mode),
- TCL_LEAVE_ERR_MSG) == NULL) {
- return TCL_ERROR;
- }
+ /*
+ * Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
+ */
+#define STORE_ARY(fieldName, object) \
+ Tcl_SetStringObj(field, (fieldName), -1); \
+ value = (object); \
+ if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
+ Tcl_DecrRefCount(var); \
+ Tcl_DecrRefCount(field); \
+ Tcl_DecrRefCount(value); \
+ return TCL_ERROR; \
+ }
+
+ Tcl_IncrRefCount(var);
+ Tcl_IncrRefCount(field);
+ STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
+ /*
+ * Watch out porters; the inode is meant to be an *unsigned* value,
+ * so the cast might fail when there isn't a real arithmentic 'long
+ * long' type...
+ */
+ STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino));
+ STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink));
+ STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid));
+ STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid));
+ STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
+#ifdef HAVE_ST_BLOCKS
+ STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
+#endif
+ STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime));
+ STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime));
+ STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime));
+ mode = (unsigned short) statPtr->st_mode;
+ STORE_ARY("mode", Tcl_NewIntObj(mode));
+ STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
+#undef STORE_ARY
+ Tcl_DecrRefCount(var);
+ Tcl_DecrRefCount(field);
return TCL_OK;
}
\f
Tcl_Obj **argObjv = argObjStorage;
#define STATIC_LIST_SIZE 4
- int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */
- int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */
- Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */
- int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */
- Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */
-
- int *index = indexArray;
- int *varcList = varcListArray;
- Tcl_Obj ***varvList = varvListArray;
- int *argcList = argcListArray;
- Tcl_Obj ***argvList = argvListArray;
+ int indexArray[STATIC_LIST_SIZE];
+ int varcListArray[STATIC_LIST_SIZE];
+ Tcl_Obj **varvListArray[STATIC_LIST_SIZE];
+ int argcListArray[STATIC_LIST_SIZE];
+ Tcl_Obj **argvListArray[STATIC_LIST_SIZE];
+
+ int *index = indexArray; /* Array of value list indices */
+ int *varcList = varcListArray; /* # loop variables per list */
+ Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */
+ int *argcList = argcListArray; /* Array of value list sizes */
+ Tcl_Obj ***argvList = argvListArray; /* Array of value lists */
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
for (j = 0; j < maxj; j++) {
for (i = 0; i < numLists; i++) {
/*
- * If a variable or value list object has been converted to
- * another kind of Tcl object, convert it back to a list object
- * and refetch the pointer to its element array.
+ * Refetch the list members; we assume that the sizes are
+ * the same, but the array of elements might be different
+ * if the internal rep of the objects has been lost and
+ * recreated (it is too difficult to accurately tell when
+ * this happens, which can lead to some wierd crashes,
+ * like Bug #494348...)
*/
- if (argObjv[1+i*2]->typePtr != &tclListType) {
- result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
- &varcList[i], &varvList[i]);
- if (result != TCL_OK) {
- panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
- }
+ result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
+ &varcList[i], &varvList[i]);
+ if (result != TCL_OK) {
+ panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
}
- if (argObjv[2+i*2]->typePtr != &tclListType) {
- result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
- &argcList[i], &argvList[i]);
- if (result != TCL_OK) {
- panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
- }
+ result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
+ &argcList[i], &argvList[i]);
+ if (result != TCL_OK) {
+ panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
}
for (v = 0; v < varcList[i]; v++) {
{
char *format; /* Used to read characters from the format
* string. */
- int formatLen; /* The length of the format string */
+ int formatLen; /* The length of the format string */
char *endPtr; /* Points to the last char in format array */
- char newFormat[40]; /* A new format specifier is generated here. */
+ char newFormat[43]; /* A new format specifier is generated here. */
int width; /* Field width from field specifier, or 0 if
* no width given. */
int precision; /* Field precision from field specifier, or 0
int size; /* Number of bytes needed for result of
* conversion, based on type of conversion
* ("e", "s", etc.), width, and precision. */
- int intValue; /* Used to hold value to pass to sprintf, if
+ long intValue; /* Used to hold value to pass to sprintf, if
* it's a one-word integer or char value */
char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if
* it's a one-word value. */
double doubleValue; /* Used to hold value to pass to sprintf if
* it's a double value. */
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if
+ * it's a 'long long' value. */
+#endif /* TCL_WIDE_INT_IS_LONG */
int whichValue; /* Indicates which of intValue, ptrValue,
* or doubleValue has the value to pass to
* sprintf, according to the following
# define PTR_VALUE 2
# define DOUBLE_VALUE 3
# define STRING_VALUE 4
+# define WIDE_VALUE 5
# define MAX_FLOAT_SIZE 320
-
+
Tcl_Obj *resultPtr; /* Where result is stored finally. */
char staticBuf[MAX_FLOAT_SIZE + 1];
/* A static buffer to copy the format results
* been set for the current field. */
int gotZero; /* Non-zero indicates that a zero flag has
* been seen in the current field. */
+#ifndef TCL_WIDE_INT_IS_LONG
+ int useWide; /* Value to be printed is Tcl_WideInt. */
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* This procedure is a bit nasty. The goal is to use sprintf to
* whatever's generated. This is hard to estimate.
* 3. there's no way to move the arguments from objv to the call
* to sprintf in a reasonable way. This is particularly nasty
- * because some of the arguments may be two-word values (doubles).
+ * because some of the arguments may be two-word values (doubles
+ * and wide-ints).
* So, what happens here is to scan the format string one % group
* at a time, making many individual calls to sprintf.
*/
return TCL_ERROR;
}
- format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen);
+ format = Tcl_GetStringFromObj(objv[1], &formatLen);
endPtr = format + formatLen;
resultPtr = Tcl_NewObj();
objIndex = 2;
width = precision = noPercent = useShort = 0;
gotZero = gotMinus = gotPrecision = 0;
+#ifndef TCL_WIDE_INT_IS_LONG
+ useWide = 0;
+#endif /* TCL_WIDE_INT_IS_LONG */
whichValue = PTR_VALUE;
/*
newPtr++;
format++;
}
- if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
+ if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
width = strtoul(format, &end, 10); /* INTL: Tcl source. */
format = end;
} else if (*format == '*') {
format++;
gotPrecision = 1;
}
- if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
+ if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
precision = strtoul(format, &end, 10); /* INTL: "C" locale. */
format = end;
} else if (*format == '*') {
}
}
if (*format == 'l') {
+#ifndef TCL_WIDE_INT_IS_LONG
+ useWide = 1;
+ strcpy(newPtr, TCL_LL_MODIFIER);
+ newPtr += TCL_LL_MODIFIER_SIZE;
+#endif /* TCL_WIDE_INT_IS_LONG */
format++;
} else if (*format == 'h') {
useShort = 1;
case 'u':
case 'x':
case 'X':
- if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (useWide) {
+ if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
+ objv[objIndex], &wideValue) != TCL_OK) {
+ goto fmtError;
+ }
+ whichValue = WIDE_VALUE;
+ size = 40 + precision;
+ break;
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &intValue) != TCL_OK) {
goto fmtError;
}
+#if (LONG_MAX > INT_MAX)
+ /*
+ * Add the 'l' for long format type because we are on
+ * an LP64 archtecture and we are really going to pass
+ * a long argument to sprintf.
+ */
+ newPtr++;
+ *newPtr = 0;
+ newPtr[-1] = newPtr[-2];
+ newPtr[-2] = 'l';
+#endif /* LONG_MAX > INT_MAX */
whichValue = INT_VALUE;
size = 40 + precision;
break;
}
break;
case 'c':
- if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
+ if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &intValue) != TCL_OK) {
goto fmtError;
}
sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
break;
}
+#ifndef TCL_WIDE_INT_IS_LONG
+ case WIDE_VALUE: {
+ sprintf(dst, newFormat, wideValue);
+ break;
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
case INT_VALUE: {
if (useShort) {
sprintf(dst, newFormat, (short) intValue);
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
-\f
-/*
- *---------------------------------------------------------------------------
- *
- * StringifyObjects --
- *
- * Helper function to bridge the gap between an object-based procedure
- * and an older string-based procedure.
- *
- * Given an array of objects, allocate an array that consists of the
- * string representations of those objects.
- *
- * Results:
- * The return value is a pointer to the newly allocated array of
- * strings. Elements 0 to (objc-1) of the string array point to the
- * string representation of the corresponding element in the source
- * object array; element objc of the string array is NULL.
- *
- * Side effects:
- * Memory allocated. The caller must eventually free this memory
- * by calling ckfree() on the return value.
- *
- *---------------------------------------------------------------------------
- */
-
-static char **
-StringifyObjects(objc, objv)
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- int i;
- char **argv;
-
- argv = (char **) ckalloc((objc + 1) * sizeof(char *));
- for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
- }
- argv[i] = NULL;
- return argv;
-}
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#include "tclInt.h"
#include "tclPort.h"
-#include "tclCompile.h"
#include "tclRegexp.h"
/*
#define SORTMODE_DICTIONARY 4
/*
+ * Magic values for the index field of the SortInfo structure.
+ * Note that the index "end-1" will be translated to SORTIDX_END-1, etc.
+ */
+#define SORTIDX_NONE -1 /* Not indexed; use whole value. */
+#define SORTIDX_END -2 /* Indexed from end. */
+
+/*
* Forward declarations for procedures defined in this file:
*/
static void AppendLocals _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *listPtr, char *pattern,
+ Tcl_Obj *listPtr, CONST char *pattern,
int includeLinks));
static int DictionaryCompare _ANSI_ARGS_((char *left,
char *right));
static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
if (objc == 2) {
incrAmount = 1;
} else {
+#ifdef TCL_WIDE_INT_IS_LONG
if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
+#else
+ /*
+ * Need to be a bit cautious to ensure that [expr]-like rules
+ * are enforced for interpretation of wide integers, despite
+ * the fact that the underlying API itself is a 'long' only one.
+ */
+ if (objv[2]->typePtr == &tclIntType) {
+ incrAmount = objv[2]->internalRep.longValue;
+ } else if (objv[2]->typePtr == &tclWideIntType) {
+ incrAmount = Tcl_WideAsLong(objv[2]->internalRep.wideValue);
+ } else {
+ Tcl_WideInt wide;
+
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (reading increment)");
+ return TCL_ERROR;
+ }
+ incrAmount = Tcl_WideAsLong(wide);
+ if ((wide <= Tcl_LongAsWide(LONG_MAX))
+ && (wide >= Tcl_LongAsWide(LONG_MIN))) {
+ objv[2]->typePtr = &tclIntType;
+ objv[2]->internalRep.longValue = incrAmount;
+ }
+ }
+#endif
}
/*
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- static char *subCmds[] = {
+ static CONST char *subCmds[] = {
"args", "body", "cmdcount", "commands",
- "complete", "default", "exists", "globals",
+ "complete", "default", "exists", "functions", "globals",
"hostname", "level", "library", "loaded",
"locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
- ICompleteIdx, IDefaultIdx, IExistsIdx, IGlobalsIdx,
+ ICompleteIdx, IDefaultIdx, IExistsIdx, IFunctionsIdx, IGlobalsIdx,
IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
+ case IFunctionsIdx:
+ result = InfoFunctionsCmd(clientData, interp, objc, objv);
+ break;
case IGlobalsIdx:
result = InfoGlobalsCmd(clientData, interp, objc, objv);
break;
return TCL_ERROR;
}
- /*
- * We should not return a bytecompiled body. If it is precompiled,
- * then the bodyPtr's string representation is bogus, since sources
- * are not available. If it was just a bytecompiled body, then it
- * is likely to not be of any use to the caller, as it was compiled
- * for a separate procedure context [Bug: 3412], and noone else can
- * reasonably use it.
- * In order to make sure that later manipulations of the object do not
- * invalidate the internal representation, we make a copy of the string
- * representation and return that one, instead.
+ /*
+ * Here we used to return procPtr->bodyPtr, except when the body was
+ * bytecompiled - in that case, the return was a copy of the body's
+ * string rep. In order to better isolate the implementation details
+ * of the compiler/engine subsystem, we now always return a copy of
+ * the string rep. It is important to return a copy so that later
+ * manipulations of the object do not invalidate the internal rep.
*/
bodyPtr = procPtr->bodyPtr;
- resultPtr = bodyPtr;
- if (bodyPtr->typePtr == &tclByteCodeType) {
- resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
+ if (bodyPtr->bytes == NULL) {
+ /*
+ * The string rep might not be valid if the procedure has
+ * never been run before. [Bug #545644]
+ */
+ (void) Tcl_GetString(bodyPtr);
}
+ resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length);
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *cmdName, *pattern, *simplePattern;
+ char *cmdName, *pattern;
+ CONST char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Namespace *nsPtr;
/*
*----------------------------------------------------------------------
*
+ * InfoFunctionsCmd --
+ *
+ * Called to implement the "info functions" command that returns the
+ * list of math functions matching an optional pattern. Handles the
+ * following syntax:
+ *
+ * info functions ?pattern?
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If there is
+ * an error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoFunctionsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *pattern;
+ Tcl_Obj *listPtr;
+
+ if (objc == 2) {
+ pattern = NULL;
+ } else if (objc == 3) {
+ pattern = Tcl_GetString(objv[2]);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
+ return TCL_ERROR;
+ }
+
+ listPtr = Tcl_ListMathFuncs(interp, pattern);
+ if (listPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* InfoGlobalsCmd --
*
* Called to implement the "info globals" command that returns the list
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *name;
+ CONST char *name;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *libDirName;
+ CONST char *libDirName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
AppendLocals(interp, listPtr, pattern, includeLinks)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Obj *listPtr; /* List object to append names to. */
- char *pattern; /* Pattern to match against. */
+ CONST char *pattern; /* Pattern to match against. */
int includeLinks; /* 1 if upvars should be included, else 0. */
{
Interp *iPtr = (Interp *) interp;
* Skip nameless (temporary) variables and undefined variables
*/
- if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)) {
+ if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
+ && (includeLinks || !TclIsVarLink(varPtr))) {
varName = varPtr->name;
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
nameOfExecutable = Tcl_GetNameOfExecutable();
if (nameOfExecutable != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), (char *)nameOfExecutable, -1);
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), nameOfExecutable, -1);
}
return TCL_OK;
}
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *patchlevel;
+ CONST char *patchlevel;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *cmdName, *pattern, *simplePattern;
+ char *cmdName, *pattern;
+ CONST char *simplePattern;
Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
|| Tcl_StringMatch(cmdName, simplePattern)) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
- if (specificNsInPattern) {
- elemObjPtr = Tcl_NewObj();
- Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
- elemObjPtr);
- } else {
- elemObjPtr = Tcl_NewStringObj(cmdName, -1);
- }
-
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (TclIsProc(cmdPtr)
|| ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) {
+ if (specificNsInPattern) {
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
+ elemObjPtr);
+ } else {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ }
+
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
* script file that is currently being evaluated. Handles the
* following syntax:
*
- * info script
+ * info script ?newName?
+ *
+ * If newName is specified, it will set that as the internal name.
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
- * an error, the result is an error message.
+ * an error, the result is an error message. It may change the
+ * internal script filename.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ if ((objc != 2) && (objc != 3)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?filename?");
return TCL_ERROR;
}
+ if (objc == 3) {
+ if (iPtr->scriptFile != NULL) {
+ Tcl_DecrRefCount(iPtr->scriptFile);
+ }
+ iPtr->scriptFile = objv[2];
+ Tcl_IncrRefCount(iPtr->scriptFile);
+ }
if (iPtr->scriptFile != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), iPtr->scriptFile, -1);
+ Tcl_SetObjResult(interp, iPtr->scriptFile);
}
return TCL_OK;
}
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *version;
+ CONST char *version;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- char *varName, *pattern, *simplePattern;
+ char *varName, *pattern;
+ CONST char *simplePattern;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Var *varPtr;
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Obj *listPtr;
- Tcl_Obj **elemPtrs;
- int listLen, index, result;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "list index");
+ Tcl_Obj *elemPtr; /* Pointer to the element being extracted */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "list ?index...?");
return TCL_ERROR;
}
/*
- * Convert the first argument to a list if necessary.
+ * If objc == 3, then objv[ 2 ] may be either a single index or
+ * a list of indices: go to TclLindexList to determine which.
+ * If objc >= 4, or objc == 2, then objv[ 2 .. objc-2 ] are all
+ * single indices and processed as such in TclLindexFlat.
*/
- listPtr = objv[1];
- result = Tcl_ListObjGetElements(interp, listPtr, &listLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
- }
+ if ( objc == 3 ) {
+
+ elemPtr = TclLindexList( interp, objv[ 1 ], objv[ 2 ] );
+
+ } else {
+ elemPtr = TclLindexFlat( interp, objv[ 1 ], objc-2, objv+2 );
+
+ }
+
/*
- * Get the index from objv[2].
+ * Set the interpreter's object result to the last element extracted
*/
- result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
- &index);
- if (result != TCL_OK) {
- return result;
+ if ( elemPtr == NULL ) {
+ return TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, elemPtr);
+ Tcl_DecrRefCount( elemPtr );
+ return TCL_OK;
}
- if ((index < 0) || (index >= listLen)) {
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLindexList --
+ *
+ * This procedure handles the 'lindex' command when objc==3.
+ *
+ * Results:
+ * Returns a pointer to the object extracted, or NULL if an
+ * error occurred.
+ *
+ * Side effects:
+ * None.
+ *
+ * If objv[1] can be parsed as a list, TclLindexList handles extraction
+ * of the desired element locally. Otherwise, it invokes
+ * TclLindexFlat to treat objv[1] as a scalar.
+ *
+ * The reference count of the returned object includes one reference
+ * corresponding to the pointer returned. Thus, the calling code will
+ * usually do something like:
+ * Tcl_SetObjResult( interp, result );
+ * Tcl_DecrRefCount( result );
+ *
+ *----------------------------------------------------------------------
+ */
+\f
+Tcl_Obj *
+TclLindexList( interp, listPtr, argPtr )
+ Tcl_Interp* interp; /* Tcl interpreter */
+ Tcl_Obj* listPtr; /* List being unpacked */
+ Tcl_Obj* argPtr; /* Index or index list */
+{
+
+ Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */
+ int listLen; /* Length of the list being manipulated. */
+ int index; /* Index into the list */
+ int result; /* Result returned from a Tcl library call */
+ int i; /* Current index number */
+ Tcl_Obj** indices; /* Array of list indices */
+ int indexCount; /* Size of the array of list indices */
+ Tcl_Obj* oldListPtr; /* Temp location to preserve the list
+ * pointer when replacing it with a sublist */
+
+ /*
+ * Determine whether argPtr designates a list or a single index.
+ * We have to be careful about the order of the checks to avoid
+ * repeated shimmering; see TIP#22 and TIP#33 for the details.
+ */
+
+ if ( argPtr->typePtr != &tclListType
+ && TclGetIntForIndex( NULL , argPtr, 0, &index ) == TCL_OK ) {
+
+ /*
+ * argPtr designates a single index.
+ */
+
+ return TclLindexFlat( interp, listPtr, 1, &argPtr );
+
+ } else if ( Tcl_ListObjGetElements( NULL, argPtr, &indexCount, &indices )
+ != TCL_OK ) {
+
/*
- * The index is out of range: the result is an empty string object.
+ * argPtr designates something that is neither an index nor a
+ * well-formed list. Report the error via TclLindexFlat.
*/
- return TCL_OK;
+ return TclLindexFlat( interp, listPtr, 1, &argPtr );
}
/*
- * Make sure listPtr still refers to a list object. It might have been
- * converted to an int above if the argument objects were shared.
+ * Record the reference to the list that we are maintaining in
+ * the activation record.
*/
- if (listPtr->typePtr != &tclListType) {
- result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
- &elemPtrs);
+ Tcl_IncrRefCount( listPtr );
+
+ /*
+ * argPtr designates a list, and the 'else if' above has parsed it
+ * into indexCount and indices.
+ */
+
+ for ( i = 0; i < indexCount; ++i ) {
+
+ /*
+ * Convert the current listPtr to a list if necessary.
+ */
+
+ result = Tcl_ListObjGetElements( interp, listPtr,
+ &listLen, &elemPtrs);
if (result != TCL_OK) {
- return result;
+ Tcl_DecrRefCount( listPtr );
+ return NULL;
}
- }
+
+ /*
+ * Get the index from indices[ i ]
+ */
+
+ result = TclGetIntForIndex( interp, indices[ i ],
+ /*endValue*/ (listLen - 1),
+ &index );
+ if ( result != TCL_OK ) {
+ /*
+ * Index could not be parsed
+ */
+
+ Tcl_DecrRefCount( listPtr );
+ return NULL;
+
+ } else if ( index < 0
+ || index >= listLen ) {
+ /*
+ * Index is out of range
+ */
+ Tcl_DecrRefCount( listPtr );
+ listPtr = Tcl_NewObj();
+ Tcl_IncrRefCount( listPtr );
+ return listPtr;
+ }
+
+ /*
+ * Make sure listPtr still refers to a list object.
+ * If it shared a Tcl_Obj structure with the arguments, then
+ * it might have just been converted to something else.
+ */
+
+ if (listPtr->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount( listPtr );
+ return NULL;
+ }
+ }
+
+ /*
+ * Extract the pointer to the appropriate element
+ */
+
+ oldListPtr = listPtr;
+ listPtr = elemPtrs[ index ];
+ Tcl_IncrRefCount( listPtr );
+ Tcl_DecrRefCount( oldListPtr );
+
+ /*
+ * The work we did above may have caused the internal rep
+ * of *argPtr to change to something else. Get it back.
+ */
+
+ result = Tcl_ListObjGetElements( interp, argPtr,
+ &indexCount, &indices );
+ if ( result != TCL_OK ) {
+ /*
+ * This can't happen unless some extension corrupted a Tcl_Obj.
+ */
+ Tcl_DecrRefCount( listPtr );
+ return NULL;
+ }
+
+ } /* end for */
/*
- * Set the interpreter's object result to the index-th list element.
+ * Return the last object extracted. Its reference count will include
+ * the reference being returned.
*/
- Tcl_SetObjResult(interp, elemPtrs[index]);
- return TCL_OK;
+ return listPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLindexFlat --
+ *
+ * This procedure handles the 'lindex' command, given that the
+ * arguments to the command are known to be a flat list.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ * This procedure is called from either tclExecute.c or
+ * Tcl_LindexObjCmd whenever either is presented with
+ * objc == 2 or objc >= 4. It is also called from TclLindexList
+ * for the objc==3 case once it is determined that objv[2] cannot
+ * be parsed as a list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclLindexFlat( interp, listPtr, indexCount, indexArray )
+ Tcl_Interp* interp; /* Tcl interpreter */
+ Tcl_Obj* listPtr; /* Tcl object representing the list */
+ int indexCount; /* Count of indices */
+ Tcl_Obj* CONST indexArray[];
+ /* Array of pointers to Tcl objects
+ * representing the indices in the
+ * list */
+{
+
+ int i; /* Current list index */
+ int result; /* Result of Tcl library calls */
+ int listLen; /* Length of the current list being
+ * processed */
+ Tcl_Obj** elemPtrs; /* Array of pointers to the elements
+ * of the current list */
+ int index; /* Parsed version of the current element
+ * of indexArray */
+ Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that
+ * its ref count can be decremented. */
+
+ /*
+ * Record the reference to the 'listPtr' object that we are
+ * maintaining in the C activation record.
+ */
+
+ Tcl_IncrRefCount( listPtr );
+
+ for ( i = 0; i < indexCount; ++i ) {
+
+ /*
+ * Convert the current listPtr to a list if necessary.
+ */
+
+ result = Tcl_ListObjGetElements(interp, listPtr,
+ &listLen, &elemPtrs);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount( listPtr );
+ return NULL;
+ }
+
+ /*
+ * Get the index from objv[i]
+ */
+
+ result = TclGetIntForIndex( interp, indexArray[ i ],
+ /*endValue*/ (listLen - 1),
+ &index );
+ if ( result != TCL_OK ) {
+
+ /* Index could not be parsed */
+
+ Tcl_DecrRefCount( listPtr );
+ return NULL;
+
+ } else if ( index < 0
+ || index >= listLen ) {
+
+ /*
+ * Index is out of range
+ */
+
+ Tcl_DecrRefCount( listPtr );
+ listPtr = Tcl_NewObj();
+ Tcl_IncrRefCount( listPtr );
+ return listPtr;
+ }
+
+ /*
+ * Make sure listPtr still refers to a list object.
+ * It might have been converted to something else above
+ * if objv[1] overlaps with one of the other parameters.
+ */
+
+ if (listPtr->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, listPtr, &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount( listPtr );
+ return NULL;
+ }
+ }
+
+ /*
+ * Extract the pointer to the appropriate element
+ */
+
+ oldListPtr = listPtr;
+ listPtr = elemPtrs[ index ];
+ Tcl_IncrRefCount( listPtr );
+ Tcl_DecrRefCount( oldListPtr );
+
+ }
+
+ return listPtr;
+
}
\f
/*
register int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Obj *listPtr, *resultPtr;
- Tcl_ObjType *typePtr;
+ Tcl_Obj *listPtr;
int index, isDuplicate, len, result;
-
+
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
return TCL_ERROR;
}
- /*
- * Get the index first since, if a conversion to int is needed, it
- * will invalidate the list's internal representation.
- */
-
result = Tcl_ListObjLength(interp, objv[1], &len);
if (result != TCL_OK) {
return result;
}
- result = TclGetIntForIndex(interp, objv[2], /*endValue*/ len, &index);
+ /*
+ * Get the index. "end" is interpreted to be the index after the last
+ * element, such that using it will cause any inserted elements to be
+ * appended to the list.
+ */
+
+ result = TclGetIntForIndex(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
+ if (index > len) {
+ index = len;
+ }
/*
* If the list object is unshared we can modify it directly. Otherwise
- * we create a copy to modify: this is "copy on write". We create the
- * duplicate directly in the interpreter's object result.
+ * we create a copy to modify: this is "copy on write".
*/
-
+
listPtr = objv[1];
isDuplicate = 0;
if (Tcl_IsShared(listPtr)) {
- /*
- * The following code must reflect the logic in Tcl_DuplicateObj()
- * except that it must duplicate the list object directly into the
- * interpreter's result.
- */
-
- Tcl_ResetResult(interp);
- resultPtr = Tcl_GetObjResult(interp);
- typePtr = listPtr->typePtr;
- if (listPtr->bytes == NULL) {
- resultPtr->bytes = NULL;
- } else if (listPtr->bytes != tclEmptyStringRep) {
- len = listPtr->length;
- TclInitStringRep(resultPtr, listPtr->bytes, len);
- }
- if (typePtr != NULL) {
- if (typePtr->dupIntRepProc == NULL) {
- resultPtr->internalRep = listPtr->internalRep;
- resultPtr->typePtr = typePtr;
- } else {
- (*typePtr->dupIntRepProc)(listPtr, resultPtr);
- }
- }
- listPtr = resultPtr;
+ listPtr = Tcl_DuplicateObj(listPtr);
isDuplicate = 1;
}
-
- if ((objc == 4) && (index == INT_MAX)) {
+
+ if ((objc == 4) && (index == len)) {
/*
* Special case: insert one element at the end of the list.
*/
-
result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]);
} else if (objc > 3) {
result = Tcl_ListObjReplace(interp, listPtr, index, 0,
(objc-3), &(objv[3]));
}
if (result != TCL_OK) {
+ if (isDuplicate) {
+ Tcl_DecrRefCount(listPtr); /* free unneeded obj */
+ }
return result;
}
* Set the interpreter's object result.
*/
- if (!isDuplicate) {
- Tcl_SetObjResult(interp, listPtr);
- }
+ Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
\f
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *listPtr;
- int createdNewObj, first, last, listLen, numToDelete;
- int firstArgLen, result;
- char *firstArg;
+ int isDuplicate, first, last, listLen, numToDelete, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
return TCL_ERROR;
}
- /*
- * If the list object is unshared we can modify it directly, otherwise
- * we create a copy to modify: this is "copy on write".
- */
-
- listPtr = objv[1];
- createdNewObj = 0;
- if (Tcl_IsShared(listPtr)) {
- listPtr = Tcl_DuplicateObj(listPtr);
- createdNewObj = 1;
- }
- result = Tcl_ListObjLength(interp, listPtr, &listLen);
+ result = Tcl_ListObjLength(interp, objv[1], &listLen);
if (result != TCL_OK) {
- errorReturn:
- if (createdNewObj) {
- Tcl_DecrRefCount(listPtr); /* free unneeded obj */
- }
return result;
}
/*
- * Get the first and last indexes.
+ * Get the first and last indexes. "end" is interpreted to be the index
+ * for the last element, such that using it will cause that element to
+ * be included for deletion.
*/
- result = TclGetIntForIndex(interp, objv[2], /*endValue*/ (listLen - 1),
- &first);
+ result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first);
if (result != TCL_OK) {
- goto errorReturn;
+ return result;
}
- firstArg = Tcl_GetStringFromObj(objv[2], &firstArgLen);
- result = TclGetIntForIndex(interp, objv[3], /*endValue*/ (listLen - 1),
- &last);
+ result = TclGetIntForIndex(interp, objv[3], /*end*/ (listLen - 1), &last);
if (result != TCL_OK) {
- goto errorReturn;
+ return result;
}
if (first < 0) {
first = 0;
}
- if ((first >= listLen) && (listLen > 0)
- && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
+
+ /*
+ * Complain if the user asked for a start element that is greater than the
+ * list length. This won't ever trigger for the "end*" case as that will
+ * be properly constrained by TclGetIntForIndex because we use listLen-1
+ * (to allow for replacing the last elem).
+ */
+
+ if ((first >= listLen) && (listLen > 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"list doesn't contain element ",
Tcl_GetString(objv[2]), (int *) NULL);
- result = TCL_ERROR;
- goto errorReturn;
+ return TCL_ERROR;
}
if (last >= listLen) {
last = (listLen - 1);
numToDelete = 0;
}
+ /*
+ * If the list object is unshared we can modify it directly, otherwise
+ * we create a copy to modify: this is "copy on write".
+ */
+
+ listPtr = objv[1];
+ isDuplicate = 0;
+ if (Tcl_IsShared(listPtr)) {
+ listPtr = Tcl_DuplicateObj(listPtr);
+ isDuplicate = 1;
+ }
if (objc > 4) {
result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
(objc-4), &(objv[4]));
0, NULL);
}
if (result != TCL_OK) {
- goto errorReturn;
+ if (isDuplicate) {
+ Tcl_DecrRefCount(listPtr); /* free unneeded obj */
+ }
+ return result;
}
/*
{
char *bytes, *patternBytes;
int i, match, mode, index, result, listc, length, elemLen;
- Tcl_Obj *patObj, **listv;
- static char *options[] = {
- "-exact", "-glob", "-regexp", NULL
+ int dataType, isIncreasing, lower, upper, patInt, objInt;
+ int offset, allMatches, inlineReturn, negatedMatch;
+ double patDouble, objDouble;
+ Tcl_Obj *patObj, **listv, *listPtr, *startPtr;
+ static CONST char *options[] = {
+ "-all", "-ascii", "-decreasing", "-dictionary",
+ "-exact", "-glob", "-increasing", "-inline",
+ "-integer", "-not", "-real", "-regexp",
+ "-sorted", "-start", NULL
};
enum options {
- LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_REGEXP
+ LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_DECREASING, LSEARCH_DICTIONARY,
+ LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INLINE,
+ LSEARCH_INTEGER, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP,
+ LSEARCH_SORTED, LSEARCH_START
};
+ enum datatypes {
+ ASCII, DICTIONARY, INTEGER, REAL
+ };
+ enum modes {
+ EXACT, GLOB, REGEXP, SORTED
+ };
+
+ mode = GLOB;
+ dataType = ASCII;
+ isIncreasing = 1;
+ allMatches = 0;
+ inlineReturn = 0;
+ negatedMatch = 0;
+ listPtr = NULL;
+ startPtr = NULL;
+ offset = 0;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? list pattern");
+ return TCL_ERROR;
+ }
- mode = LSEARCH_GLOB;
- if (objc == 4) {
- if (Tcl_GetIndexFromObj(interp, objv[1], options, "search mode", 0,
- &mode) != TCL_OK) {
+ for (i = 1; i < objc-2; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
+ != TCL_OK) {
+ if (startPtr) {
+ Tcl_DecrRefCount(startPtr);
+ }
return TCL_ERROR;
}
- } else if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "?mode? list pattern");
- return TCL_ERROR;
+ switch ((enum options) index) {
+ case LSEARCH_ALL: /* -all */
+ allMatches = 1;
+ break;
+ case LSEARCH_ASCII: /* -ascii */
+ dataType = ASCII;
+ break;
+ case LSEARCH_DECREASING: /* -decreasing */
+ isIncreasing = 0;
+ break;
+ case LSEARCH_DICTIONARY: /* -dictionary */
+ dataType = DICTIONARY;
+ break;
+ case LSEARCH_EXACT: /* -increasing */
+ mode = EXACT;
+ break;
+ case LSEARCH_GLOB: /* -glob */
+ mode = GLOB;
+ break;
+ case LSEARCH_INCREASING: /* -increasing */
+ isIncreasing = 1;
+ break;
+ case LSEARCH_INLINE: /* -inline */
+ inlineReturn = 1;
+ break;
+ case LSEARCH_INTEGER: /* -integer */
+ dataType = INTEGER;
+ break;
+ case LSEARCH_NOT: /* -not */
+ negatedMatch = 1;
+ break;
+ case LSEARCH_REAL: /* -real */
+ dataType = REAL;
+ break;
+ case LSEARCH_REGEXP: /* -regexp */
+ mode = REGEXP;
+ break;
+ case LSEARCH_SORTED: /* -sorted */
+ mode = SORTED;
+ break;
+ case LSEARCH_START: /* -start */
+ /*
+ * If there was a previous -start option, release its saved
+ * index because it will either be replaced or there will be
+ * an error.
+ */
+ if (startPtr) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ if (i > objc-4) {
+ Tcl_AppendResult(interp, "missing starting index", NULL);
+ return TCL_ERROR;
+ }
+ i++;
+ if (objv[i] == objv[objc - 2]) {
+ /*
+ * Take copy to prevent shimmering problems. Note
+ * that it does not matter if the index obj is also a
+ * component of the list being searched. We only need
+ * to copy where the list and the index are
+ * one-and-the-same.
+ */
+ startPtr = Tcl_DuplicateObj(objv[i]);
+ } else {
+ startPtr = objv[i];
+ Tcl_IncrRefCount(startPtr);
+ }
+ }
}
/*
result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
+ if (startPtr) {
+ Tcl_DecrRefCount(startPtr);
+ }
return result;
}
+ /*
+ * Get the user-specified start offset.
+ */
+ if (startPtr) {
+ result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
+ Tcl_DecrRefCount(startPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (offset < 0) {
+ offset = 0;
+ } else if (offset > listc-1) {
+ offset = listc-1;
+ }
+ }
+
patObj = objv[objc - 1];
- patternBytes = Tcl_GetStringFromObj(patObj, &length);
+ patternBytes = NULL;
+ if ((enum modes) mode == EXACT || (enum modes) mode == SORTED) {
+ switch ((enum datatypes) dataType) {
+ case ASCII:
+ case DICTIONARY:
+ patternBytes = Tcl_GetStringFromObj(patObj, &length);
+ break;
+ case INTEGER:
+ result = Tcl_GetIntFromObj(interp, patObj, &patInt);
+ if (result != TCL_OK) {
+ return result;
+ }
+ break;
+ case REAL:
+ result = Tcl_GetDoubleFromObj(interp, patObj, &patDouble);
+ if (result != TCL_OK) {
+ return result;
+ }
+ break;
+ }
+ } else {
+ patternBytes = Tcl_GetStringFromObj(patObj, &length);
+ }
+ /*
+ * Set default index value to -1, indicating failure; if we find the
+ * item in the course of our search, index will be set to the correct
+ * value.
+ */
index = -1;
- for (i = 0; i < listc; i++) {
- match = 0;
- switch ((enum options) mode) {
- case LSEARCH_EXACT: {
- bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
- if (length == elemLen) {
- match = (memcmp(bytes, patternBytes,
- (size_t) length) == 0);
+ match = 0;
+
+ if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) {
+ /*
+ * If the data is sorted, we can do a more intelligent search.
+ * Note that there is no point in being smart when -all was
+ * specified; in that case, we have to look at all items anyway,
+ * and there is no sense in doing this when the match sense is
+ * inverted.
+ */
+ lower = offset - 1;
+ upper = listc;
+ while (lower + 1 != upper) {
+ i = (lower + upper)/2;
+ switch ((enum datatypes) dataType) {
+ case ASCII:
+ bytes = Tcl_GetString(listv[i]);
+ match = strcmp(patternBytes, bytes);
+ break;
+ case DICTIONARY:
+ bytes = Tcl_GetString(listv[i]);
+ match = DictionaryCompare(patternBytes, bytes);
+ break;
+ case INTEGER:
+ result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (patInt == objInt) {
+ match = 0;
+ } else if (patInt < objInt) {
+ match = -1;
+ } else {
+ match = 1;
}
break;
- }
- case LSEARCH_GLOB: {
- match = Tcl_StringMatch(Tcl_GetString(listv[i]), patternBytes);
+ case REAL:
+ result = Tcl_GetDoubleFromObj(interp, listv[i], &objDouble);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (patDouble == objDouble) {
+ match = 0;
+ } else if (patDouble < objDouble) {
+ match = -1;
+ } else {
+ match = 1;
+ }
break;
}
- case LSEARCH_REGEXP: {
+ if (match == 0) {
+ /*
+ * Normally, binary search is written to stop when it
+ * finds a match. If there are duplicates of an element in
+ * the list, our first match might not be the first occurance.
+ * Consider: 0 0 0 1 1 1 2 2 2
+ * To maintain consistancy with standard lsearch semantics,
+ * we must find the leftmost occurance of the pattern in the
+ * list. Thus we don't just stop searching here. This
+ * variation means that a search always makes log n
+ * comparisons (normal binary search might "get lucky" with
+ * an early comparison).
+ */
+ index = i;
+ upper = i;
+ } else if (match > 0) {
+ if (isIncreasing) {
+ lower = i;
+ } else {
+ upper = i;
+ }
+ } else {
+ if (isIncreasing) {
+ upper = i;
+ } else {
+ lower = i;
+ }
+ }
+ }
+
+ } else {
+ /*
+ * We need to do a linear search, because (at least one) of:
+ * - our matcher can only tell equal vs. not equal
+ * - our matching sense is negated
+ * - we're building a list of all matched items
+ */
+ if (allMatches) {
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ }
+ for (i = offset; i < listc; i++) {
+ match = 0;
+ switch ((enum modes) mode) {
+ case SORTED:
+ case EXACT:
+ switch ((enum datatypes) dataType) {
+ case ASCII:
+ bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
+ if (length == elemLen) {
+ match = (memcmp(bytes, patternBytes,
+ (size_t) length) == 0);
+ }
+ break;
+ case DICTIONARY:
+ bytes = Tcl_GetString(listv[i]);
+ match = (DictionaryCompare(bytes, patternBytes) == 0);
+ break;
+ case INTEGER:
+ result = Tcl_GetIntFromObj(interp, listv[i], &objInt);
+ if (result != TCL_OK) {
+ if (listPtr) {
+ Tcl_DecrRefCount(listPtr);
+ }
+ return result;
+ }
+ match = (objInt == patInt);
+ break;
+ case REAL:
+ result = Tcl_GetDoubleFromObj(interp, listv[i],
+ &objDouble);
+ if (result != TCL_OK) {
+ if (listPtr) {
+ Tcl_DecrRefCount(listPtr);
+ }
+ return result;
+ }
+ match = (objDouble == patDouble);
+ break;
+ }
+ break;
+ case GLOB:
+ match = Tcl_StringMatch(Tcl_GetString(listv[i]),
+ patternBytes);
+ break;
+ case REGEXP:
match = Tcl_RegExpMatchObj(interp, listv[i], patObj);
if (match < 0) {
+ if (listPtr) {
+ Tcl_DecrRefCount(listPtr);
+ }
return TCL_ERROR;
}
break;
}
+ /*
+ * Invert match condition for -not
+ */
+ if (negatedMatch) {
+ match = !match;
+ }
+ if (match != 0) {
+ if (!allMatches) {
+ index = i;
+ break;
+ } else if (inlineReturn) {
+ /*
+ * Note that these appends are not expected to fail.
+ */
+ Tcl_ListObjAppendElement(interp, listPtr, listv[i]);
+ } else {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewIntObj(i));
+ }
+ }
}
- if (match != 0) {
- index = i;
- break;
- }
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
+
+ /*
+ * Return everything or a single value.
+ */
+ if (allMatches) {
+ Tcl_SetObjResult(interp, listPtr);
+ } else if (!inlineReturn) {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
+ } else if (index < 0) {
+ /*
+ * Is this superfluous? The result should be a blank object
+ * by default...
+ */
+ Tcl_SetObjResult(interp, Tcl_NewObj());
+ } else {
+ Tcl_SetObjResult(interp, listv[index]);
+ }
return TCL_OK;
}
\f
/*
*----------------------------------------------------------------------
*
+ * Tcl_LsetObjCmd --
+ *
+ * This procedure is invoked to process the "lset" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_LsetObjCmd( clientData, interp, objc, objv )
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument values. */
+{
+
+ Tcl_Obj* listPtr; /* Pointer to the list being altered. */
+ Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */
+
+ /* Check parameter count */
+
+ if ( objc < 3 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" );
+ return TCL_ERROR;
+ }
+
+ /* Look up the list variable's value */
+
+ listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL,
+ TCL_LEAVE_ERR_MSG );
+ if ( listPtr == NULL ) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Substitute the value in the value. Return either the value or
+ * else an unshared copy of it.
+ */
+
+ if ( objc == 4 ) {
+ finalValuePtr = TclLsetList( interp, listPtr,
+ objv[ 2 ], objv[ 3 ] );
+ } else {
+ finalValuePtr = TclLsetFlat( interp, listPtr,
+ objc-3, objv+2, objv[ objc-1 ] );
+ }
+
+ /*
+ * If substitution has failed, bail out.
+ */
+
+ if ( finalValuePtr == NULL ) {
+ return TCL_ERROR;
+ }
+
+ /* Finally, update the variable so that traces fire. */
+
+ listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr,
+ TCL_LEAVE_ERR_MSG );
+ Tcl_DecrRefCount( finalValuePtr );
+ if ( listPtr == NULL ) {
+ return TCL_ERROR;
+ }
+
+ /* Return the new value of the variable as the interpreter result. */
+
+ Tcl_SetObjResult( interp, listPtr );
+ return TCL_OK;
+
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_LsortObjCmd --
*
* This procedure is invoked to process the "lsort" Tcl command.
SortInfo sortInfo; /* Information about this sort that
* needs to be passed to the
* comparison function */
- static char *switches[] = {
+ static CONST char *switches[] = {
"-ascii", "-command", "-decreasing", "-dictionary", "-increasing",
"-index", "-integer", "-real", "-unique", (char *) NULL
};
sortInfo.isIncreasing = 1;
sortInfo.sortMode = SORTMODE_ASCII;
- sortInfo.index = -1;
+ sortInfo.index = SORTIDX_NONE;
sortInfo.interp = interp;
sortInfo.resultCode = TCL_OK;
cmdPtr = NULL;
-1);
return TCL_ERROR;
}
- if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
- != TCL_OK) {
+ if (TclGetIntForIndex(interp, objv[i+1], SORTIDX_END,
+ &sortInfo.index) != TCL_OK) {
return TCL_ERROR;
}
- cmdPtr = objv[i+1];
i++;
break;
case 6: /* -integer */
sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
&length, &listObjPtrs);
- if (sortInfo.resultCode != TCL_OK) {
+ if (sortInfo.resultCode != TCL_OK || length <= 0) {
goto done;
}
- if (length <= 0) {
- return TCL_OK;
- }
elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
for (i=0; i < length; i++){
elementArray[i].objPtr = listObjPtrs[i];
return order;
}
- if (infoPtr->index != -1) {
+ if (infoPtr->index != SORTIDX_NONE) {
/*
* The "-index" option was specified. Treat each object as a
* list, extract the requested element from each list, and
- * compare the elements, not the lists. The special index "end"
- * is signaled here with a large negative index.
+ * compare the elements, not the lists. "end"-relative indices
+ * are signaled here with large negative values.
*/
if (Tcl_ListObjLength(infoPtr->interp, objPtr1, &listLen) != TCL_OK) {
infoPtr->resultCode = TCL_ERROR;
return order;
}
- if (infoPtr->index < -1) {
- index = listLen - 1;
+ if (infoPtr->index < SORTIDX_NONE) {
+ index = listLen + infoPtr->index + 1;
} else {
index = infoPtr->index;
}
infoPtr->resultCode = TCL_ERROR;
return order;
}
- if (infoPtr->index < -1) {
- index = listLen - 1;
+ if (infoPtr->index < SORTIDX_NONE) {
+ index = listLen + infoPtr->index + 1;
} else {
index = infoPtr->index;
}
}
return diff;
}
-
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 1998-2000 Scriptics Corporation.
+ * Copyright (c) 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#include "tclInt.h"
#include "tclPort.h"
-#include "tclCompile.h"
#include "tclRegexp.h"
/*
- * Flag values used by Tcl_ScanObjCmd.
+ * Structure used to hold information about variable traces:
*/
-#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */
-#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */
-#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
-#define SCAN_WIDTH 0x8 /* A width value was supplied. */
-
-#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */
-#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */
-#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */
-#define SCAN_XOK 0x80 /* An 'x' is allowed. */
-#define SCAN_PTOK 0x100 /* Decimal point is allowed. */
-#define SCAN_EXPOK 0x200 /* An exponent is allowed. */
+typedef struct {
+ int flags; /* Operations for which Tcl command is
+ * to be invoked. */
+ size_t length; /* Number of non-NULL chars. in command. */
+ char command[4]; /* Space for Tcl command to invoke. Actual
+ * size will be as large as necessary to
+ * hold command. This field must be the
+ * last in the structure, so that it can
+ * be larger than 4 bytes. */
+} TraceVarInfo;
/*
- * Structure used to hold information about variable traces:
+ * Structure used to hold information about command traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
- char *errMsg; /* Error message returned from Tcl command,
- * or NULL. Malloc'ed. */
size_t length; /* Number of non-NULL chars. in command. */
+ Tcl_Trace stepTrace; /* Used for execution traces, when tracing
+ * inside the given command */
+ int startLevel; /* Used for bookkeeping with step execution
+ * traces, store the level at which the step
+ * trace was invoked */
+ char *startCmd; /* Used for bookkeeping with step execution
+ * traces, store the command name which invoked
+ * step trace */
+ int curFlags; /* Trace flags for the current command */
+ int curCode; /* Return code for the current command */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
* last in the structure, so that it can
* be larger than 4 bytes. */
-} TraceVarInfo;
+} TraceCommandInfo;
+
+/*
+ * Used by command execution traces. Note that we assume in the code
+ * that the first two defines are exactly 4 times the
+ * 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
+ *
+ * TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command
+ * currently being traced, before execution.
+ * TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command
+ * currently being traced, after execution.
+ * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags.
+ * TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace
+ * is currently executing. Therefore we
+ * don't let further traces execute.
+ * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly
+ * by the command being traced, not because
+ * of an internal trace.
+ * The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
+ * be used in command execution traces.
+ */
+#define TCL_TRACE_ENTER_DURING_EXEC 4
+#define TCL_TRACE_LEAVE_DURING_EXEC 8
+#define TCL_TRACE_ANY_EXEC 15
+#define TCL_TRACE_EXEC_IN_PROGRESS 0x10
+#define TCL_TRACE_EXEC_DIRECT 0x20
/*
* Forward declarations for procedures defined in this file:
*/
+typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
+ int optionIndex, int objc, Tcl_Obj *CONST objv[]));
+
+Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
+Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
+Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;
+
+/*
+ * Each subcommand has a number of 'types' to which it can apply.
+ * Currently 'execution', 'command' and 'variable' are the only
+ * types supported. These three arrays MUST be kept in sync!
+ * In the future we may provide an API to add to the list of
+ * supported trace types.
+ */
+static CONST char *traceTypeOptions[] = {
+ "execution", "command", "variable", (char*) NULL
+};
+static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
+ TclTraceExecutionObjCmd,
+ TclTraceCommandObjCmd,
+ TclTraceVariableObjCmd,
+};
+
+/*
+ * Declarations for local procedures to this file:
+ */
+static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
+ Trace *tracePtr, Command *cmdPtr,
+ CONST char *command, int numChars,
+ int objc, Tcl_Obj *CONST objv[]));
static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, char *name1, char *name2,
- int flags));
-\f
+ Tcl_Interp *interp, CONST char *name1,
+ CONST char *name2, int flags));
+static void TraceCommandProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, CONST char *oldName,
+ CONST char *newName, int flags));
+static Tcl_CmdObjTraceProc TraceExecutionProc;
+
/*
*----------------------------------------------------------------------
*
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_DString ds;
+ Tcl_Obj *retVal;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
- if (Tcl_GetCwd(interp, &ds) == NULL) {
+ retVal = Tcl_FSGetCwd(interp);
+ if (retVal == NULL) {
return TCL_ERROR;
}
- Tcl_DStringResult(interp, &ds);
+ Tcl_SetObjResult(interp, retVal);
+ Tcl_DecrRefCount(retVal);
return TCL_OK;
}
\f
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *resultPtr;
Tcl_RegExpInfo info;
- static char *options[] = {
+ static CONST char *options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", (char *) NULL
return TCL_ERROR;
}
- regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
- if (regExpr == NULL) {
- return TCL_ERROR;
- }
- objPtr = objv[1];
-
+ /*
+ * Handle the odd about case separately.
+ */
if (about) {
- if (TclRegAbout(interp, regExpr) < 0) {
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+ if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
return TCL_ERROR;
}
return TCL_OK;
}
+ /*
+ * Get the length of the string that we are matching against so
+ * we can do the termination test for -all matches. Do this before
+ * getting the regexp to avoid shimmering problems.
+ */
+ objPtr = objv[1];
+ stringLength = Tcl_GetCharLength(objPtr);
+
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+ if (regExpr == NULL) {
+ return TCL_ERROR;
+ }
+
if (offset > 0) {
/*
* Add flag if using offset (string is part of a larger string),
}
/*
- * Get the length of the string that we are matching against so
- * we can do the termination test for -all matches.
- */
- stringLength = Tcl_GetCharLength(objPtr);
-
- /*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match. If "-all"
* hasn't been specified then the loop body only gets executed once.
int start, end;
Tcl_Obj *objs[2];
- if (i <= info.nsubs) {
+ /*
+ * Only adjust the match area if there was a match for
+ * that area. (Scriptics Bug 4391/SF Bug #219232)
+ */
+ if (i <= info.nsubs && info.matches[i].start >= 0) {
start = offset + info.matches[i].start;
end = offset + info.matches[i].end;
}
offset += info.matches[0].end;
all++;
+ eflags |= TCL_REG_NOTBOL;
if (offset >= stringLength) {
break;
}
* Set the interpreter's object result to an integer object
* with value 1 if -all wasn't specified, otherwise it's all-1
* (the number of times through the while - 1).
+ * Get the resultPtr again as the Tcl_ObjSetVar2 above may have
+ * cause the result to change. [Patch #558324] (watson).
*/
if (!doinline) {
+ resultPtr = Tcl_GetObjResult(interp);
Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
}
return TCL_OK;
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int i, result, cflags, all, wlen, numMatches, offset;
+ int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
+ int start, end, subStart, subEnd, match;
Tcl_RegExp regExpr;
- Tcl_Obj *resultPtr, *varPtr, *objPtr;
- Tcl_UniChar *wstring;
- char *subspec;
+ Tcl_RegExpInfo info;
+ Tcl_Obj *resultPtr, *subPtr, *objPtr;
+ Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
- static char *options[] = {
+ static CONST char *options[] = {
"-all", "-nocase", "-expanded",
"-line", "-linestop", "-lineanchor", "-start",
"--", NULL
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
+ resultPtr = NULL;
- for (i = 1; i < objc; i++) {
+ for (idx = 1; idx < objc; idx++) {
char *name;
int index;
- name = Tcl_GetString(objv[i]);
+ name = Tcl_GetString(objv[idx]);
if (name[0] != '-') {
break;
}
- if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
- &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
+ TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
break;
}
case REGSUB_START: {
- if (++i >= objc) {
+ if (++idx >= objc) {
goto endOfForLoop;
}
- if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
return TCL_ERROR;
}
if (offset < 0) {
break;
}
case REGSUB_LAST: {
- i++;
+ idx++;
goto endOfForLoop;
}
}
}
endOfForLoop:
- if (objc - i != 4) {
+ if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? exp string subSpec varName");
+ "?switches? exp string subSpec ?varName?");
return TCL_ERROR;
}
- objv += i;
+ objc -= idx;
+ objv += idx;
+
+ if (all && (offset == 0)
+ && (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL)
+ && (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
+ /*
+ * This is a simple one pair string map situation. We make use of
+ * a slightly modified version of the one pair STR_MAP code.
+ */
+ int slen, nocase;
+ int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *,
+ unsigned long));
+ Tcl_UniChar *p, wsrclc;
+
+ numMatches = 0;
+ nocase = (cflags & TCL_REG_NOCASE);
+ strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
+
+ wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
+ wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
+ wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
+ wend = wstring + wlen - (slen ? slen - 1 : 0);
+ result = TCL_OK;
+
+ if (slen == 0) {
+ /*
+ * regsub behavior for "" matches between each character.
+ * 'string map' skips the "" case.
+ */
+ if (wstring < wend) {
+ resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ Tcl_IncrRefCount(resultPtr);
+ for (; wstring < wend; wstring++) {
+ Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
+ Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
+ numMatches++;
+ }
+ wlen = 0;
+ }
+ } else {
+ wsrclc = Tcl_UniCharToLower(*wsrc);
+ for (p = wfirstChar = wstring; wstring < wend; wstring++) {
+ if (((*wstring == *wsrc) ||
+ (nocase && (Tcl_UniCharToLower(*wstring) ==
+ wsrclc))) &&
+ ((slen == 1) || (strCmpFn(wstring, wsrc,
+ (unsigned long) slen) == 0))) {
+ if (numMatches == 0) {
+ resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ Tcl_IncrRefCount(resultPtr);
+ }
+ if (p != wstring) {
+ Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
+ p = wstring + slen;
+ } else {
+ p += slen;
+ }
+ wstring = p - 1;
+
+ Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
+ numMatches++;
+ }
+ }
+ if (numMatches) {
+ wlen = wfirstChar + wlen - p;
+ wstring = p;
+ }
+ }
+ objPtr = NULL;
+ subPtr = NULL;
+ goto regsubDone;
+ }
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
- result = TCL_OK;
- resultPtr = Tcl_NewObj();
- Tcl_IncrRefCount(resultPtr);
+ /*
+ * Make sure to avoid problems where the objects are shared. This
+ * can cause RegExpObj <> UnicodeObj shimmering that causes data
+ * corruption. [Bug #461322]
+ */
- objPtr = objv[1];
- wlen = Tcl_GetCharLength(objPtr);
- wstring = Tcl_GetUnicode(objPtr);
- subspec = Tcl_GetString(objv[2]);
- varPtr = objv[3];
+ if (objv[1] == objv[0]) {
+ objPtr = Tcl_DuplicateObj(objv[1]);
+ } else {
+ objPtr = objv[1];
+ }
+ wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
+ if (objv[2] == objv[0]) {
+ subPtr = Tcl_DuplicateObj(objv[2]);
+ } else {
+ subPtr = objv[2];
+ }
+ wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
+
+ result = TCL_OK;
/*
* The following loop is to handle multiple matches within the
numMatches = 0;
for ( ; offset < wlen; ) {
- int start, end, subStart, subEnd, match;
- char *src, *firstChar;
- char c;
- Tcl_RegExpInfo info;
/*
* The flags argument is set if string is part of a larger string,
if (match == 0) {
break;
}
- if ((numMatches == 0) && (offset > 0)) {
- /* Copy the initial portion of the string in if an offset
- * was specified.
- */
- Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
+ if (numMatches == 0) {
+ resultPtr = Tcl_NewUnicodeObj(wstring, 0);
+ Tcl_IncrRefCount(resultPtr);
+ if (offset > 0) {
+ /*
+ * Copy the initial portion of the string in if an offset
+ * was specified.
+ */
+ Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
+ }
}
numMatches++;
* subSpec to reduce the number of calls to Tcl_SetVar.
*/
- src = subspec;
- firstChar = subspec;
- for (c = *src; c != '\0'; src++, c = *src) {
- int index;
-
- if (c == '&') {
- index = 0;
- } else if (c == '\\') {
- c = src[1];
- if ((c >= '0') && (c <= '9')) {
- index = c - '0';
- } else if ((c == '\\') || (c == '&')) {
- Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
- Tcl_AppendToObj(resultPtr, &c, 1);
- firstChar = src + 2;
- src++;
+ wsrc = wfirstChar = wsubspec;
+ wend = wsubspec + wsublen;
+ for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) {
+ if (ch == '&') {
+ idx = 0;
+ } else if (ch == '\\') {
+ ch = wsrc[1];
+ if ((ch >= '0') && (ch <= '9')) {
+ idx = ch - '0';
+ } else if ((ch == '\\') || (ch == '&')) {
+ *wsrc = ch;
+ Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+ wsrc - wfirstChar + 1);
+ *wsrc = '\\';
+ wfirstChar = wsrc + 2;
+ wsrc++;
continue;
} else {
continue;
} else {
continue;
}
- if (firstChar != src) {
- Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
+ if (wfirstChar != wsrc) {
+ Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
+ wsrc - wfirstChar);
}
- if (index <= info.nsubs) {
- subStart = info.matches[index].start;
- subEnd = info.matches[index].end;
+ if (idx <= info.nsubs) {
+ subStart = info.matches[idx].start;
+ subEnd = info.matches[idx].end;
if ((subStart >= 0) && (subEnd >= 0)) {
Tcl_AppendUnicodeToObj(resultPtr,
wstring + offset + subStart, subEnd - subStart);
}
}
- if (*src == '\\') {
- src++;
+ if (*wsrc == '\\') {
+ wsrc++;
}
- firstChar = src + 1;
+ wfirstChar = wsrc + 1;
}
- if (firstChar != src) {
- Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
+ if (wfirstChar != wsrc) {
+ Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
}
if (end == 0) {
/*
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
offset++;
+ } else {
+ offset += end;
}
- offset += end;
if (!all) {
break;
}
* Copy the portion of the source string after the last match to the
* result variable.
*/
-
+ regsubDone:
if (numMatches == 0) {
/*
* On zero matches, just ignore the offset, since it shouldn't
* matter to us in this case, and the user may have skewed it.
*/
- Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen);
+ resultPtr = objv[1];
+ Tcl_IncrRefCount(resultPtr);
} else if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
}
- if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) {
- Tcl_AppendResult(interp, "couldn't set variable \"",
- Tcl_GetString(varPtr), "\"", (char *) NULL);
- result = TCL_ERROR;
+ if (objc == 4) {
+ if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
+ Tcl_AppendResult(interp, "couldn't set variable \"",
+ Tcl_GetString(objv[3]), "\"", (char *) NULL);
+ result = TCL_ERROR;
+ } else {
+ /*
+ * Set the interpreter's object result to an integer object
+ * holding the number of matches.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
+ }
} else {
/*
- * Set the interpreter's object result to an integer object holding the
- * number of matches.
+ * No varname supplied, so just return the modified string.
*/
-
- Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
+ Tcl_SetObjResult(interp, resultPtr);
}
done:
- Tcl_DecrRefCount(resultPtr);
+ if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); }
+ if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); }
+ if (resultPtr) { Tcl_DecrRefCount(resultPtr); }
return result;
}
\f
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *bytes;
- int result;
-
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
- bytes = Tcl_GetString(objv[1]);
- result = Tcl_EvalFile(interp, bytes);
- return result;
+ return Tcl_FSEvalFile(interp, objv[1]);
}
\f
/*
* Do nothing.
*/
} else if (splitCharLen == 0) {
+ Tcl_HashTable charReuseTable;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
/*
* Handle the special case of splitting on every character.
+ *
+ * Uses a hash table to ensure that each kind of character has
+ * only one Tcl_Obj instance (multiply-referenced) in the
+ * final list. This is a *major* win when splitting on a long
+ * string (especially in the megabyte range!) - DKF
*/
+ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; string < end; string += len) {
len = Tcl_UtfToUniChar(string, &ch);
- objPtr = Tcl_NewStringObj(string, len);
+ /* Assume Tcl_UniChar is an integral type... */
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
+ if (isNew) {
+ objPtr = Tcl_NewStringObj(string, len);
+ /* Don't need to fiddle with refcount... */
+ Tcl_SetHashValue(hPtr, (ClientData) objPtr);
+ } else {
+ objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
+ }
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
+ Tcl_DeleteHashTable(&charReuseTable);
} else {
char *element, *p, *splitEnd;
int splitLen;
* that this command only functions correctly on properly formed
* Tcl UTF strings.
*
+ * Note that the primary methods here (equal, compare, match, ...)
+ * have bytecode equivalents. You will find the code for those in
+ * tclExecute.c. The code here will only be used in the non-bc
+ * case (like in an 'eval').
+ *
* Results:
* A standard Tcl result.
*
Tcl_Obj *resultPtr;
char *string1, *string2;
int length1, length2;
- static char *options[] = {
+ static CONST char *options[] = {
"bytelength", "compare", "equal", "first",
"index", "is", "last", "length",
"map", "match", "range", "repeat",
switch ((enum options) index) {
case STR_EQUAL:
case STR_COMPARE: {
+ /*
+ * Remember to keep code here in some sync with the
+ * byte-compiled versions in tclExecute.c (INST_STR_EQ,
+ * INST_STR_NEQ and INST_STR_CMP as well as the expr string
+ * comparison in INST_EQ/INST_NEQ/INST_LT/...).
+ */
int i, match, length, nocase = 0, reqlength = -1;
+ int (*strCmpFn)();
if (objc < 4 || objc > 7) {
str_cmp_args:
for (i = 2; i < objc-2; i++) {
string2 = Tcl_GetStringFromObj(objv[i], &length2);
if ((length2 > 1)
- && strncmp(string2, "-nocase", (size_t) length2) == 0) {
+ && strncmp(string2, "-nocase", (size_t)length2) == 0) {
nocase = 1;
} else if ((length2 > 1)
- && strncmp(string2, "-length", (size_t) length2) == 0) {
+ && strncmp(string2, "-length", (size_t)length2) == 0) {
if (i+1 >= objc-2) {
goto str_cmp_args;
}
}
}
- string1 = Tcl_GetStringFromObj(objv[objc-2], &length1);
- string2 = Tcl_GetStringFromObj(objv[objc-1], &length2);
/*
- * This is the min length IN BYTES of the two strings
+ * From now on, we only access the two objects at the end
+ * of the argument array.
*/
- length = (length1 < length2) ? length1 : length2;
+ objv += objc-2;
- if (reqlength == 0) {
+ if ((reqlength == 0) || (objv[0] == objv[1])) {
/*
- * Anything matches at 0 chars, right?
+ * Alway match at 0 chars of if it is the same obj.
*/
- match = 0;
- } else if (nocase || ((reqlength > 0) && (reqlength <= length))) {
+ Tcl_SetBooleanObj(resultPtr,
+ ((enum options) index == STR_EQUAL));
+ break;
+ } else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
+ objv[1]->typePtr == &tclByteArrayType) {
/*
- * with -nocase or -length we have to check true char length
- * as it could be smaller than expected
+ * Use binary versions of comparisons since that won't
+ * cause undue type conversions and it is much faster.
+ * Only do this if we're case-sensitive (which is all
+ * that really makes sense with byte arrays anyway, and
+ * we have no memcasecmp() for some reason... :^)
*/
-
- length1 = Tcl_NumUtfChars(string1, length1);
- length2 = Tcl_NumUtfChars(string2, length2);
- length = (length1 < length2) ? length1 : length2;
-
+ string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
+ string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
+ strCmpFn = memcmp;
+ } else if ((objv[0]->typePtr == &tclStringType)
+ && (objv[1]->typePtr == &tclStringType)) {
+ /*
+ * Do a unicode-specific comparison if both of the args
+ * are of String type. In benchmark testing this proved
+ * the most efficient check between the unicode and
+ * string comparison operations.
+ */
+ string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
+ string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
+ strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
+ } else {
/*
- * Do the reqlength check again, against 0 as well for
- * the benfit of nocase
+ * As a catch-all we will work with UTF-8. We cannot use
+ * memcmp() as that is unsafe with any string containing
+ * NULL (\xC0\x80 in Tcl's utf rep). We can use the more
+ * efficient TclpUtfNcmp2 if we are case-sensitive and no
+ * specific length was requested.
*/
+ string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
+ string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
+ if ((reqlength < 0) && !nocase) {
+ strCmpFn = TclpUtfNcmp2;
+ } else {
+ length1 = Tcl_NumUtfChars(string1, length1);
+ length2 = Tcl_NumUtfChars(string2, length2);
+ strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp;
+ }
+ }
- if ((reqlength > 0) && (reqlength < length)) {
+ if (((enum options) index == STR_EQUAL)
+ && (reqlength < 0) && (length1 != length2)) {
+ match = 1; /* this will be reversed below */
+ } else {
+ length = (length1 < length2) ? length1 : length2;
+ if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
/*
* The requested length is negative, so we ignore it by
- * setting it to the longer of the two lengths.
+ * setting it to length + 1 so we correct the match var.
*/
-
- reqlength = (length1 > length2) ? length1 : length2;
- }
- if (nocase) {
- match = Tcl_UtfNcasecmp(string1, string2,
- (unsigned) length);
- } else {
- match = Tcl_UtfNcmp(string1, string2, (unsigned) length);
+ reqlength = length + 1;
}
+ match = strCmpFn(string1, string2, (unsigned) length);
if ((match == 0) && (reqlength > length)) {
match = length1 - length2;
}
- } else {
- match = memcmp(string1, string2, (unsigned) length);
- if (match == 0) {
- match = length1 - length2;
- }
}
if ((enum options) index == STR_EQUAL) {
break;
}
case STR_FIRST: {
- register char *p, *end;
- int match, utflen, start;
+ Tcl_UniChar *ustring1, *ustring2;
+ int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
- "string1 string2 ?startIndex?");
+ "subString string ?startIndex?");
return TCL_ERROR;
}
/*
- * This algorithm fails on improperly formed UTF strings.
* We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
- utflen = -1;
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
- string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ length2 = -1;
+
+ ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
+ ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
- * If a startIndex is specified, we will need to fast forward
- * to that point in the string before we think about a match
+ * If a startIndex is specified, we will need to fast
+ * forward to that point in the string before we think
+ * about a match
*/
- utflen = Tcl_NumUtfChars(string2, length2);
- if (TclGetIntForIndex(interp, objv[4], utflen-1,
- &start) != TCL_OK) {
+ if (TclGetIntForIndex(interp, objv[4], length2 - 1,
+ &start) != TCL_OK) {
return TCL_ERROR;
}
- if (start >= utflen) {
+ if (start >= length2) {
goto str_first_done;
} else if (start > 0) {
- if (length2 == utflen) {
- /* no unicode chars */
- string2 += start;
- length2 -= start;
- } else {
- char *s = Tcl_UtfAtIndex(string2, start);
- length2 -= s - string2;
- string2 = s;
- }
+ ustring2 += start;
+ length2 -= start;
+ } else if (start < 0) {
+ /*
+ * Invalid start index mapped to string start;
+ * Bug #423581
+ */
+ start = 0;
}
}
if (length1 > 0) {
- end = string2 + length2 - length1 + 1;
- for (p = string2; p < end; p++) {
+ register Tcl_UniChar *p, *end;
+
+ end = ustring2 + length2 - length1 + 1;
+ for (p = ustring2; p < end; p++) {
/*
* Scan forward to find the first character.
*/
-
- p = memchr(p, *string1, (unsigned) (end - p));
- if (p == NULL) {
- break;
- }
- if (memcmp(string1, p, (unsigned) length1) == 0) {
- match = p - string2;
+ if ((*p == *ustring1) &&
+ (TclUniCharNcmp(ustring1, p,
+ (unsigned long) length1) == 0)) {
+ match = p - ustring2;
break;
}
}
}
-
/*
* Compute the character index of the matching string by
* counting the number of characters before the match.
*/
- str_first_done:
- if (match != -1) {
- if (objc == 4) {
- match = Tcl_NumUtfChars(string2, match);
- } else if (length2 == utflen) {
- /* no unicode chars */
- match += start;
- } else {
- match = start + Tcl_NumUtfChars(string2, match);
- }
+ if ((match != -1) && (objc == 5)) {
+ match += start;
}
+
+ str_first_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_INDEX: {
- char buf[TCL_UTF_MAX];
- Tcl_UniChar unichar;
-
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
return TCL_ERROR;
*/
if (objv[2]->typePtr == &tclByteArrayType) {
-
- string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
+ string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_SetByteArrayObj(resultPtr,
- (unsigned char *)(&string1[index]), 1);
+ if ((index >= 0) && (index < length1)) {
+ Tcl_SetByteArrayObj(resultPtr,
+ (unsigned char *)(&string1[index]), 1);
+ }
} else {
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
-
/*
- * convert to Unicode internal rep to calulate what
- * 'end' really means.
+ * Get Unicode char length to calulate what 'end' means.
*/
+ length1 = Tcl_GetCharLength(objv[2]);
- length2 = Tcl_GetCharLength(objv[2]);
-
- if (TclGetIntForIndex(interp, objv[3], length2 - 1,
+ if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&index) != TCL_OK) {
return TCL_ERROR;
}
- if ((index >= 0) && (index < length2)) {
- unichar = Tcl_GetUniChar(objv[2], index);
- length2 = Tcl_UniCharToUtf((int)unichar, buf);
- Tcl_SetStringObj(resultPtr, buf, length2);
+ if ((index >= 0) && (index < length1)) {
+ char buf[TCL_UTF_MAX];
+ Tcl_UniChar ch;
+
+ ch = Tcl_GetUniChar(objv[2], index);
+ length1 = Tcl_UniCharToUtf(ch, buf);
+ Tcl_SetStringObj(resultPtr, buf, length1);
}
}
break;
int i, failat = 0, result = 1, strict = 0;
Tcl_Obj *objPtr, *failVarObj = NULL;
- static char *isOptions[] = {
+ static CONST char *isOptions[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "digit", "double", "false",
"graph", "integer", "lower", "print",
strncmp(string2, "-strict", (size_t) length2) == 0) {
strict = 1;
} else if ((length2 > 1) &&
- strncmp(string2, "-failindex", (size_t) length2) == 0) {
+ strncmp(string2, "-failindex",
+ (size_t) length2) == 0) {
if (i+1 >= objc-1) {
Tcl_WrongNumArgs(interp, 3, objv,
"?-strict? ?-failindex var? str");
*/
if (TclLooksLikeInt(string1, length1)) {
errno = 0;
- strtoul(string1, &stop, 0);
+#ifdef TCL_WIDE_INT_IS_LONG
+ strtoul(string1, &stop, 0); /* INTL: Tcl source. */
+#else
+ strtoull(string1, &stop, 0); /* INTL: Tcl source. */
+#endif
if (stop == end) {
if (errno == ERANGE) {
result = 0;
*/
result = 0;
errno = 0;
+#ifdef TCL_WIDE_INT_IS_LONG
strtoul(string1, &stop, 0); /* INTL: Tcl source. */
+#else
+ strtoull(string1, &stop, 0); /* INTL: Tcl source. */
+#endif
if (errno == ERANGE) {
/*
* if (errno == ERANGE), then it was an over/underflow
break;
}
case STR_LAST: {
- register char *p;
- int match, utflen, start;
+ Tcl_UniChar *ustring1, *ustring2, *p;
+ int match, start;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
- "string1 string2 ?startIndex?");
+ "subString string ?startIndex?");
return TCL_ERROR;
}
/*
- * This algorithm fails on improperly formed UTF strings.
+ * We are searching string2 for the sequence string1.
*/
match = -1;
start = 0;
- utflen = -1;
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
- string2 = Tcl_GetStringFromObj(objv[3], &length2);
+ length2 = -1;
+
+ ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
+ ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
if (objc == 5) {
/*
* If a startIndex is specified, we will need to restrict
* the string range to that char index in the string
*/
- utflen = Tcl_NumUtfChars(string2, length2);
- if (TclGetIntForIndex(interp, objv[4], utflen-1,
- &start) != TCL_OK) {
+ if (TclGetIntForIndex(interp, objv[4], length2 - 1,
+ &start) != TCL_OK) {
return TCL_ERROR;
}
if (start < 0) {
goto str_last_done;
- } else if (start < utflen) {
- if (length2 == utflen) {
- /* no unicode chars */
- p = string2 + start + 1 - length1;
- } else {
- p = Tcl_UtfAtIndex(string2, start+1) - length1;
- }
+ } else if (start < length2) {
+ p = ustring2 + start + 1 - length1;
} else {
- p = string2 + length2 - length1;
+ p = ustring2 + length2 - length1;
}
} else {
- p = string2 + length2 - length1;
+ p = ustring2 + length2 - length1;
}
if (length1 > 0) {
- for (; p >= string2; p--) {
+ for (; p >= ustring2; p--) {
/*
* Scan backwards to find the first character.
*/
-
- while ((p != string2) && (*p != *string1)) {
- p--;
- }
- if (memcmp(string1, p, (unsigned) length1) == 0) {
- match = p - string2;
+ if ((*p == *ustring1) &&
+ (memcmp((char *) ustring1, (char *) p, (size_t)
+ (length1 * sizeof(Tcl_UniChar))) == 0)) {
+ match = p - ustring2;
break;
}
}
}
- /*
- * Compute the character index of the matching string by counting
- * the number of characters before the match.
- */
- str_last_done:
- if (match != -1) {
- if ((objc == 4) || (length2 != utflen)) {
- /* only check when we've got unicode chars */
- match = Tcl_NumUtfChars(string2, match);
- }
- }
+ str_last_done:
Tcl_SetIntObj(resultPtr, match);
break;
}
if ((enum options) index == STR_BYTELENGTH) {
(void) Tcl_GetStringFromObj(objv[2], &length1);
- Tcl_SetIntObj(resultPtr, length1);
} else {
/*
* If we have a ByteArray object, avoid recomputing the
if (objv[2]->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(objv[2], &length1);
- Tcl_SetIntObj(resultPtr, length1);
} else {
- Tcl_SetIntObj(resultPtr,
- Tcl_GetCharLength(objv[2]));
+ length1 = Tcl_GetCharLength(objv[2]);
}
}
+ Tcl_SetIntObj(resultPtr, length1);
break;
}
case STR_MAP: {
- int uselen, mapElemc, len, nocase = 0;
+ int mapElemc, nocase = 0;
Tcl_Obj **mapElemv;
- char *end;
- Tcl_UniChar ch;
- int (*str_comp_fn)();
+ Tcl_UniChar *ustring1, *ustring2, *p, *end;
+ int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
+ CONST Tcl_UniChar*, unsigned long));
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
* empty charMap, just return whatever string was given
*/
Tcl_SetObjResult(interp, objv[objc-1]);
+ return TCL_OK;
} else if (mapElemc & 1) {
/*
* The charMap must be an even number of key/value items
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[objc-1], &length1);
+ objc--;
+
+ ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
if (length1 == 0) {
+ /*
+ * Empty input string, just stop now
+ */
break;
}
- end = string1 + length1;
+ end = ustring1 + length1;
- if (nocase) {
- length1 = Tcl_NumUtfChars(string1, length1);
- str_comp_fn = Tcl_UtfNcasecmp;
- } else {
- str_comp_fn = memcmp;
- }
+ strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
- for ( ; string1 < end; string1 += len) {
- len = Tcl_UtfToUniChar(string1, &ch);
- for (index = 0; index < mapElemc; index +=2) {
- /*
- * Get the key string to match on
- */
- string2 = Tcl_GetStringFromObj(mapElemv[index],
- &length2);
- if (nocase) {
- uselen = Tcl_NumUtfChars(string2, length2);
- } else {
- uselen = length2;
+ /*
+ * Force result to be Unicode
+ */
+ Tcl_SetUnicodeObj(resultPtr, ustring1, 0);
+
+ if (mapElemc == 2) {
+ /*
+ * Special case for one map pair which avoids the extra
+ * for loop and extra calls to get Unicode data. The
+ * algorithm is otherwise identical to the multi-pair case.
+ * This will be >30% faster on larger strings.
+ */
+ int mapLen;
+ Tcl_UniChar *mapString, u2lc;
+
+ ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
+ p = ustring1;
+ if (length2 == 0) {
+ ustring1 = end;
+ } else {
+ mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
+ u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
+ for (; ustring1 < end; ustring1++) {
+ if (((*ustring1 == *ustring2) ||
+ (nocase && (Tcl_UniCharToLower(*ustring1) ==
+ u2lc))) &&
+ ((length2 == 1) || strCmpFn(ustring1, ustring2,
+ (unsigned long) length2) == 0)) {
+ if (p != ustring1) {
+ Tcl_AppendUnicodeToObj(resultPtr, p,
+ ustring1 - p);
+ p = ustring1 + length2;
+ } else {
+ p += length2;
+ }
+ ustring1 = p - 1;
+
+ Tcl_AppendUnicodeToObj(resultPtr, mapString,
+ mapLen);
+ }
}
- if ((uselen > 0) && (uselen <= length1) &&
- (str_comp_fn(string2, string1, uselen) == 0)) {
- /*
- * Adjust len to be full length of matched string
- * it has to be the BYTE length
- */
- len = length2;
+ }
+ } else {
+ Tcl_UniChar **mapStrings, *u2lc = NULL;
+ int *mapLens;
+ /*
+ * Precompute pointers to the unicode string and length.
+ * This saves us repeated function calls later,
+ * significantly speeding up the algorithm. We only need
+ * the lowercase first char in the nocase case.
+ */
+ mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2)
+ * sizeof(Tcl_UniChar *));
+ mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int));
+ if (nocase) {
+ u2lc = (Tcl_UniChar *)
+ ckalloc((mapElemc) * sizeof(Tcl_UniChar));
+ }
+ for (index = 0; index < mapElemc; index++) {
+ mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
+ &(mapLens[index]));
+ if (nocase && ((index % 2) == 0)) {
+ u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
+ }
+ }
+ for (p = ustring1; ustring1 < end; ustring1++) {
+ for (index = 0; index < mapElemc; index += 2) {
/*
- * Change string2 and length2 to the map value
+ * Get the key string to match on.
*/
- string2 = Tcl_GetStringFromObj(mapElemv[index+1],
- &length2);
- Tcl_AppendToObj(resultPtr, string2, length2);
- break;
+ ustring2 = mapStrings[index];
+ length2 = mapLens[index];
+ if ((length2 > 0) && ((*ustring1 == *ustring2) ||
+ (nocase && (Tcl_UniCharToLower(*ustring1) ==
+ u2lc[index/2]))) &&
+ ((length2 == 1) || strCmpFn(ustring2, ustring1,
+ (unsigned long) length2) == 0)) {
+ if (p != ustring1) {
+ /*
+ * Put the skipped chars onto the result first
+ */
+ Tcl_AppendUnicodeToObj(resultPtr, p,
+ ustring1 - p);
+ p = ustring1 + length2;
+ } else {
+ p += length2;
+ }
+ /*
+ * Adjust len to be full length of matched string
+ */
+ ustring1 = p - 1;
+
+ /*
+ * Append the map value to the unicode string
+ */
+ Tcl_AppendUnicodeToObj(resultPtr,
+ mapStrings[index+1], mapLens[index+1]);
+ break;
+ }
}
}
- if (index == mapElemc) {
- /*
- * No match was found, put the char onto result
- */
- Tcl_AppendToObj(resultPtr, string1, len);
+ ckfree((char *) mapStrings);
+ ckfree((char *) mapLens);
+ if (nocase) {
+ ckfree((char *) u2lc);
}
+ }
+ if (p != ustring1) {
/*
- * in nocase, length1 is in chars
- * otherwise it is in bytes
+ * Put the rest of the unmapped chars onto result
*/
- if (nocase) {
- length1--;
- } else {
- length1 -= len;
- }
+ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
break;
}
}
Tcl_SetBooleanObj(resultPtr,
- Tcl_StringCaseMatch(Tcl_GetString(objv[objc-1]),
- Tcl_GetString(objv[objc-2]),
- nocase));
+ Tcl_UniCharCaseMatch(Tcl_GetUnicode(objv[objc-1]),
+ Tcl_GetUnicode(objv[objc-2]), nocase));
break;
}
case STR_RANGE: {
}
/*
- * If we have a ByteArray object, avoid indexing in the
- * Utf string since the byte array contains one byte per
- * character. Otherwise, use the Unicode string rep to
- * get the range.
+ * Get the length in actual characters.
*/
+ length1 = Tcl_GetCharLength(objv[2]) - 1;
- if (objv[2]->typePtr == &tclByteArrayType) {
-
- string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
-
- if (TclGetIntForIndex(interp, objv[3], length1 - 1,
- &first) != TCL_OK) {
- return TCL_ERROR;
- }
- if (TclGetIntForIndex(interp, objv[4], length1 - 1,
- &last) != TCL_OK) {
- return TCL_ERROR;
- }
- if (first < 0) {
- first = 0;
- }
- if (last >= length1 - 1) {
- last = length1 - 1;
- }
- if (last >= first) {
- int numBytes = last - first + 1;
- resultPtr = Tcl_NewByteArrayObj(
- (unsigned char *) &string1[first], numBytes);
- Tcl_SetObjResult(interp, resultPtr);
- }
- } else {
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
-
- /*
- * Convert to Unicode internal rep to calulate length and
- * create a result object.
- */
+ if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
+ || (TclGetIntForIndex(interp, objv[4], length1,
+ &last) != TCL_OK)) {
+ return TCL_ERROR;
+ }
- length2 = Tcl_GetCharLength(objv[2]) - 1;
-
- if (TclGetIntForIndex(interp, objv[3], length2,
- &first) != TCL_OK) {
- return TCL_ERROR;
- }
- if (TclGetIntForIndex(interp, objv[4], length2,
- &last) != TCL_OK) {
- return TCL_ERROR;
- }
- if (first < 0) {
- first = 0;
- }
- if (last >= length2) {
- last = length2;
- }
- if (last >= first) {
- resultPtr = Tcl_GetRange(objv[2], first, last);
- Tcl_SetObjResult(interp, resultPtr);
- }
+ if (first < 0) {
+ first = 0;
+ }
+ if (last >= length1) {
+ last = length1;
+ }
+ if (last >= first) {
+ Tcl_SetObjResult(interp, Tcl_GetRange(objv[2], first, last));
}
break;
}
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
- if (length1 > 0) {
- for (index = 0; index < count; index++) {
- Tcl_AppendToObj(resultPtr, string1, length1);
- }
- }
- break;
- }
- case STR_REPLACE: {
- int first, last;
-
- if (objc < 5 || objc > 6) {
+ if (count == 1) {
+ Tcl_SetObjResult(interp, objv[2]);
+ } else if (count > 1) {
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ if (length1 > 0) {
+ /*
+ * Only build up a string that has data. Instead of
+ * building it up with repeated appends, we just allocate
+ * the necessary space once and copy the string value in.
+ */
+ length2 = length1 * count;
+ /*
+ * Include space for the NULL
+ */
+ string2 = (char *) ckalloc((size_t) length2+1);
+ for (index = 0; index < count; index++) {
+ memcpy(string2 + (length1 * index), string1,
+ (size_t) length1);
+ }
+ string2[length2] = '\0';
+ /*
+ * We have to directly assign this instead of using
+ * Tcl_SetStringObj (and indirectly TclInitStringRep)
+ * because that makes another copy of the data.
+ */
+ resultPtr = Tcl_NewObj();
+ resultPtr->bytes = string2;
+ resultPtr->length = length2;
+ Tcl_SetObjResult(interp, resultPtr);
+ }
+ }
+ break;
+ }
+ case STR_REPLACE: {
+ Tcl_UniChar *ustring1;
+ int first, last;
+
+ if (objc < 5 || objc > 6) {
Tcl_WrongNumArgs(interp, 2, objv,
"string first last ?string?");
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
- length1 = Tcl_NumUtfChars(string1, length1) - 1;
- if (TclGetIntForIndex(interp, objv[3], length1,
- &first) != TCL_OK) {
- return TCL_ERROR;
- }
- if (TclGetIntForIndex(interp, objv[4], length1,
- &last) != TCL_OK) {
+ ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
+ length1--;
+
+ if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
+ || (TclGetIntForIndex(interp, objv[4], length1,
+ &last) != TCL_OK)) {
return TCL_ERROR;
}
- if ((last < first) || (first > length1) || (last < 0)) {
+
+ if ((last < first) || (last < 0) || (first > length1)) {
Tcl_SetObjResult(interp, objv[2]);
} else {
- char *start, *end;
-
if (first < 0) {
first = 0;
}
- start = Tcl_UtfAtIndex(string1, first);
- end = Tcl_UtfAtIndex(start, ((last > length1) ? length1 : last)
- - first + 1);
- Tcl_SetStringObj(resultPtr, string1, start - string1);
+
+ Tcl_SetUnicodeObj(resultPtr, ustring1, first);
if (objc == 6) {
Tcl_AppendObjToObj(resultPtr, objv[5]);
}
if (last < length1) {
- Tcl_AppendToObj(resultPtr, end, -1);
+ Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
+ length1 - last);
}
}
break;
Tcl_SetObjLength(resultPtr, length1);
} else {
int first, last;
- char *start, *end;
+ CONST char *start, *end;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndex(interp, objv[3], length1,
case STR_TRIM: {
Tcl_UniChar ch, trim;
- register char *p, *end;
+ register CONST char *p, *end;
char *check, *checkEnd;
int offset;
case STR_WORDEND: {
int cur;
Tcl_UniChar ch;
- char *p, *end;
+ CONST char *p, *end;
int numChars;
if (objc != 4) {
case STR_WORDSTART: {
int cur;
Tcl_UniChar ch;
- char *p;
+ CONST char *p;
int numChars;
if (objc != 4) {
*
* This procedure is invoked to process the "subst" Tcl command.
* See the user documentation for details on what it does. This
- * command is an almost direct copy of an implementation by
- * Andrew Payne.
+ * command relies on Tcl_SubstObj() for its implementation.
*
* Results:
* A standard Tcl result.
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- static char *substOptions[] = {
+ static CONST char *substOptions[] = {
"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
};
enum substOptions {
SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
};
- Interp *iPtr = (Interp *) interp;
- Tcl_DString result;
- char *p, *old, *value;
- int optionIndex, code, count, doVars, doCmds, doBackslashes, i;
+ Tcl_Obj *resultPtr;
+ int optionIndex, flags, i;
/*
* Parse command-line options.
*/
- doVars = doCmds = doBackslashes = 1;
+ flags = TCL_SUBST_ALL;
for (i = 1; i < (objc-1); i++) {
- p = Tcl_GetString(objv[i]);
- if (*p != '-') {
- break;
- }
if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
"switch", 0, &optionIndex) != TCL_OK) {
}
switch (optionIndex) {
case SUBST_NOBACKSLASHES: {
- doBackslashes = 0;
+ flags &= ~TCL_SUBST_BACKSLASHES;
break;
}
case SUBST_NOCOMMANDS: {
- doCmds = 0;
+ flags &= ~TCL_SUBST_COMMANDS;
break;
}
case SUBST_NOVARS: {
- doVars = 0;
+ flags &= ~TCL_SUBST_VARIABLES;
break;
}
default: {
}
/*
- * Scan through the string one character at a time, performing
- * command, variable, and backslash substitutions.
+ * Perform the substitution.
*/
+ resultPtr = Tcl_SubstObj(interp, objv[i], flags);
+
+ if (resultPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SubstObj --
+ *
+ * This function performs the substitutions specified on the
+ * given string as described in the user documentation for the
+ * "subst" Tcl command. This code is heavily based on an
+ * implementation by Andrew Payne. Note that if a command
+ * substitution returns TCL_CONTINUE or TCL_RETURN from its
+ * evaluation and is not completely well-formed, the results are
+ * not defined (or at least hard to characterise.) This fault
+ * will be fixed at some point, but the cost of the only sane
+ * fix (well-formedness check first) is such that you need to
+ * "precompile and cache" to stop everyone from being hit with
+ * the consequences every time through. Note that the current
+ * behaviour is not a security hole; it just restarts parsing
+ * the string following the substitution in a mildly surprising
+ * place, and it is a very bad idea to count on this remaining
+ * the same in future...
+ *
+ * Results:
+ * A Tcl_Obj* containing the substituted string, or NULL to
+ * indicate that an error occurred.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
- Tcl_DStringInit(&result);
- old = p = Tcl_GetString(objv[i]);
- while (*p != 0) {
+Tcl_Obj *
+Tcl_SubstObj(interp, objPtr, flags)
+ Tcl_Interp *interp;
+ Tcl_Obj *objPtr;
+ int flags;
+{
+ Tcl_Obj *resultObj;
+ char *p, *old;
+
+ old = p = Tcl_GetString(objPtr);
+ resultObj = Tcl_NewStringObj("", 0);
+ while (1) {
switch (*p) {
- case '\\':
- if (doBackslashes) {
- char buf[TCL_UTF_MAX];
+ case 0:
+ if (p != old) {
+ Tcl_AppendToObj(resultObj, old, p-old);
+ }
+ return resultObj;
- if (p != old) {
- Tcl_DStringAppend(&result, old, p-old);
- }
- Tcl_DStringAppend(&result, buf,
- Tcl_UtfBackslash(p, &count, buf));
- p += count;
- old = p;
- } else {
- p++;
+ case '\\':
+ if (flags & TCL_SUBST_BACKSLASHES) {
+ char buf[TCL_UTF_MAX];
+ int count;
+
+ if (p != old) {
+ Tcl_AppendToObj(resultObj, old, p-old);
}
- break;
+ Tcl_AppendToObj(resultObj, buf,
+ Tcl_UtfBackslash(p, &count, buf));
+ p += count;
+ old = p;
+ } else {
+ p++;
+ }
+ break;
- case '$':
- if (doVars) {
- if (p != old) {
- Tcl_DStringAppend(&result, old, p-old);
- }
- value = Tcl_ParseVar(interp, p, &p);
- if (value == NULL) {
- Tcl_DStringFree(&result);
- return TCL_ERROR;
- }
- Tcl_DStringAppend(&result, value, -1);
- old = p;
- } else {
+ case '$':
+ if (flags & TCL_SUBST_VARIABLES) {
+ Tcl_Parse parse;
+ int code;
+
+ /*
+ * Code is simpler overall if we (effectively) inline
+ * Tcl_ParseVar, particularly as that allows us to use
+ * a non-string interface when we come to appending
+ * the variable contents to the result object. There
+ * are a few other optimisations that doing this
+ * enables (like being able to continue the run of
+ * unsubstituted characters straight through if a '$'
+ * does not precede a variable name.)
+ */
+ if (Tcl_ParseVarName(interp, p, -1, &parse, 0) != TCL_OK) {
+ goto errorResult;
+ }
+ if (parse.numTokens == 1) {
+ /*
+ * There isn't a variable name after all: the $ is
+ * just a $.
+ */
p++;
+ break;
}
- break;
-
- case '[':
- if (doCmds) {
- if (p != old) {
- Tcl_DStringAppend(&result, old, p-old);
- }
- iPtr->evalFlags = TCL_BRACKET_TERM;
- code = Tcl_Eval(interp, p+1);
- if (code == TCL_ERROR) {
- Tcl_DStringFree(&result);
- return code;
- }
- old = p = (p+1 + iPtr->termOffset+1);
- Tcl_DStringAppend(&result, iPtr->result, -1);
+ if (p != old) {
+ Tcl_AppendToObj(resultObj, old, p-old);
+ }
+ p += parse.tokenPtr->size;
+ code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
+ parse.numTokens);
+ if (code == TCL_ERROR) {
+ goto errorResult;
+ }
+ if (code == TCL_BREAK) {
Tcl_ResetResult(interp);
- } else {
- p++;
+ return resultObj;
}
- break;
+ if (code != TCL_CONTINUE) {
+ Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
+ }
+ Tcl_ResetResult(interp);
+ old = p;
+ } else {
+ p++;
+ }
+ break;
+
+ case '[':
+ if (flags & TCL_SUBST_COMMANDS) {
+ Interp *iPtr = (Interp *) interp;
+ int code;
- default:
+ if (p != old) {
+ Tcl_AppendToObj(resultObj, old, p-old);
+ }
+ iPtr->evalFlags = TCL_BRACKET_TERM;
+ code = Tcl_EvalEx(interp, p+1, -1, 0);
+ switch (code) {
+ case TCL_ERROR:
+ goto errorResult;
+ case TCL_BREAK:
+ Tcl_ResetResult(interp);
+ return resultObj;
+ default:
+ Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
+ case TCL_CONTINUE:
+ Tcl_ResetResult(interp);
+ old = p = (p+1 + iPtr->termOffset + 1);
+ }
+ } else {
p++;
- break;
+ }
+ break;
+ default:
+ p++;
+ break;
}
}
- if (p != old) {
- Tcl_DStringAppend(&result, old, p-old);
- }
- Tcl_DStringResult(interp, &result);
- return TCL_OK;
+
+ errorResult:
+ Tcl_DecrRefCount(resultObj);
+ return NULL;
}
\f
/*
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int i, j, index, mode, matched, result, splitObjs, seenComment;
+ int i, j, index, mode, matched, result, splitObjs;
char *string, *pattern;
Tcl_Obj *stringObj;
- static char *options[] = {
+ Tcl_Obj *CONST *savedObjv = objv;
+ static CONST char *options[] = {
"-exact", "-glob", "-regexp", "--",
NULL
};
if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
- objv = listv;
- splitObjs = 1;
- }
-
- seenComment = 0;
- for (i = 0; i < objc; i += 2) {
- if (i == objc - 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra switch pattern with no body", -1);
-
- /*
- * Check if this can be due to a badly placed comment
- * in the switch block
- */
- if (splitObjs && seenComment) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1);
- }
+ /*
+ * Ensure that the list is non-empty.
+ */
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, savedObjv,
+ "?switches? string {pattern body ... ?default body?}");
return TCL_ERROR;
}
+ objv = listv;
+ splitObjs = 1;
+ }
- /*
- * See if the pattern matches the string.
- */
+ /*
+ * Complain if there is an odd number of words in the list of
+ * patterns and bodies.
+ */
- pattern = Tcl_GetString(objv[i]);
+ if (objc % 2) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
/*
+ * Check if this can be due to a badly placed comment
+ * in the switch block.
+ *
* The following is an heuristic to detect the infamous
* "comment in switch" error: just check if a pattern
* begins with '#'.
*/
- if (splitObjs && *pattern == '#') {
- seenComment = 1;
+ if (splitObjs) {
+ for (i=0 ; i<objc ; i+=2) {
+ if (Tcl_GetString(objv[i])[0] == '#') {
+ Tcl_AppendResult(interp, ", this may be due to a ",
+ "comment incorrectly placed outside of a ",
+ "switch body - see the \"switch\" ",
+ "documentation", NULL);
+ break;
+ }
+ }
}
+ return TCL_ERROR;
+ }
+
+ /*
+ * Complain if the last body is a continuation. Note that this
+ * check assumes that the list is non-empty!
+ */
+
+ if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "no body specified for pattern \"",
+ Tcl_GetString(objv[objc-2]), "\"", NULL);
+ return TCL_ERROR;
+ }
+
+ for (i = 0; i < objc; i += 2) {
+ /*
+ * See if the pattern matches the string.
+ */
+
+ pattern = Tcl_GetString(objv[i]);
+
matched = 0;
if ((i == objc - 2)
&& (*pattern == 'd')
for (j = i + 1; ; j += 2) {
if (j >= objc) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "no body specified for pattern \"", pattern,
- "\"", (char *) NULL);
- return TCL_ERROR;
+ /*
+ * This shouldn't happen since we've checked that the
+ * last body is not a continuation...
+ */
+ panic("fall-out when searching for body to match pattern");
}
if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
objPtr = objv[1];
i = count;
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
while (i-- > 0) {
result = Tcl_EvalObjEx(interp, objPtr, 0);
if (result != TCL_OK) {
return result;
}
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
- totalMicroSec =
- (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
+ totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
+ + ( stop.usec - start.usec ) );
sprintf(buf, "%.0f microseconds per iteration",
((count <= 0) ? 0 : totalMicroSec/count));
Tcl_ResetResult(interp);
*
* This procedure is invoked to process the "trace" Tcl command.
* See the user documentation for details on what it does.
+ *
+ * Standard syntax as of Tcl 8.4 is
+ *
+ * trace {add|info|remove} {command|variable} name ops cmd
+ *
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
- *
*----------------------------------------------------------------------
*/
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int optionIndex, commandLength;
- char *name, *rwuOps, *command, *p;
+ char *name, *flagOps, *command, *p;
size_t length;
- static char *traceOptions[] = {
- "variable", "vdelete", "vinfo", (char *) NULL
+ /* Main sub commands to 'trace' */
+ static CONST char *traceOptions[] = {
+ "add", "info", "remove",
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ "variable", "vdelete", "vinfo",
+#endif
+ (char *) NULL
};
+ /* 'OLD' options are pre-Tcl-8.4 style */
enum traceOptions {
- TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO
+ TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
+#endif
};
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
return TCL_ERROR;
}
switch ((enum traceOptions) optionIndex) {
- case TRACE_VARIABLE: {
- int flags;
- TraceVarInfo *tvarPtr;
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
- return TCL_ERROR;
- }
+ case TRACE_ADD:
+ case TRACE_REMOVE:
+ case TRACE_INFO: {
+ /*
+ * All sub commands of trace add/remove must take at least
+ * one more argument. Beyond that we let the subcommand itself
+ * control the argument structure.
+ */
+ int typeIndex;
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
+ "option", 0, &typeIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
+ break;
+ }
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ case TRACE_OLD_VARIABLE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
+ }
- flags = 0;
- rwuOps = Tcl_GetString(objv[3]);
- for (p = rwuOps; *p != 0; p++) {
- if (*p == 'r') {
- flags |= TCL_TRACE_READS;
- } else if (*p == 'w') {
- flags |= TCL_TRACE_WRITES;
- } else if (*p == 'u') {
- flags |= TCL_TRACE_UNSETS;
- } else {
- goto badOps;
- }
- }
- if (flags == 0) {
- goto badOps;
+ flags = 0;
+ flagOps = Tcl_GetString(objv[3]);
+ for (p = flagOps; *p != 0; p++) {
+ if (*p == 'r') {
+ flags |= TCL_TRACE_READS;
+ } else if (*p == 'w') {
+ flags |= TCL_TRACE_WRITES;
+ } else if (*p == 'u') {
+ flags |= TCL_TRACE_UNSETS;
+ } else if (*p == 'a') {
+ flags |= TCL_TRACE_ARRAY;
+ } else {
+ goto badVarOps;
}
+ }
+ if (flags == 0) {
+ goto badVarOps;
+ }
+ flags |= TCL_TRACE_OLD_STYLE;
+
+ command = Tcl_GetStringFromObj(objv[4], &commandLength);
+ length = (size_t) commandLength;
+ tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
+ (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
+ + length + 1));
+ tvarPtr->flags = flags;
+ tvarPtr->length = length;
+ flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
+ strcpy(tvarPtr->command, command);
+ name = Tcl_GetString(objv[2]);
+ if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
+ (ClientData) tvarPtr) != TCL_OK) {
+ ckfree((char *) tvarPtr);
+ return TCL_ERROR;
+ }
+ break;
+ }
+ case TRACE_OLD_VDELETE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ ClientData clientData;
- command = Tcl_GetStringFromObj(objv[4], &commandLength);
- length = (size_t) commandLength;
- tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
- (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
- + length + 1));
- tvarPtr->flags = flags;
- tvarPtr->errMsg = NULL;
- tvarPtr->length = length;
- flags |= TCL_TRACE_UNSETS;
- strcpy(tvarPtr->command, command);
- name = Tcl_GetString(objv[2]);
- if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
- (ClientData) tvarPtr) != TCL_OK) {
- ckfree((char *) tvarPtr);
- return TCL_ERROR;
- }
- break;
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
}
- case TRACE_VDELETE: {
- int flags;
- TraceVarInfo *tvarPtr;
- ClientData clientData;
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
- return TCL_ERROR;
+ flags = 0;
+ flagOps = Tcl_GetString(objv[3]);
+ for (p = flagOps; *p != 0; p++) {
+ if (*p == 'r') {
+ flags |= TCL_TRACE_READS;
+ } else if (*p == 'w') {
+ flags |= TCL_TRACE_WRITES;
+ } else if (*p == 'u') {
+ flags |= TCL_TRACE_UNSETS;
+ } else if (*p == 'a') {
+ flags |= TCL_TRACE_ARRAY;
+ } else {
+ goto badVarOps;
}
+ }
+ if (flags == 0) {
+ goto badVarOps;
+ }
+ flags |= TCL_TRACE_OLD_STYLE;
- flags = 0;
- rwuOps = Tcl_GetString(objv[3]);
- for (p = rwuOps; *p != 0; p++) {
- if (*p == 'r') {
- flags |= TCL_TRACE_READS;
- } else if (*p == 'w') {
- flags |= TCL_TRACE_WRITES;
- } else if (*p == 'u') {
- flags |= TCL_TRACE_UNSETS;
- } else {
- goto badOps;
- }
- }
- if (flags == 0) {
- goto badOps;
- }
+ /*
+ * Search through all of our traces on this variable to
+ * see if there's one with the given command. If so, then
+ * delete the first one that matches.
+ */
- /*
- * Search through all of our traces on this variable to
- * see if there's one with the given command. If so, then
- * delete the first one that matches.
- */
-
- command = Tcl_GetStringFromObj(objv[4], &commandLength);
- length = (size_t) commandLength;
- clientData = 0;
- name = Tcl_GetString(objv[2]);
- while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
- TraceVarProc, clientData)) != 0) {
- tvarPtr = (TraceVarInfo *) clientData;
- if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
- && (strncmp(command, tvarPtr->command,
- (size_t) length) == 0)) {
- Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS,
- TraceVarProc, clientData);
- if (tvarPtr->errMsg != NULL) {
- ckfree(tvarPtr->errMsg);
- }
- ckfree((char *) tvarPtr);
- break;
- }
+ command = Tcl_GetStringFromObj(objv[4], &commandLength);
+ length = (size_t) commandLength;
+ clientData = 0;
+ name = Tcl_GetString(objv[2]);
+ while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
+ TraceVarProc, clientData)) != 0) {
+ tvarPtr = (TraceVarInfo *) clientData;
+ if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
+ && (strncmp(command, tvarPtr->command,
+ (size_t) length) == 0)) {
+ Tcl_UntraceVar2(interp, name, NULL,
+ flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
+ TraceVarProc, clientData);
+ Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
+ break;
}
- break;
}
- case TRACE_VINFO: {
- ClientData clientData;
- char ops[4];
- Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
+ break;
+ }
+ case TRACE_OLD_VINFO: {
+ ClientData clientData;
+ char ops[5];
+ Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name");
- return TCL_ERROR;
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
+ return TCL_ERROR;
+ }
+ resultListPtr = Tcl_GetObjResult(interp);
+ clientData = 0;
+ name = Tcl_GetString(objv[2]);
+ while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
+ TraceVarProc, clientData)) != 0) {
+
+ TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+
+ pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ p = ops;
+ if (tvarPtr->flags & TCL_TRACE_READS) {
+ *p = 'r';
+ p++;
}
- resultListPtr = Tcl_GetObjResult(interp);
- clientData = 0;
- name = Tcl_GetString(objv[2]);
- while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
- TraceVarProc, clientData)) != 0) {
-
- TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
-
- pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- p = ops;
- if (tvarPtr->flags & TCL_TRACE_READS) {
- *p = 'r';
- p++;
- }
- if (tvarPtr->flags & TCL_TRACE_WRITES) {
- *p = 'w';
- p++;
- }
- if (tvarPtr->flags & TCL_TRACE_UNSETS) {
- *p = 'u';
- p++;
- }
- *p = '\0';
+ if (tvarPtr->flags & TCL_TRACE_WRITES) {
+ *p = 'w';
+ p++;
+ }
+ if (tvarPtr->flags & TCL_TRACE_UNSETS) {
+ *p = 'u';
+ p++;
+ }
+ if (tvarPtr->flags & TCL_TRACE_ARRAY) {
+ *p = 'a';
+ p++;
+ }
+ *p = '\0';
- /*
- * Build a pair (2-item list) with the ops string as
- * the first obj element and the tvarPtr->command string
- * as the second obj element. Append the pair (as an
- * element) to the end of the result object list.
- */
+ /*
+ * Build a pair (2-item list) with the ops string as
+ * the first obj element and the tvarPtr->command string
+ * as the second obj element. Append the pair (as an
+ * element) to the end of the result object list.
+ */
- elemObjPtr = Tcl_NewStringObj(ops, -1);
- Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
- elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
- Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
- Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
- }
- Tcl_SetObjResult(interp, resultListPtr);
- break;
- }
- default: {
- panic("Tcl_TraceObjCmd: bad option index to TraceOptions");
+ elemObjPtr = Tcl_NewStringObj(ops, -1);
+ Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
+ elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
+ Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
}
+ Tcl_SetObjResult(interp, resultListPtr);
+ break;
+ }
+#endif /* TCL_REMOVE_OBSOLETE_TRACES */
}
return TCL_OK;
- badOps:
- Tcl_AppendResult(interp, "bad operations \"", rwuOps,
- "\": should be one or more of rwu", (char *) NULL);
+ badVarOps:
+ Tcl_AppendResult(interp, "bad operations \"", flagOps,
+ "\": should be one or more of rwua", (char *) NULL);
return TCL_ERROR;
}
+
\f
/*
*----------------------------------------------------------------------
*
- * TraceVarProc --
+ * TclTraceExecutionObjCmd --
*
- * This procedure is called to handle variable accesses that have
- * been traced using the "trace" command.
+ * Helper function for Tcl_TraceObjCmd; implements the
+ * [trace {add|remove|info} execution ...] subcommands.
+ * See the user documentation for details on what these do.
*
* Results:
- * Normally returns NULL. If the trace command returns an error,
- * then this procedure returns an error string.
+ * Standard Tcl result.
*
* Side effects:
- * Depends on the command associated with the trace.
+ * Depends on the operation (add, remove, or info) being performed;
+ * may add or remove command traces on a command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
+ Tcl_Interp *interp; /* Current interpreter. */
+ int optionIndex; /* Add, info or remove */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int commandLength, index;
+ char *name, *command;
+ size_t length;
+ enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
+ static CONST char *opStrings[] = { "enter", "leave",
+ "enterstep", "leavestep", (char *) NULL };
+ enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
+ TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };
+
+ switch ((enum traceOptions) optionIndex) {
+ case TRACE_ADD:
+ case TRACE_REMOVE: {
+ int flags = 0;
+ int i, listLen, result;
+ Tcl_Obj **elemPtrs;
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 3, objv, "name opList execution");
+ return TCL_ERROR;
+ }
+ /*
+ * Make sure the ops argument is a list object; get its length and
+ * a pointer to its array of element pointers.
+ */
+
+ result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (listLen == 0) {
+ Tcl_SetResult(interp, "bad operation list \"\": must be "
+ "one or more of enter, leave, enterstep, or leavestep", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ for (i = 0; i < listLen; i++) {
+ if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
+ "operation", TCL_EXACT, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum operations) index) {
+ case TRACE_EXEC_ENTER:
+ flags |= TCL_TRACE_ENTER_EXEC;
+ break;
+ case TRACE_EXEC_LEAVE:
+ flags |= TCL_TRACE_LEAVE_EXEC;
+ break;
+ case TRACE_EXEC_ENTER_STEP:
+ flags |= TCL_TRACE_ENTER_DURING_EXEC;
+ break;
+ case TRACE_EXEC_LEAVE_STEP:
+ flags |= TCL_TRACE_LEAVE_DURING_EXEC;
+ break;
+ }
+ }
+ command = Tcl_GetStringFromObj(objv[5], &commandLength);
+ length = (size_t) commandLength;
+ if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ TraceCommandInfo *tcmdPtr;
+ tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
+ (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ + length + 1));
+ tcmdPtr->flags = flags;
+ tcmdPtr->stepTrace = NULL;
+ tcmdPtr->startLevel = 0;
+ tcmdPtr->startCmd = NULL;
+ tcmdPtr->length = length;
+ flags |= TCL_TRACE_DELETE;
+ if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
+ flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
+ }
+ strcpy(tcmdPtr->command, command);
+ name = Tcl_GetString(objv[3]);
+ if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
+ (ClientData) tcmdPtr) != TCL_OK) {
+ ckfree((char *) tcmdPtr);
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Search through all of our traces on this command to
+ * see if there's one with the given command. If so, then
+ * delete the first one that matches.
+ */
+
+ TraceCommandInfo *tcmdPtr;
+ ClientData clientData;
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+ tcmdPtr = (TraceCommandInfo *) clientData;
+ /*
+ * In checking the 'flags' field we must remove any extraneous
+ * flags which may have been temporarily added by various pieces
+ * of the trace mechanism.
+ */
+ if ((tcmdPtr->length == length)
+ && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME |
+ TCL_TRACE_DELETE)) == flags)
+ && (strncmp(command, tcmdPtr->command,
+ (size_t) length) == 0)) {
+ flags |= TCL_TRACE_DELETE;
+ if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
+ flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
+ }
+ Tcl_UntraceCommand(interp, name,
+ flags, TraceCommandProc, clientData);
+ if (tcmdPtr->stepTrace != NULL) {
+ /*
+ * We need to remove the interpreter-wide trace
+ * which we created to allow 'step' traces.
+ */
+ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
+ tcmdPtr->stepTrace = NULL;
+ if (tcmdPtr->startCmd != NULL) {
+ ckfree((char *)tcmdPtr->startCmd);
+ }
+ }
+ /* Postpone deletion */
+ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
+ tcmdPtr->flags = 0;
+ } else {
+ Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
+ }
+ break;
+ }
+ }
+ }
+ break;
+ }
+ case TRACE_INFO: {
+ ClientData clientData;
+ Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 3, objv, "name");
+ return TCL_ERROR;
+ }
+
+ resultListPtr = Tcl_GetObjResult(interp);
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+
+ eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ /*
+ * Build a list with the ops list as the first obj
+ * element and the tcmdPtr->command string as the
+ * second obj element. Append this list (as an
+ * element) to the end of the result object list.
+ */
+
+ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("enter",6));
+ }
+ if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("leave",5));
+ }
+ if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("enterstep",9));
+ }
+ if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("leavestep",10));
+ }
+ Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
+
+ elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
+ Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr,
+ eachTraceObjPtr);
+ }
+ Tcl_SetObjResult(interp, resultListPtr);
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclTraceCommandObjCmd --
+ *
+ * Helper function for Tcl_TraceObjCmd; implements the
+ * [trace {add|info|remove} command ...] subcommands.
+ * See the user documentation for details on what these do.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * Depends on the operation (add, remove, or info) being performed;
+ * may add or remove command traces on a command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
+ Tcl_Interp *interp; /* Current interpreter. */
+ int optionIndex; /* Add, info or remove */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int commandLength, index;
+ char *name, *command;
+ size_t length;
+ enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
+ static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
+ enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
+
+ switch ((enum traceOptions) optionIndex) {
+ case TRACE_ADD:
+ case TRACE_REMOVE: {
+ int flags = 0;
+ int i, listLen, result;
+ Tcl_Obj **elemPtrs;
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
+ return TCL_ERROR;
+ }
+ /*
+ * Make sure the ops argument is a list object; get its length and
+ * a pointer to its array of element pointers.
+ */
+
+ result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (listLen == 0) {
+ Tcl_SetResult(interp, "bad operation list \"\": must be "
+ "one or more of delete or rename", TCL_STATIC);
+ return TCL_ERROR;
+ }
+ for (i = 0; i < listLen; i++) {
+ if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
+ "operation", TCL_EXACT, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum operations) index) {
+ case TRACE_CMD_RENAME:
+ flags |= TCL_TRACE_RENAME;
+ break;
+ case TRACE_CMD_DELETE:
+ flags |= TCL_TRACE_DELETE;
+ break;
+ }
+ }
+ command = Tcl_GetStringFromObj(objv[5], &commandLength);
+ length = (size_t) commandLength;
+ if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ TraceCommandInfo *tcmdPtr;
+ tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
+ (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ + length + 1));
+ tcmdPtr->flags = flags;
+ tcmdPtr->stepTrace = NULL;
+ tcmdPtr->startLevel = 0;
+ tcmdPtr->startCmd = NULL;
+ tcmdPtr->length = length;
+ flags |= TCL_TRACE_DELETE;
+ strcpy(tcmdPtr->command, command);
+ name = Tcl_GetString(objv[3]);
+ if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
+ (ClientData) tcmdPtr) != TCL_OK) {
+ ckfree((char *) tcmdPtr);
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Search through all of our traces on this command to
+ * see if there's one with the given command. If so, then
+ * delete the first one that matches.
+ */
+
+ TraceCommandInfo *tcmdPtr;
+ ClientData clientData;
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+ tcmdPtr = (TraceCommandInfo *) clientData;
+ if ((tcmdPtr->length == length)
+ && (tcmdPtr->flags == flags)
+ && (strncmp(command, tcmdPtr->command,
+ (size_t) length) == 0)) {
+ Tcl_UntraceCommand(interp, name,
+ flags | TCL_TRACE_DELETE,
+ TraceCommandProc, clientData);
+ ckfree((char *) tcmdPtr);
+ break;
+ }
+ }
+ }
+ break;
+ }
+ case TRACE_INFO: {
+ ClientData clientData;
+ Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 3, objv, "name");
+ return TCL_ERROR;
+ }
+
+ resultListPtr = Tcl_GetObjResult(interp);
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
+ TraceCommandProc, clientData)) != 0) {
+
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
+
+ eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
+ /*
+ * Build a list with the ops list as
+ * the first obj element and the tcmdPtr->command string
+ * as the second obj element. Append this list (as an
+ * element) to the end of the result object list.
+ */
+
+ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ if (tcmdPtr->flags & TCL_TRACE_RENAME) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("rename",6));
+ }
+ if (tcmdPtr->flags & TCL_TRACE_DELETE) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("delete",6));
+ }
+ Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
+
+ elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
+ Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr,
+ eachTraceObjPtr);
+ }
+ Tcl_SetObjResult(interp, resultListPtr);
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclTraceVariableObjCmd --
+ *
+ * Helper function for Tcl_TraceObjCmd; implements the
+ * [trace {add|info|remove} variable ...] subcommands.
+ * See the user documentation for details on what these do.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * Depends on the operation (add, remove, or info) being performed;
+ * may add or remove variable traces on a variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
+ Tcl_Interp *interp; /* Current interpreter. */
+ int optionIndex; /* Add, info or remove */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int commandLength, index;
+ char *name, *command;
+ size_t length;
+ enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
+ static CONST char *opStrings[] = { "array", "read", "unset", "write",
+ (char *) NULL };
+ enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
+ TRACE_VAR_WRITE };
+
+ switch ((enum traceOptions) optionIndex) {
+ case TRACE_ADD:
+ case TRACE_REMOVE: {
+ int flags = 0;
+ int i, listLen, result;
+ Tcl_Obj **elemPtrs;
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
+ return TCL_ERROR;
+ }
+ /*
+ * Make sure the ops argument is a list object; get its length and
+ * a pointer to its array of element pointers.
+ */
+
+ result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (listLen == 0) {
+ Tcl_SetResult(interp, "bad operation list \"\": must be "
+ "one or more of array, read, unset, or write",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+ for (i = 0; i < listLen ; i++) {
+ if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
+ "operation", TCL_EXACT, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum operations) index) {
+ case TRACE_VAR_ARRAY:
+ flags |= TCL_TRACE_ARRAY;
+ break;
+ case TRACE_VAR_READ:
+ flags |= TCL_TRACE_READS;
+ break;
+ case TRACE_VAR_UNSET:
+ flags |= TCL_TRACE_UNSETS;
+ break;
+ case TRACE_VAR_WRITE:
+ flags |= TCL_TRACE_WRITES;
+ break;
+ }
+ }
+ command = Tcl_GetStringFromObj(objv[5], &commandLength);
+ length = (size_t) commandLength;
+ if ((enum traceOptions) optionIndex == TRACE_ADD) {
+ TraceVarInfo *tvarPtr;
+ tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
+ (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
+ + length + 1));
+ tvarPtr->flags = flags;
+ tvarPtr->length = length;
+ flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
+ strcpy(tvarPtr->command, command);
+ name = Tcl_GetString(objv[3]);
+ if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
+ (ClientData) tvarPtr) != TCL_OK) {
+ ckfree((char *) tvarPtr);
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Search through all of our traces on this variable to
+ * see if there's one with the given command. If so, then
+ * delete the first one that matches.
+ */
+
+ TraceVarInfo *tvarPtr;
+ ClientData clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
+ TraceVarProc, clientData)) != 0) {
+ tvarPtr = (TraceVarInfo *) clientData;
+ if ((tvarPtr->length == length)
+ && (tvarPtr->flags == flags)
+ && (strncmp(command, tvarPtr->command,
+ (size_t) length) == 0)) {
+ Tcl_UntraceVar2(interp, name, NULL,
+ flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
+ TraceVarProc, clientData);
+ Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
+ break;
+ }
+ }
+ }
+ break;
+ }
+ case TRACE_INFO: {
+ ClientData clientData;
+ Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 3, objv, "name");
+ return TCL_ERROR;
+ }
+
+ resultListPtr = Tcl_GetObjResult(interp);
+ clientData = 0;
+ name = Tcl_GetString(objv[3]);
+ while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
+ TraceVarProc, clientData)) != 0) {
+
+ TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+
+ eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ /*
+ * Build a list with the ops list as
+ * the first obj element and the tcmdPtr->command string
+ * as the second obj element. Append this list (as an
+ * element) to the end of the result object list.
+ */
+
+ elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ if (tvarPtr->flags & TCL_TRACE_ARRAY) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("array", 5));
+ }
+ if (tvarPtr->flags & TCL_TRACE_READS) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("read", 4));
+ }
+ if (tvarPtr->flags & TCL_TRACE_WRITES) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("write", 5));
+ }
+ if (tvarPtr->flags & TCL_TRACE_UNSETS) {
+ Tcl_ListObjAppendElement(NULL, elemObjPtr,
+ Tcl_NewStringObj("unset", 5));
+ }
+ Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
+
+ elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
+ Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr,
+ eachTraceObjPtr);
+ }
+ Tcl_SetObjResult(interp, resultListPtr);
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CommandTraceInfo --
+ *
+ * Return the clientData value associated with a trace on a
+ * command. This procedure can also be used to step through
+ * all of the traces on a particular command that have the
+ * same trace procedure.
+ *
+ * Results:
+ * The return value is the clientData value associated with
+ * a trace on the given command. Information will only be
+ * returned for a trace with proc as trace procedure. If
+ * the clientData argument is NULL then the first such trace is
+ * returned; otherwise, the next relevant one after the one
+ * given by clientData will be returned. If the command
+ * doesn't exist, or if there are no (more) traces for it,
+ * then NULL is returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
+ Tcl_Interp *interp; /* Interpreter containing command. */
+ CONST char *cmdName; /* Name of command. */
+ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY (can be 0). */
+ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
+ ClientData prevClientData; /* If non-NULL, gives last value returned
+ * by this procedure, so this call will
+ * return the next trace after that one.
+ * If NULL, this call will return the
+ * first trace. */
+{
+ Command *cmdPtr;
+ register CommandTrace *tracePtr;
+
+ cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
+ NULL, TCL_LEAVE_ERR_MSG);
+ if (cmdPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Find the relevant trace, if any, and return its clientData.
+ */
+
+ tracePtr = cmdPtr->tracePtr;
+ if (prevClientData != NULL) {
+ for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
+ if ((tracePtr->clientData == prevClientData)
+ && (tracePtr->traceProc == proc)) {
+ tracePtr = tracePtr->nextPtr;
+ break;
+ }
+ }
+ }
+ for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
+ if (tracePtr->traceProc == proc) {
+ return tracePtr->clientData;
+ }
+ }
+ return NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_TraceCommand --
+ *
+ * Arrange for rename/deletes to a command to cause a
+ * procedure to be invoked, which can monitor the operations.
+ *
+ * Also optionally arrange for execution of that command
+ * to cause a procedure to be invoked.
+ *
+ * Results:
+ * A standard Tcl return value.
+ *
+ * Side effects:
+ * A trace is set up on the command given by cmdName, such that
+ * future changes to the command will be intermediated by
+ * proc. See the manual entry for complete details on the calling
+ * sequence for proc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
+ Tcl_Interp *interp; /* Interpreter in which command is
+ * to be traced. */
+ CONST char *cmdName; /* Name of command. */
+ int flags; /* OR-ed collection of bits, including any
+ * of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
+ * and any of the TRACE_*_EXEC flags */
+ Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are
+ * invoked upon varName. */
+ ClientData clientData; /* Arbitrary argument to pass to proc. */
+{
+ Command *cmdPtr;
+ register CommandTrace *tracePtr;
+
+ cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
+ NULL, TCL_LEAVE_ERR_MSG);
+ if (cmdPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Set up trace information.
+ */
+
+ tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
+ tracePtr->traceProc = proc;
+ tracePtr->clientData = clientData;
+ tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE
+ | TCL_TRACE_ANY_EXEC);
+ tracePtr->nextPtr = cmdPtr->tracePtr;
+ cmdPtr->tracePtr = tracePtr;
+ if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
+ cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UntraceCommand --
+ *
+ * Remove a previously-created trace for a command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If there exists a trace for the command given by cmdName
+ * with the given flags, proc, and clientData, then that trace
+ * is removed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
+ Tcl_Interp *interp; /* Interpreter containing command. */
+ CONST char *cmdName; /* Name of command. */
+ int flags; /* OR-ed collection of bits, including any
+ * of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
+ * and any of the TRACE_*_EXEC flags */
+ Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
+ ClientData clientData; /* Arbitrary argument to pass to proc. */
+{
+ register CommandTrace *tracePtr;
+ CommandTrace *prevPtr;
+ Command *cmdPtr;
+ Interp *iPtr = (Interp *) interp;
+ ActiveCommandTrace *activePtr;
+ int hasExecTraces = 0;
+
+ cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
+ NULL, TCL_LEAVE_ERR_MSG);
+ if (cmdPtr == NULL) {
+ return;
+ }
+
+ flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
+
+ for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
+ prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
+ if (tracePtr == NULL) {
+ return;
+ }
+ if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags)
+ && (tracePtr->clientData == clientData)) {
+ if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
+ hasExecTraces = 1;
+ }
+ break;
+ }
+ }
+
+ /*
+ * The code below makes it possible to delete traces while traces
+ * are active: it makes sure that the deleted trace won't be
+ * processed by CallCommandTraces.
+ */
+
+ for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
+ activePtr = activePtr->nextPtr) {
+ if (activePtr->nextTracePtr == tracePtr) {
+ activePtr->nextTracePtr = tracePtr->nextPtr;
+ }
+ }
+ if (prevPtr == NULL) {
+ cmdPtr->tracePtr = tracePtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = tracePtr->nextPtr;
+ }
+ tracePtr->flags = 0;
+ Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC);
+
+ if (hasExecTraces) {
+ for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
+ prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
+ if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
+ return;
+ }
+ }
+ /*
+ * None of the remaining traces on this command are execution
+ * traces. We therefore remove this flag:
+ */
+ cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TraceCommandProc --
+ *
+ * This procedure is called to handle command changes that have
+ * been traced using the "trace" command, when using the
+ * 'rename' or 'delete' options.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
-static char *
-TraceVarProc(clientData, interp, name1, name2, flags)
- ClientData clientData; /* Information about the variable trace. */
- Tcl_Interp *interp; /* Interpreter containing variable. */
- char *name1; /* Name of variable or array. */
- char *name2; /* Name of element within array; NULL means
- * scalar variable is being referenced. */
+static void
+TraceCommandProc(clientData, interp, oldName, newName, flags)
+ ClientData clientData; /* Information about the command trace. */
+ Tcl_Interp *interp; /* Interpreter containing command. */
+ CONST char *oldName; /* Name of command being changed. */
+ CONST char *newName; /* New name of command. Empty string
+ * or NULL means command is being deleted
+ * (renamed to ""). */
int flags; /* OR-ed bits giving operation and other
* information. */
{
Tcl_SavedResult state;
- TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
- char *result;
+ TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
-
- result = NULL;
- if (tvarPtr->errMsg != NULL) {
- ckfree(tvarPtr->errMsg);
- tvarPtr->errMsg = NULL;
- }
- if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
-
+
+ Tcl_Preserve((ClientData) tcmdPtr);
+
+ if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
/*
* Generate a command to execute by appending list elements
- * for the two variable names and the operation. The five
- * extra characters are for three space, the opcode character,
- * and the terminating null.
+ * for the old and new command name and the operation.
*/
- if (name2 == NULL) {
- name2 = "";
- }
Tcl_DStringInit(&cmd);
- Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
- Tcl_DStringAppendElement(&cmd, name1);
- Tcl_DStringAppendElement(&cmd, name2);
- if (flags & TCL_TRACE_READS) {
- Tcl_DStringAppend(&cmd, " r", 2);
- } else if (flags & TCL_TRACE_WRITES) {
- Tcl_DStringAppend(&cmd, " w", 2);
- } else if (flags & TCL_TRACE_UNSETS) {
- Tcl_DStringAppend(&cmd, " u", 2);
+ Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
+ Tcl_DStringAppendElement(&cmd, oldName);
+ Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
+ if (flags & TCL_TRACE_RENAME) {
+ Tcl_DStringAppend(&cmd, " rename", 7);
+ } else if (flags & TCL_TRACE_DELETE) {
+ Tcl_DStringAppend(&cmd, " delete", 7);
}
/*
* Execute the command. Save the interp's result used for
* the command. We discard any object result the command returns.
+ *
+ * Add the TCL_TRACE_DESTROYED flag to tcmdPtr to indicate to
+ * other areas that this will be destroyed by us, otherwise a
+ * double-free might occur depending on what the eval does.
*/
Tcl_SaveResult(interp, &state);
+ if (flags & TCL_TRACE_DESTROYED) {
+ tcmdPtr->flags |= TCL_TRACE_DESTROYED;
+ }
- code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
- if (code != TCL_OK) { /* copy error msg to result */
- char *string;
- int length;
-
- string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
- tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1));
- memcpy(tvarPtr->errMsg, string, (size_t) (length + 1));
- result = tvarPtr->errMsg;
+ code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
+ Tcl_DStringLength(&cmd), 0);
+ if (code != TCL_OK) {
+ /* We ignore errors in these traced commands */
}
Tcl_RestoreResult(interp, &state);
Tcl_DStringFree(&cmd);
}
+ /*
+ * We delete when the trace was destroyed or if this is a delete trace,
+ * because command deletes are unconditional, so the trace must go away.
+ */
+ if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
+ if (tcmdPtr->stepTrace != NULL) {
+ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
+ tcmdPtr->stepTrace = NULL;
+ if (tcmdPtr->startCmd != NULL) {
+ ckfree((char *)tcmdPtr->startCmd);
+ }
+ }
+ /* Postpone deletion, until exec trace returns */
+ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
+ tcmdPtr->flags = 0;
+ } else {
+ Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
+ }
+ }
+ Tcl_Release((ClientData) tcmdPtr);
+ return;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCheckExecutionTraces --
+ *
+ * Checks on all current command execution traces, and invokes
+ * procedures which have been registered. This procedure can be
+ * used by other code which performs execution to unify the
+ * tracing system, so that execution traces will function for that
+ * other code.
+ *
+ * For instance extensions like [incr Tcl] which use their
+ * own execution technique can make use of Tcl's tracing.
+ *
+ * This procedure is called by 'TclEvalObjvInternal'
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR, etc.
+ *
+ * Side effects:
+ * Those side effects made by any trace procedures called.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
+ Tcl_Interp *interp; /* The current interpreter. */
+ CONST char *command; /* Pointer to beginning of the current
+ * command string. */
+ int numChars; /* The number of characters in 'command'
+ * which are part of the command string. */
+ Command *cmdPtr; /* Points to command's Command struct. */
+ int code; /* The current result code. */
+ int traceFlags; /* Current tracing situation. */
+ int objc; /* Number of arguments for the command. */
+ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
+{
+ Interp *iPtr = (Interp *) interp;
+ CommandTrace *tracePtr, *lastTracePtr;
+ ActiveCommandTrace active;
+ int curLevel;
+ int traceCode = TCL_OK;
+ TraceCommandInfo* tcmdPtr;
+
+ if (command == NULL || cmdPtr->tracePtr == NULL) {
+ return(traceCode);
+ }
+
+ curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
+
+ active.nextPtr = iPtr->activeCmdTracePtr;
+ iPtr->activeCmdTracePtr = &active;
+
+ active.cmdPtr = cmdPtr;
+ lastTracePtr = NULL;
+ for ( tracePtr = cmdPtr->tracePtr;
+ (traceCode == TCL_OK) && (tracePtr != NULL);
+ tracePtr = active.nextTracePtr) {
+ if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
+ /* execute the trace command in order of creation for "leave" */
+ active.nextTracePtr = NULL;
+ tracePtr = cmdPtr->tracePtr;
+ while (tracePtr->nextPtr != lastTracePtr) {
+ active.nextTracePtr = tracePtr;
+ tracePtr = tracePtr->nextPtr;
+ }
+ } else {
+ active.nextTracePtr = tracePtr->nextPtr;
+ }
+ tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
+ if (tcmdPtr->flags != 0) {
+ tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
+ tcmdPtr->curCode = code;
+ traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
+ curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
+ }
+ lastTracePtr = tracePtr;
+ }
+ iPtr->activeCmdTracePtr = active.nextPtr;
+ return(traceCode);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCheckInterpTraces --
+ *
+ * Checks on all current traces, and invokes procedures which
+ * have been registered. This procedure can be used by other
+ * code which performs execution to unify the tracing system.
+ * For instance extensions like [incr Tcl] which use their
+ * own execution technique can make use of Tcl's tracing.
+ *
+ * This procedure is called by 'TclEvalObjvInternal'
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR, etc.
+ *
+ * Side effects:
+ * Those side effects made by any trace procedures called.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
+ Tcl_Interp *interp; /* The current interpreter. */
+ CONST char *command; /* Pointer to beginning of the current
+ * command string. */
+ int numChars; /* The number of characters in 'command'
+ * which are part of the command string. */
+ Command *cmdPtr; /* Points to command's Command struct. */
+ int code; /* The current result code. */
+ int traceFlags; /* Current tracing situation. */
+ int objc; /* Number of arguments for the command. */
+ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Trace *tracePtr, *lastTracePtr;
+ ActiveInterpTrace active;
+ int curLevel;
+ int traceCode = TCL_OK;
+ TraceCommandInfo* tcmdPtr;
+
+ if (command == NULL || iPtr->tracePtr == NULL ||
+ (iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
+ return(traceCode);
+ }
+
+ curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
+
+ active.nextPtr = iPtr->activeInterpTracePtr;
+ iPtr->activeInterpTracePtr = &active;
+
+ lastTracePtr = NULL;
+ for ( tracePtr = iPtr->tracePtr;
+ (traceCode == TCL_OK) && (tracePtr != NULL);
+ tracePtr = active.nextTracePtr) {
+ if (traceFlags & TCL_TRACE_ENTER_EXEC) {
+ /* execute the trace command in reverse order of creation
+ * for "enterstep" operation. The order is changed for
+ * ""enterstep" instead of for "leavestep as was done in
+ * TclCheckExecutionTraces because for step traces,
+ * Tcl_CreateObjTrace creates one more linked list of traces
+ * which results in one more reversal of trace invocation.
+ */
+ active.nextTracePtr = NULL;
+ tracePtr = iPtr->tracePtr;
+ while (tracePtr->nextPtr != lastTracePtr) {
+ active.nextTracePtr = tracePtr;
+ tracePtr = tracePtr->nextPtr;
+ }
+ } else {
+ active.nextTracePtr = tracePtr->nextPtr;
+ }
+ if (tracePtr->level > 0 && curLevel > tracePtr->level) {
+ continue;
+ }
+ if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
+ /*
+ * The proc invoked might delete the traced command which
+ * which might try to free tracePtr. We want to use tracePtr
+ * until the end of this if section, so we use
+ * Tcl_Preserve() and Tcl_Release() to be sureit is not
+ * freed while we still need it.
+ */
+ Tcl_Preserve((ClientData) tracePtr);
+ tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
+ if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) &&
+ ((tracePtr->flags & traceFlags) != 0)) {
+ tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
+ tcmdPtr->curFlags = traceFlags;
+ tcmdPtr->curCode = code;
+ traceCode = (tracePtr->proc)((ClientData)tcmdPtr,
+ (Tcl_Interp*)interp,
+ curLevel, command,
+ (Tcl_Command)cmdPtr,
+ objc, objv);
+ } else {
+ if (traceFlags & TCL_TRACE_ENTER_EXEC) {
+ /*
+ * Old-style interpreter-wide traces only trigger
+ * before the command is executed.
+ */
+ traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
+ command, numChars, objc, objv);
+ }
+ }
+ tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
+ Tcl_Release((ClientData) tracePtr);
+ }
+ lastTracePtr = tracePtr;
+ }
+ iPtr->activeInterpTracePtr = active.nextPtr;
+ return(traceCode);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * CallTraceProcedure --
+ *
+ * Invokes a trace procedure registered with an interpreter. These
+ * procedures trace command execution. Currently this trace procedure
+ * is called with the address of the string-based Tcl_CmdProc for the
+ * command, not the Tcl_ObjCmdProc.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Those side effects made by the trace procedure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
+ Tcl_Interp *interp; /* The current interpreter. */
+ register Trace *tracePtr; /* Describes the trace procedure to call. */
+ Command *cmdPtr; /* Points to command's Command struct. */
+ CONST char *command; /* Points to the first character of the
+ * command's source before substitutions. */
+ int numChars; /* The number of characters in the
+ * command's source. */
+ register int objc; /* Number of arguments for the command. */
+ Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *commandCopy;
+ int traceCode;
+
+ /*
+ * Copy the command characters into a new string.
+ */
+
+ commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
+ memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
+ commandCopy[numChars] = '\0';
+
+ /*
+ * Call the trace procedure then free allocated storage.
+ */
+
+ traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
+ iPtr->numLevels, commandCopy,
+ (Tcl_Command) cmdPtr, objc, objv );
+
+ ckfree((char *) commandCopy);
+ return(traceCode);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TraceExecutionProc --
+ *
+ * This procedure is invoked whenever code relevant to a
+ * 'trace execution' command is executed. It is called in one
+ * of two ways in Tcl's core:
+ *
+ * (i) by the TclCheckExecutionTraces, when an execution trace has been
+ * triggered.
+ * (ii) by TclCheckInterpTraces, when a prior execution trace has
+ * created a trace of the internals of a procedure, passing in
+ * this procedure as the one to be called.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR, etc.
+ *
+ * Side effects:
+ * May invoke an arbitrary Tcl procedure, and may create or
+ * delete an interpreter-wide trace.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
+ int level, CONST char* command, Tcl_Command cmdInfo,
+ int objc, struct Tcl_Obj *CONST objv[]) {
+ int call = 0;
+ Interp *iPtr = (Interp *) interp;
+ TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
+ int flags = tcmdPtr->curFlags;
+ int code = tcmdPtr->curCode;
+ int traceCode = TCL_OK;
+
+ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
+ /*
+ * Inside any kind of execution trace callback, we do
+ * not allow any further execution trace callbacks to
+ * be called for the same trace.
+ */
+ return(traceCode);
+ }
+
+ if (!(flags & TCL_INTERP_DESTROYED)) {
+ /*
+ * Check whether the current call is going to eval arbitrary
+ * Tcl code with a generated trace, or whether we are only
+ * going to setup interpreter-wide traces to implement the
+ * 'step' traces. This latter situation can happen if
+ * we create a command trace without either before or after
+ * operations, but with either of the step operations.
+ */
+ if (flags & TCL_TRACE_EXEC_DIRECT) {
+ call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
+ } else {
+ call = 1;
+ }
+ /*
+ * First, if we have returned back to the level at which we
+ * created an interpreter trace for enterstep and/or leavestep
+ * execution traces, we remove it here.
+ */
+ if (flags & TCL_TRACE_LEAVE_EXEC) {
+ if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)
+ && (strcmp(command, tcmdPtr->startCmd) == 0)) {
+ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
+ tcmdPtr->stepTrace = NULL;
+ if (tcmdPtr->startCmd != NULL) {
+ ckfree((char *)tcmdPtr->startCmd);
+ }
+ }
+ }
+
+ /*
+ * Second, create the tcl callback, if required.
+ */
+ if (call) {
+ Tcl_SavedResult state;
+ Tcl_DString cmd;
+ Tcl_DString sub;
+ int i;
+
+ Tcl_DStringInit(&cmd);
+ Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
+ /* Append command with arguments */
+ Tcl_DStringInit(&sub);
+ for (i = 0; i < objc; i++) {
+ char* str;
+ int len;
+ str = Tcl_GetStringFromObj(objv[i],&len);
+ Tcl_DStringAppendElement(&sub, str);
+ }
+ Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
+ Tcl_DStringFree(&sub);
+
+ if (flags & TCL_TRACE_ENTER_EXEC) {
+ /* Append trace operation */
+ if (flags & TCL_TRACE_EXEC_DIRECT) {
+ Tcl_DStringAppendElement(&cmd, "enter");
+ } else {
+ Tcl_DStringAppendElement(&cmd, "enterstep");
+ }
+ } else if (flags & TCL_TRACE_LEAVE_EXEC) {
+ Tcl_Obj* resultCode;
+ char* resultCodeStr;
+
+ /* Append result code */
+ resultCode = Tcl_NewIntObj(code);
+ resultCodeStr = Tcl_GetString(resultCode);
+ Tcl_DStringAppendElement(&cmd, resultCodeStr);
+ Tcl_DecrRefCount(resultCode);
+
+ /* Append result string */
+ Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));
+ /* Append trace operation */
+ if (flags & TCL_TRACE_EXEC_DIRECT) {
+ Tcl_DStringAppendElement(&cmd, "leave");
+ } else {
+ Tcl_DStringAppendElement(&cmd, "leavestep");
+ }
+ } else {
+ panic("TraceExecutionProc: bad flag combination");
+ }
+
+ /*
+ * Execute the command. Save the interp's result used for
+ * the command. We discard any object result the command returns.
+ */
+
+ Tcl_SaveResult(interp, &state);
+
+ tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
+ iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
+ Tcl_Preserve((ClientData)tcmdPtr);
+ /*
+ * This line can have quite arbitrary side-effects,
+ * including deleting the trace, the command being
+ * traced, or even the interpreter.
+ */
+ traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
+ tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
+ iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS;
+ if (tcmdPtr->flags == 0) {
+ flags |= TCL_TRACE_DESTROYED;
+ }
+
+ if (traceCode == TCL_OK) {
+ /* Restore result if trace execution was successful */
+ Tcl_RestoreResult(interp, &state);
+ }
+
+ Tcl_DStringFree(&cmd);
+ }
+
+ /*
+ * Third, if there are any step execution traces for this proc,
+ * we register an interpreter trace to invoke enterstep and/or
+ * leavestep traces.
+ * We also need to save the current stack level and the proc
+ * string in startLevel and startCmd so that we can delete this
+ * interpreter trace when it reaches the end of this proc.
+ */
+ if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
+ && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) {
+ tcmdPtr->startLevel = level;
+ tcmdPtr->startCmd =
+ (char *) ckalloc((unsigned) (strlen(command) + 1));
+ strcpy(tcmdPtr->startCmd, command);
+ tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
+ (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
+ TraceExecutionProc, (ClientData)tcmdPtr, NULL);
+ }
+ }
+ if (flags & TCL_TRACE_DESTROYED) {
+ if (tcmdPtr->stepTrace != NULL) {
+ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
+ tcmdPtr->stepTrace = NULL;
+ if (tcmdPtr->startCmd != NULL) {
+ ckfree((char *)tcmdPtr->startCmd);
+ }
+ }
+ Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC);
+ }
+ if (call) {
+ Tcl_Release((ClientData)tcmdPtr);
+ }
+ return(traceCode);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TraceVarProc --
+ *
+ * This procedure is called to handle variable accesses that have
+ * been traced using the "trace" command.
+ *
+ * Results:
+ * Normally returns NULL. If the trace command returns an error,
+ * then this procedure returns an error string.
+ *
+ * Side effects:
+ * Depends on the command associated with the trace.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static char *
+TraceVarProc(clientData, interp, name1, name2, flags)
+ ClientData clientData; /* Information about the variable trace. */
+ Tcl_Interp *interp; /* Interpreter containing variable. */
+ CONST char *name1; /* Name of variable or array. */
+ CONST char *name2; /* Name of element within array; NULL means
+ * scalar variable is being referenced. */
+ int flags; /* OR-ed bits giving operation and other
+ * information. */
+{
+ Tcl_SavedResult state;
+ TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+ char *result;
+ int code;
+ Tcl_DString cmd;
+
+ /*
+ * We might call Tcl_Eval() below, and that might evaluate
+ * [trace vdelete] which might try to free tvarPtr. We want
+ * to use tvarPtr until the end of this function, so we use
+ * Tcl_Preserve() and Tcl_Release() to be sure it is not
+ * freed while we still need it.
+ */
+
+ Tcl_Preserve((ClientData) tvarPtr);
+
+ result = NULL;
+ if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
+ if (tvarPtr->length != (size_t) 0) {
+ /*
+ * Generate a command to execute by appending list elements
+ * for the two variable names and the operation.
+ */
+
+ Tcl_DStringInit(&cmd);
+ Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
+ Tcl_DStringAppendElement(&cmd, name1);
+ Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
+ if (flags & TCL_TRACE_ARRAY) {
+ Tcl_DStringAppend(&cmd, " a", 2);
+ } else if (flags & TCL_TRACE_READS) {
+ Tcl_DStringAppend(&cmd, " r", 2);
+ } else if (flags & TCL_TRACE_WRITES) {
+ Tcl_DStringAppend(&cmd, " w", 2);
+ } else if (flags & TCL_TRACE_UNSETS) {
+ Tcl_DStringAppend(&cmd, " u", 2);
+ }
+ } else {
+#endif
+ if (flags & TCL_TRACE_ARRAY) {
+ Tcl_DStringAppend(&cmd, " array", 6);
+ } else if (flags & TCL_TRACE_READS) {
+ Tcl_DStringAppend(&cmd, " read", 5);
+ } else if (flags & TCL_TRACE_WRITES) {
+ Tcl_DStringAppend(&cmd, " write", 6);
+ } else if (flags & TCL_TRACE_UNSETS) {
+ Tcl_DStringAppend(&cmd, " unset", 6);
+ }
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ }
+#endif
+
+ /*
+ * Execute the command. Save the interp's result used for
+ * the command. We discard any object result the command returns.
+ *
+ * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
+ * other areas that this will be destroyed by us, otherwise a
+ * double-free might occur depending on what the eval does.
+ */
+
+ Tcl_SaveResult(interp, &state);
+ if (flags & TCL_TRACE_DESTROYED) {
+ tvarPtr->flags |= TCL_TRACE_DESTROYED;
+ }
+
+ code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
+ Tcl_DStringLength(&cmd), 0);
+ if (code != TCL_OK) { /* copy error msg to result */
+ register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(errMsgObj);
+ result = (char *) errMsgObj;
+ }
+
+ Tcl_RestoreResult(interp, &state);
+
+ Tcl_DStringFree(&cmd);
+ }
+ }
if (flags & TCL_TRACE_DESTROYED) {
- result = NULL;
- if (tvarPtr->errMsg != NULL) {
- ckfree(tvarPtr->errMsg);
+ if (result != NULL) {
+ register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
+
+ Tcl_DecrRefCount(errMsgObj);
+ result = NULL;
}
- ckfree((char *) tvarPtr);
+ Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
}
+ Tcl_Release((ClientData) tvarPtr);
return result;
}
\f
return result;
}
-
* Tcl commands into a sequence of instructions ("bytecodes").
*
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
-static void FreeForeachInfo _ANSI_ARGS_((
- ClientData clientData));
+static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
+static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
+ int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));
+
+/*
+ * Flags bits used by TclPushVarName.
+ */
+
+#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
+#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
/*
* The structures below define the AuxData types defined in this file.
/*
*----------------------------------------------------------------------
*
+ * TclCompileAppendCmd --
+ *
+ * Procedure called to compile the "append" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is normally TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message. If
+ * complation fails because the command requires a second level of
+ * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
+ * command should be compiled "out of line" by emitting code to
+ * invoke its command procedure (Tcl_AppendObjCmd) at runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "append" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileAppendCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int simpleVarName, isScalar, localIndex, numWords;
+ int code = TCL_OK;
+
+ numWords = parsePtr->numWords;
+ if (numWords == 1) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"append varName ?value value ...?\"",
+ -1);
+ return TCL_ERROR;
+ } else if (numWords == 2) {
+ /*
+ * append varName === set varName
+ */
+ return TclCompileSetCmd(interp, parsePtr, envPtr);
+ } else if (numWords > 3) {
+ /*
+ * APPEND instructions currently only handle one value
+ */
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we
+ * need to emit code to compute and push the name at runtime. We use a
+ * frame slot (entry in the array of local vars) if we are compiling a
+ * procedure body and if the name is simple text that does not include
+ * namespace qualifiers.
+ */
+
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+
+ code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar);
+ if (code != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * We are doing an assignment, otherwise TclCompileSetCmd was called,
+ * so push the new value. This will need to be extended to push a
+ * value for each argument.
+ */
+
+ if (numWords > 2) {
+ valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr,
+ valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
+ } else {
+ code = TclCompileTokens(interp, valueTokenPtr+1,
+ valueTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ }
+ }
+
+ /*
+ * Emit instructions to set/get the variable.
+ */
+
+ if (simpleVarName) {
+ if (isScalar) {
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
+ }
+ } else {
+ TclEmitOpcode(INST_APPEND_STK, envPtr);
+ }
+ } else {
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
+ }
+ } else {
+ TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
+ }
+ }
+ } else {
+ TclEmitOpcode(INST_APPEND_STK, envPtr);
+ }
+
+ done:
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileBreakCmd --
*
* Procedure called to compile the "break" command.
* there was an error during compilation. If an error occurs then
* the interpreter's result contains a standard error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "break" command
* at runtime.
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"break\"", -1);
- envPtr->maxStackDepth = 0;
return TCL_ERROR;
}
*/
TclEmitOpcode(INST_BREAK, envPtr);
- envPtr->maxStackDepth = 0;
return TCL_OK;
}
\f
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "catch" command
* at runtime.
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *nameTokenPtr;
- char *name;
- int localIndex, nameChars, range, maxDepth, startOffset, jumpDist;
+ CONST char *name;
+ int localIndex, nameChars, range, startOffset, jumpDist;
int code;
- char buffer[32 + TCL_INTEGER_SPACE];
+ int savedStackDepth = envPtr->currStackDepth;
- envPtr->maxStackDepth = 0;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
* We will compile the catch command. Emit a beginCatch instruction at
* the start of the catch body: the subcommand it controls.
*/
-
- maxDepth = 0;
envPtr->exceptDepth++;
envPtr->maxExceptDepth =
range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
- startOffset = (envPtr->codeNext - envPtr->codeStart);
+ /*
+ * If the body is a simple word, compile the instructions to
+ * eval it. Otherwise, compile instructions to substitute its
+ * text without catching, a catch instruction that resets the
+ * stack to what it was before substituting the body, and then
+ * an instruction to eval the body. Care has to be taken to
+ * register the correct startOffset for the catch range so that
+ * errors in the substitution are not catched [Bug 219184]
+ */
+
+ if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ startOffset = (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
+ } else {
+ code = TclCompileTokens(interp, cmdTokenPtr+1,
+ cmdTokenPtr->numComponents, envPtr);
+ startOffset = (envPtr->codeNext - envPtr->codeStart);
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
+ }
envPtr->exceptArrayPtr[range].codeOffset = startOffset;
- code = TclCompileCmdWord(interp, cmdTokenPtr+1,
- cmdTokenPtr->numComponents, envPtr);
+
if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"catch\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- }
+ code = TCL_OUT_LINE_COMPILE;
goto done;
}
- maxDepth = envPtr->maxStackDepth;
envPtr->exceptArrayPtr[range].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart) - startOffset;
}
}
TclEmitOpcode(INST_POP, envPtr);
- TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0),
- envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
/*
* the catch's error target.
*/
+ envPtr->currStackDepth = savedStackDepth;
envPtr->exceptArrayPtr[range].catchOffset =
(envPtr->codeNext - envPtr->codeStart);
if (localIndex != -1) {
}
TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+
/*
* Update the target of the jump after the "no errors" code, then emit
* an endCatch instruction at the end of the catch command.
TclEmitOpcode(INST_END_CATCH, envPtr);
done:
+ envPtr->currStackDepth = savedStackDepth + 1;
envPtr->exceptDepth--;
- envPtr->maxStackDepth = maxDepth;
return code;
}
\f
* there was an error while parsing string. If an error occurs then
* the interpreter's result contains a standard error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "continue" command
* at runtime.
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"continue\"", -1);
- envPtr->maxStackDepth = 0;
return TCL_ERROR;
}
*/
TclEmitOpcode(INST_CONTINUE, envPtr);
- envPtr->maxStackDepth = 0;
return TCL_OK;
}
\f
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "expr" command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "expr" command
* at runtime.
{
Tcl_Token *firstWordPtr;
- envPtr->maxStackDepth = 0;
if (parsePtr->numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
* there was an error while parsing string. If an error occurs then
* the interpreter's result contains a standard error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "for" command
* at runtime.
*
*----------------------------------------------------------------------
*/
-
int
TclCompileForCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
- JumpFixup jumpFalseFixup;
- int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist;
+ JumpFixup jumpEvalCondFixup;
+ int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange, code;
- unsigned char *jumpPc;
char buffer[32 + TCL_INTEGER_SPACE];
+ int savedStackDepth = envPtr->currStackDepth;
- envPtr->maxStackDepth = 0;
if (parsePtr->numWords != 5) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
}
/*
+ * Bail out also if the body or the next expression require substitutions
+ * in order to insure correct behaviour [Bug 219166]
+ */
+
+ nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
+ bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
+ if ((nextTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
+ || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
* Create ExceptionRange records for the body and the "next" command.
* The "next" command's ExceptionRange supports break but not continue
* (and has a -1 continueOffset).
* Inline compile the initial command.
*/
- maxDepth = 0;
code = TclCompileCmdWord(interp, startTokenPtr+1,
startTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
}
goto done;
}
- maxDepth = envPtr->maxStackDepth;
TclEmitOpcode(INST_POP, envPtr);
-
+
/*
- * Compile the test then emit the conditional jump that exits the for.
+ * Jump to the evaluation of the condition. This code uses the "loop
+ * rotation" optimisation (which eliminates one branch from the loop).
+ * "for start cond next body" produces then:
+ * start
+ * goto A
+ * B: body : bodyCodeOffset
+ * next : nextCodeOffset, continueOffset
+ * A: cond -> result : testCodeOffset
+ * if (result) goto B
*/
- testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"for\" test expression)", -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
/*
* Compile the loop body.
*/
- nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
- bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
- envPtr->exceptArrayPtr[bodyRange].codeOffset =
- (envPtr->codeNext - envPtr->codeStart);
+ bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"for\" body line %d)",
}
goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - envPtr->exceptArrayPtr[bodyRange].codeOffset;
+ (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
+
/*
* Compile the "next" subcommand.
*/
- envPtr->exceptArrayPtr[bodyRange].continueOffset =
- (envPtr->codeNext - envPtr->codeStart);
- envPtr->exceptArrayPtr[nextRange].codeOffset =
- (envPtr->codeNext - envPtr->codeStart);
+ nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+
+ envPtr->currStackDepth = savedStackDepth;
code = TclCompileCmdWord(interp, nextTokenPtr+1,
nextTokenPtr->numComponents, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
}
goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
envPtr->exceptArrayPtr[nextRange].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart)
- - envPtr->exceptArrayPtr[nextRange].codeOffset;
+ - nextCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Jump back to the test at the top of the loop. Generate a 4 byte jump
- * if the distance to the test is > 120 bytes. This is conservative and
- * ensures that we won't have to replace this jump if we later need to
- * replace the ifFalse jump with a 4 byte jump.
- */
-
- jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
- jumpBackDist = (jumpBackOffset - testCodeOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
- }
+ envPtr->currStackDepth = savedStackDepth;
/*
- * Fix the target of the jumpFalse after the test.
+ * Compile the test expression then emit the conditional jump that
+ * terminates the for.
*/
- jumpDist = (envPtr->codeNext - envPtr->codeStart)
- - jumpFalseFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body and "next" command ExceptionRanges since
- * they moved down.
- */
-
- envPtr->exceptArrayPtr[bodyRange].codeOffset += 3;
- envPtr->exceptArrayPtr[bodyRange].continueOffset += 3;
- envPtr->exceptArrayPtr[nextRange].codeOffset += 3;
-
- /*
- * Update the jump back to the test at the top of the loop since it
- * also moved down 3 bytes.
- */
+ testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- jumpBackDist += 3;
- if (jumpBackDist > 120) {
- TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
- } else {
- TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
+ jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
+ bodyCodeOffset += 3;
+ nextCodeOffset += 3;
+ testCodeOffset += 3;
+ }
+
+ envPtr->currStackDepth = savedStackDepth;
+ code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"for\" test expression)", -1);
}
+ goto done;
+ }
+ envPtr->currStackDepth = savedStackDepth + 1;
+
+ jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
+ if (jumpDist > 127) {
+ TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
}
/*
- * Set the loop's break target.
+ * Set the loop's offsets and break target.
*/
+ envPtr->exceptArrayPtr[bodyRange].codeOffset = bodyCodeOffset;
+ envPtr->exceptArrayPtr[bodyRange].continueOffset = nextCodeOffset;
+
+ envPtr->exceptArrayPtr[nextRange].codeOffset = nextCodeOffset;
+
envPtr->exceptArrayPtr[bodyRange].breakOffset =
envPtr->exceptArrayPtr[nextRange].breakOffset =
(envPtr->codeNext - envPtr->codeStart);
* The for command's result is an empty string.
*/
- TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
code = TCL_OK;
done:
- envPtr->maxStackDepth = maxDepth;
envPtr->exceptDepth--;
return code;
}
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "while" command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "foreach" command
* at runtime.
*
- *----------------------------------------------------------------------
+n*----------------------------------------------------------------------
*/
int
int loopCtTemp; /* Index of temp var holding the loop's
* iteration count. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
- char *varList;
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
- int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range;
+ int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
- char savedChar;
char buffer[32 + TCL_INTEGER_SPACE];
+ int savedStackDepth = envPtr->currStackDepth;
/*
* We parse the variable list argument words and create two arrays:
#define STATIC_VAR_LIST_SIZE 5
int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
- char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
+ CONST char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
int *varcList = varcListStaticSpace;
- char ***varvList = varvListStaticSpace;
+ CONST char ***varvList = varvListStaticSpace;
/*
* If the foreach command isn't in a procedure, don't compile it inline:
* the payoff is too small.
*/
- envPtr->maxStackDepth = 0;
if (procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
- maxDepth = 0;
-
numWords = parsePtr->numWords;
if ((numWords < 4) || (numWords%2 != 0)) {
Tcl_ResetResult(interp);
}
/*
+ * Bail out if the body requires substitutions
+ * in order to insure correct behaviour [Bug 219166]
+ */
+ for (i = 0, tokenPtr = parsePtr->tokenPtr;
+ i < numWords-1;
+ i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ }
+ bodyTokenPtr = tokenPtr;
+ if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
numLists = (numWords - 2)/2;
if (numLists > STATIC_VAR_LIST_SIZE) {
varcList = (int *) ckalloc(numLists * sizeof(int));
- varvList = (char ***) ckalloc(numLists * sizeof(char **));
+ varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
}
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
varcList[loopIndex] = 0;
- varvList[loopIndex] = (char **) NULL;
+ varvList[loopIndex] = NULL;
}
/*
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
code = TCL_OUT_LINE_COMPILE;
goto done;
- }
- varList = tokenPtr[1].start;
- savedChar = varList[tokenPtr[1].size];
-
- /*
- * Note there is a danger that modifying the string could have
- * undesirable side effects. In this case, Tcl_SplitList does
- * not have any dependencies on shared strings so we should be
- * safe.
- */
+ } else {
+ /* Lots of copying going on here. Need a ListObj wizard
+ * to show a better way. */
- varList[tokenPtr[1].size] = '\0';
- code = Tcl_SplitList(interp, varList,
- &varcList[loopIndex], &varvList[loopIndex]);
- varList[tokenPtr[1].size] = savedChar;
- if (code != TCL_OK) {
- goto done;
- }
+ Tcl_DString varList;
- numVars = varcList[loopIndex];
- for (j = 0; j < numVars; j++) {
- char *varName = varvList[loopIndex][j];
- if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
- code = TCL_OUT_LINE_COMPILE;
+ Tcl_DStringInit(&varList);
+ Tcl_DStringAppend(&varList, tokenPtr[1].start,
+ tokenPtr[1].size);
+ code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
+ &varcList[loopIndex], &varvList[loopIndex]);
+ Tcl_DStringFree(&varList);
+ if (code != TCL_OK) {
goto done;
}
+ numVars = varcList[loopIndex];
+ for (j = 0; j < numVars; j++) {
+ CONST char *varName = varvList[loopIndex][j];
+ if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
+ code = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+ }
}
loopIndex++;
}
sizeof(ForeachVarList) + (numVars * sizeof(int)));
varListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
- char *varName = varvList[loopIndex][j];
+ CONST char *varName = varvList[loopIndex][j];
int nameChars = strlen(varName);
varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
if (code != TCL_OK) {
goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
tempVar = (firstValueTemp + loopIndex);
if (tempVar <= 255) {
loopIndex++;
}
}
- bodyTokenPtr = tokenPtr;
/*
* Initialize the temporary var that holds the count of loop iterations.
(envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"foreach\" body line %d)",
}
goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
envPtr->exceptArrayPtr[range].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart)
- envPtr->exceptArrayPtr[range].codeOffset;
* The foreach command's result is an empty string.
*/
- TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
- if (varvList[loopIndex] != (char **) NULL) {
- ckfree((char *) varvList[loopIndex]);
- }
+ if (varvList[loopIndex] != (CONST char **) NULL) {
+ ckfree((char *) varvList[loopIndex]);
+ }
}
if (varcList != varcListStaticSpace) {
ckfree((char *) varcList);
ckfree((char *) varvList);
}
- envPtr->maxStackDepth = maxDepth;
envPtr->exceptDepth--;
return code;
}
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "if" command
* at runtime.
*
*----------------------------------------------------------------------
*/
-
int
TclCompileIfCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
* body to the end of the "if" when that PC
* is determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
- int jumpDist, jumpFalseDist, jumpIndex;
- int numWords, wordIdx, numBytes, maxDepth, j, code;
- char *word;
+ int jumpDist, jumpFalseDist;
+ int jumpIndex = 0; /* avoid compiler warning. */
+ int numWords, wordIdx, numBytes, j, code;
+ CONST char *word;
char buffer[100];
+ int savedStackDepth = envPtr->currStackDepth;
+ /* Saved stack depth at the start of the first
+ * test; the envPtr current depth is restored
+ * to this value at the start of each test. */
+ int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
+ int boolVal; /* value of static condition */
+ int compileScripts = 1;
+
+ /*
+ * Only compile the "if" command if all arguments are simple
+ * words, in order to insure correct substitution [Bug 219166]
+ */
+
+ tokenPtr = parsePtr->tokenPtr;
+ wordIdx = 0;
+ numWords = parsePtr->numWords;
+
+ for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+ tokenPtr += 2;
+ }
+
TclInitJumpFixupArray(&jumpFalseFixupArray);
TclInitJumpFixupArray(&jumpEndFixupArray);
- maxDepth = 0;
code = TCL_OK;
/*
tokenPtr = parsePtr->tokenPtr;
wordIdx = 0;
- numWords = parsePtr->numWords;
while (wordIdx < numWords) {
/*
* Stop looping if the token isn't "if" or "elseif".
*/
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- break;
- }
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((tokenPtr == parsePtr->tokenPtr)
/*
* Compile the test expression then emit the conditional jump
- * around the "then" part. If the expression word isn't simple,
- * we back off and compile the if command out-of-line.
+ * around the "then" part.
*/
+ envPtr->currStackDepth = savedStackDepth;
testTokenPtr = tokenPtr;
- code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"if\" test expression)", -1);
+
+
+ if (realCond) {
+ /*
+ * Find out if the condition is a constant.
+ */
+
+ Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
+ testTokenPtr[1].size);
+ Tcl_IncrRefCount(boolObj);
+ code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
+ Tcl_DecrRefCount(boolObj);
+ if (code == TCL_OK) {
+ /*
+ * A static condition
+ */
+ realCond = 0;
+ if (!boolVal) {
+ compileScripts = 0;
+ }
+ } else {
+ Tcl_ResetResult(interp);
+ code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"if\" test expression)", -1);
+ }
+ goto done;
+ }
+ if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpFalseFixupArray);
+ }
+ jumpIndex = jumpFalseFixupArray.next;
+ jumpFalseFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
+ &(jumpFalseFixupArray.fixup[jumpIndex]));
}
- goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFalseFixupArray);
- }
- jumpIndex = jumpFalseFixupArray.next;
- jumpFalseFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- &(jumpFalseFixupArray.fixup[jumpIndex]));
-
+
+
/*
* Skip over the optional "then" before the then clause.
*/
* Compile the "then" command body.
*/
- code = TclCompileCmdWord(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"if\" then script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- }
- goto done;
+ if (compileScripts) {
+ envPtr->currStackDepth = savedStackDepth;
+ code = TclCompileCmdWord(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"if\" then script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto done;
+ }
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- /*
- * Jump to the end of the "if" command. Both jumpFalseFixupArray and
- * jumpEndFixupArray are indexed by "jumpIndex".
- */
-
- if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
- TclExpandJumpFixupArray(&jumpEndFixupArray);
- }
- jumpEndFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &(jumpEndFixupArray.fixup[jumpIndex]));
+ if (realCond) {
+ /*
+ * Jump to the end of the "if" command. Both jumpFalseFixupArray and
+ * jumpEndFixupArray are indexed by "jumpIndex".
+ */
+
+ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpEndFixupArray);
+ }
+ jumpEndFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ &(jumpEndFixupArray.fixup[jumpIndex]));
+
+ /*
+ * Fix the target of the jumpFalse after the test. Generate a 4 byte
+ * jump if the distance is > 120 bytes. This is conservative, and
+ * ensures that we won't have to replace this jump if we later also
+ * need to replace the proceeding jump to the end of the "if" with a
+ * 4 byte jump.
+ */
- /*
- * Fix the target of the jumpFalse after the test. Generate a 4 byte
- * jump if the distance is > 120 bytes. This is conservative, and
- * ensures that we won't have to replace this jump if we later also
- * need to replace the proceeding jump to the end of the "if" with a
- * 4 byte jump.
- */
+ jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
+ if (TclFixupForwardJump(envPtr,
+ &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
+ /*
+ * Adjust the code offset for the proceeding jump to the end
+ * of the "if" command.
+ */
+
+ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
+ }
+ } else if (boolVal) {
+ /*
+ *We were processing an "if 1 {...}"; stop compiling
+ * scripts
+ */
- jumpDist = (envPtr->codeNext - envPtr->codeStart)
- - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
- if (TclFixupForwardJump(envPtr,
- &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
- /*
- * Adjust the code offset for the proceeding jump to the end
- * of the "if" command.
+ compileScripts = 0;
+ } else {
+ /*
+ *We were processing an "if 0 {...}"; reset so that
+ * the rest (elseif, else) is compiled correctly
*/
- jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
- }
+ realCond = 1;
+ compileScripts = 1;
+ }
tokenPtr += (tokenPtr->numComponents + 1);
wordIdx++;
}
/*
- * Check for the optional else clause.
+ * Restore the current stack depth in the environment; the
+ * "else" clause (or its default) will add 1 to this.
+ */
+
+ envPtr->currStackDepth = savedStackDepth;
+
+ /*
+ * Check for the optional else clause. Do not compile
+ * anything if this was an "if 1 {...}" case.
*/
if ((wordIdx < numWords)
/*
* There is an else clause. Skip over the optional "else" word.
*/
-
+
word = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
}
}
- /*
- * Compile the else command body.
- */
-
- code = TclCompileCmdWord(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- sprintf(buffer, "\n (\"if\" else script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
+ if (compileScripts) {
+ /*
+ * Compile the else command body.
+ */
+
+ code = TclCompileCmdWord(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"if\" else script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto done;
}
- goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
/*
* Make sure there are no words after the else clause.
* No else clause: the "if" command's result is an empty string.
*/
- TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr);
- maxDepth = TclMax(1, maxDepth);
+ if (compileScripts) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ }
}
/*
}
}
}
-
+
/*
* Free the jumpFixupArray array if malloc'ed storage was used.
*/
done:
+ envPtr->currStackDepth = savedStackDepth + 1;
TclFreeJumpFixupArray(&jumpFalseFixupArray);
TclFreeJumpFixupArray(&jumpEndFixupArray);
- envPtr->maxStackDepth = maxDepth;
return code;
}
\f
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "incr" command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "incr" command
* at runtime.
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *incrTokenPtr;
- Tcl_Parse elemParse;
- int gotElemParse = 0;
- char *name, *elName, *p;
- int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code;
- int maxDepth = 0;
- char buffer[160];
-
- envPtr->maxStackDepth = 0;
+ int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
+ int code = TCL_OK;
+
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"incr varName ?increment?\"", -1);
return TCL_ERROR;
}
-
- name = NULL;
- elName = NULL;
- elNameChars = 0;
- localIndex = -1;
- code = TCL_OK;
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
- /*
- * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
- * curly braces surround the variable name.
- * This really matters for array elements to handle things like
- * set {x($foo)} 5
- * which raises an undefined var error if we are not careful here.
- * This goes with the hack in TclCompileSetCmd.
- */
- if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
- (varTokenPtr->start[0] != '{')) {
- /*
- * A simple variable name. Divide it up into "name" and "elName"
- * strings. If it is not a local variable, look it up at runtime.
- */
-
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- for (i = 0, p = name; i < nameChars; i++, p++) {
- if (*p == '(') {
- char *openParen = p;
- p = (name + nameChars-1);
- if (*p == ')') { /* last char is ')' => array reference */
- nameChars = (openParen - name);
- elName = openParen+1;
- elNameChars = (p - elName);
- }
- break;
- }
- }
- if (envPtr->procPtr != NULL) {
- localIndex = TclFindCompiledLocal(name, nameChars,
- /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
- if (localIndex > 255) { /* we'll push the name */
- localIndex = -1;
- }
- }
- if (localIndex < 0) {
- TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,
- /*onHeap*/ 0), envPtr);
- maxDepth = 1;
- }
- /*
- * Compile the element script, if any.
- */
-
- if (elName != NULL) {
- /*
- * Temporarily replace the '(' and ')' by '"'s.
- */
-
- *(elName-1) = '"';
- *(elName+elNameChars) = '"';
- code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,
- /*nested*/ 0, &elemParse);
- *(elName-1) = '(';
- *(elName+elNameChars) = ')';
- gotElemParse = 1;
- if ((code != TCL_OK) || (elemParse.numWords > 1)) {
- sprintf(buffer, "\n (parsing index for array \"%.*s\")",
- TclMin(nameChars, 100), name);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- code = TCL_ERROR;
- goto done;
- } else if (elemParse.numWords == 1) {
- code = TclCompileTokens(interp, elemParse.tokenPtr+1,
- elemParse.tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
- maxDepth += envPtr->maxStackDepth;
- } else {
- TclEmitPush(TclRegisterLiteral(envPtr, "", 0,
- /*alreadyAlloced*/ 0), envPtr);
- maxDepth += 1;
- }
- }
- } else {
- /*
- * Not a simple variable name. Look it up at runtime.
- */
-
- code = TclCompileTokens(interp, varTokenPtr+1,
- varTokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
+ code = TclPushVarName(interp, varTokenPtr, envPtr,
+ (TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
+ &localIndex, &simpleVarName, &isScalar);
+ if (code != TCL_OK) {
+ goto done;
}
-
+
/*
* If an increment is given, push it, but see first if it's a small
* integer.
if (parsePtr->numWords == 3) {
incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- char *word = incrTokenPtr[1].start;
+ CONST char *word = incrTokenPtr[1].start;
int numBytes = incrTokenPtr[1].size;
- char savedChar = word[numBytes];
+ int validLength = TclParseInteger(word, numBytes);
long n;
-
+
/*
* Note there is a danger that modifying the string could have
* undesirable side effects. In this case, TclLooksLikeInt and
* should be safe.
*/
- word[numBytes] = '\0';
- if (TclLooksLikeInt(word, numBytes)
- && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) {
- if ((-127 <= n) && (n <= 127)) {
+ if (validLength == numBytes) {
+ int code;
+ Tcl_Obj *longObj = Tcl_NewStringObj(word, numBytes);
+ Tcl_IncrRefCount(longObj);
+ code = Tcl_GetLongFromObj(NULL, longObj, &n);
+ Tcl_DecrRefCount(longObj);
+ if ((code == TCL_OK) && (-127 <= n) && (n <= 127)) {
haveImmValue = 1;
immValue = n;
}
}
- word[numBytes] = savedChar;
if (!haveImmValue) {
- TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes,
- /*onHeap*/ 0), envPtr);
- maxDepth += 1;
+ TclEmitPush(
+ TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
}
} else {
code = TclCompileTokens(interp, incrTokenPtr+1,
}
goto done;
}
- maxDepth += envPtr->maxStackDepth;
}
} else { /* no incr amount given so use 1 */
haveImmValue = 1;
* Emit the instruction to increment the variable.
*/
- if (name != NULL) {
- if (elName == NULL) {
+ if (simpleVarName) {
+ if (isScalar) {
if (localIndex >= 0) {
if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex,
- envPtr);
+ TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
TclEmitInt1(immValue, envPtr);
} else {
TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
}
} else {
if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue,
- envPtr);
+ TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
} else {
TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
}
} else {
if (localIndex >= 0) {
if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex,
- envPtr);
+ TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
TclEmitInt1(immValue, envPtr);
} else {
TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
}
} else {
if (haveImmValue) {
- TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue,
- envPtr);
+ TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
} else {
TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
}
}
done:
- if (gotElemParse) {
- Tcl_FreeParse(&elemParse);
- }
- envPtr->maxStackDepth = maxDepth;
return code;
}
\f
/*
*----------------------------------------------------------------------
*
- * TclCompileSetCmd --
+ * TclCompileLappendCmd --
*
- * Procedure called to compile the "set" command.
+ * Procedure called to compile the "lappend" command.
*
* Results:
* The return value is a standard Tcl result, which is normally TCL_OK
* unless there was an error while parsing string. If an error occurs
* then the interpreter's result contains a standard error message. If
- * complation fails because the set command requires a second level of
+ * complation fails because the command requires a second level of
* substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
- * set command should be compiled "out of line" by emitting code to
- * invoke its command procedure (Tcl_SetCmd) at runtime.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the incr command.
+ * command should be compiled "out of line" by emitting code to
+ * invoke its command procedure (Tcl_LappendObjCmd) at runtime.
*
* Side effects:
- * Instructions are added to envPtr to execute the "set" command
+ * Instructions are added to envPtr to execute the "lappend" command
* at runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileSetCmd(interp, parsePtr, envPtr)
+TclCompileLappendCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- Tcl_Parse elemParse;
- int gotElemParse = 0;
- register char *p;
- char *name, *elName;
- int nameChars, elNameChars;
- register int i, n;
- int isAssignment, simpleVarName, localIndex, numWords;
- int maxDepth = 0;
+ int numValues, simpleVarName, isScalar, localIndex, numWords;
int code = TCL_OK;
- envPtr->maxStackDepth = 0;
+ /*
+ * If we're not in a procedure, don't compile.
+ */
+ if (envPtr->procPtr == NULL) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
numWords = parsePtr->numWords;
- if ((numWords != 2) && (numWords != 3)) {
+ if (numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"set varName ?newValue?\"", -1);
- return TCL_ERROR;
+ "wrong # args: should be \"lappend varName ?value value ...?\"", -1);
+ return TCL_ERROR;
}
- isAssignment = (numWords == 3);
+ if (numWords != 3) {
+ /*
+ * LAPPEND instructions currently only handle one value appends
+ */
+ return TCL_OUT_LINE_COMPILE;
+ }
+ numValues = (numWords - 2);
/*
* Decide if we can use a frame slot for the var/array name or if we
* namespace qualifiers.
*/
- simpleVarName = 0;
- name = elName = NULL;
- nameChars = elNameChars = 0;
- localIndex = -1;
-
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
+
+ code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar);
+ if (code != TCL_OK) {
+ goto done;
+ }
+
/*
- * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
- * curly braces surround the variable name.
- * This really matters for array elements to handle things like
- * set {x($foo)} 5
- * which raises an undefined var error if we are not careful here.
- * This goes with the hack in TclCompileIncrCmd.
+ * If we are doing an assignment, push the new value.
+ * In the no values case, create an empty object.
*/
- if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
- (varTokenPtr->start[0] != '{')) {
- simpleVarName = 1;
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- /* last char is ')' => potential array reference */
- if ( *(name + nameChars - 1) == ')') {
- for (i = 0, p = name; i < nameChars; i++, p++) {
- if (*p == '(') {
- elName = p + 1;
- elNameChars = nameChars - i - 2;
- nameChars = i ;
- break;
- }
+ if (numWords > 2) {
+ valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr,
+ valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
+ } else {
+ code = TclCompileTokens(interp, valueTokenPtr+1,
+ valueTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
}
}
-
+#if 0
+ } else {
/*
- * If elName contains any double quotes ("), we can't inline
- * compile the element script using the replace '()' by '"'
- * technique below.
- */
-
- for (i = 0, p = elName; i < elNameChars; i++, p++) {
- if (*p == '"') {
- simpleVarName = 0;
- break;
- }
- }
- } else if (((n = varTokenPtr->numComponents) > 1)
- && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
- simpleVarName = 0;
-
- /*
- * Check for parentheses inside first token
+ * We need to carefully handle the two arg case, as lappend
+ * always creates the variable.
*/
- for (i = 0, p = varTokenPtr[1].start;
- i < varTokenPtr[1].size; i++, p++) {
- if (*p == '(') {
- simpleVarName = 1;
- break;
- }
- }
- if (simpleVarName) {
- name = varTokenPtr[1].start;
- nameChars = p - varTokenPtr[1].start;
- elName = p + 1;
- elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
- /*
- * If elName contains any double quotes ("), we can't inline
- * compile the element script using the replace '()' by '"'
- * technique below.
- */
-
- for (i = 0, p = elName; i < elNameChars; i++, p++) {
- if (*p == '"') {
- simpleVarName = 0;
- break;
- }
- }
- }
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ numValues = 1;
+#endif
}
- if (simpleVarName) {
- /*
- * See whether name has any namespace separators (::'s).
- */
+ /*
+ * Emit instructions to set/get the variable.
+ */
- int hasNsQualifiers = 0;
- for (i = 0, p = name; i < nameChars; i++, p++) {
- if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
- hasNsQualifiers = 1;
- break;
+ /*
+ * The *_STK opcodes should be refactored to make better use of existing
+ * LOAD/STORE instructions.
+ */
+ if (simpleVarName) {
+ if (isScalar) {
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
+ }
+ } else {
+ TclEmitOpcode(INST_LAPPEND_STK, envPtr);
}
- }
-
- /*
- * Look up the var name's index in the array of local vars in the
- * proc frame. If retrieving the var's value and it doesn't already
- * exist, push its name and look it up at runtime.
- */
-
- if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
- localIndex = TclFindCompiledLocal(name, nameChars,
- /*create*/ isAssignment,
- /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
- envPtr->procPtr);
- }
- if (localIndex >= 0) {
- maxDepth = 0;
} else {
- TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,
- /*onHeap*/ 0), envPtr);
- maxDepth = 1;
- }
-
- /*
- * Compile the element script, if any.
- */
-
- if (elName != NULL) {
- /*
- * Temporarily replace the '(' and ')' by '"'s.
- */
-
- *(elName-1) = '"';
- *(elName+elNameChars) = '"';
- code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,
- /*nested*/ 0, &elemParse);
- *(elName-1) = '(';
- *(elName+elNameChars) = ')';
- gotElemParse = 1;
- if ((code != TCL_OK) || (elemParse.numWords > 1)) {
- char buffer[160];
- sprintf(buffer, "\n (parsing index for array \"%.*s\")",
- TclMin(nameChars, 100), name);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- code = TCL_ERROR;
- goto done;
- } else if (elemParse.numWords == 1) {
- code = TclCompileTokens(interp, elemParse.tokenPtr+1,
- elemParse.tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto done;
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
}
- maxDepth += envPtr->maxStackDepth;
} else {
- TclEmitPush(TclRegisterLiteral(envPtr, "", 0,
- /*alreadyAlloced*/ 0), envPtr);
- maxDepth += 1;
+ TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
}
}
} else {
+ TclEmitOpcode(INST_LAPPEND_STK, envPtr);
+ }
+
+ done:
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLindexCmd --
+ *
+ * Procedure called to compile the "lindex" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if the
+ * compilation was successful. If the command cannot be byte-compiled,
+ * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
+ * interpreter's result contains an error message, and TCL_ERROR is
+ * returned.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lindex" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLindexCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ int code, i;
+
+ int numWords;
+ numWords = parsePtr->numWords;
+
+ /*
+ * Quit if too few args
+ */
+
+ if ( numWords <= 1 ) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+
+ /*
+ * Push the operands onto the stack.
+ */
+
+ for ( i = 1 ; i < numWords ; i++ ) {
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(
+ TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
+ varTokenPtr[1].size), envPtr);
+ } else {
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ }
+
+ /*
+ * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI
+ * if there are multiple index args.
+ */
+
+ if ( numWords == 3 ) {
+ TclEmitOpcode( INST_LIST_INDEX, envPtr );
+ } else {
+ TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr );
+ }
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileListCmd --
+ *
+ * Procedure called to compile the "list" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is normally TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message. If
+ * complation fails because the command requires a second level of
+ * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
+ * command should be compiled "out of line" by emitting code to
+ * invoke its command procedure (Tcl_ListObjCmd) at runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "list" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileListCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ /*
+ * If we're not in a procedure, don't compile.
+ */
+ if (envPtr->procPtr == NULL) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * Empty args case
+ */
+
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ } else {
+ /*
+ * Push the all values onto the stack.
+ */
+ Tcl_Token *valueTokenPtr;
+ int i, code, numWords;
+
+ numWords = parsePtr->numWords;
+
+ valueTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ for (i = 1; i < numWords; i++) {
+ if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr,
+ valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
+ } else {
+ code = TclCompileTokens(interp, valueTokenPtr+1,
+ valueTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
+ }
+ TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
+ }
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLlengthCmd --
+ *
+ * Procedure called to compile the "llength" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if the
+ * compilation was successful. If the command cannot be byte-compiled,
+ * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
+ * interpreter's result contains an error message, and TCL_ERROR is
+ * returned.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "llength" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLlengthCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ int code;
+
+ if (parsePtr->numWords != 2) {
+ Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * We could simply count the number of elements here and push
+ * that value, but that is too rare a case to waste the code space.
+ */
+ TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
+ varTokenPtr[1].size), envPtr);
+ } else {
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ TclEmitOpcode(INST_LIST_LENGTH, envPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLsetCmd --
+ *
+ * Procedure called to compile the "lset" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * the compilation was successful. If the "lset" command is too
+ * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
+ * indicating that the command should be compiled "out of line"
+ * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
+ * returned, and the interpreter result contains an error message.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lset" command
+ * at runtime.
+ *
+ * The general template for execution of the "lset" command is:
+ * (1) Instructions to push the variable name, unless the
+ * variable is local to the stack frame.
+ * (2) If the variable is an array element, instructions
+ * to push the array element name.
+ * (3) Instructions to push each of zero or more "index" arguments
+ * to the stack, followed with the "newValue" element.
+ * (4) Instructions to duplicate the variable name and/or array
+ * element name onto the top of the stack, if either was
+ * pushed at steps (1) and (2).
+ * (5) The appropriate INST_LOAD_* instruction to place the
+ * original value of the list variable at top of stack.
+ * (6) At this point, the stack contains:
+ * varName? arrayElementName? index1 index2 ... newValue oldList
+ * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
+ * according as whether there is exactly one index element (LIST)
+ * or either zero or else two or more (FLAT). This instruction
+ * removes everything from the stack except for the two names
+ * and pushes the new value of the variable.
+ * (7) Finally, INST_STORE_* stores the new value in the variable
+ * and cleans up the stack.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLsetCmd( interp, parsePtr, envPtr )
+ Tcl_Interp* interp; /* Tcl interpreter for error reporting */
+ Tcl_Parse* parsePtr; /* Points to a parse structure for
+ * the command */
+ CompileEnv* envPtr; /* Holds the resulting instructions */
+{
+
+ int tempDepth; /* Depth used for emitting one part
+ * of the code burst. */
+ Tcl_Token* varTokenPtr; /* Pointer to the Tcl_Token representing
+ * the parse of the variable name */
+
+ int result; /* Status return from library calls */
+
+ int localIndex; /* Index of var in local var table */
+ int simpleVarName; /* Flag == 1 if var name is simple */
+ int isScalar; /* Flag == 1 if scalar, 0 if array */
+
+ int i;
+
+ /* Check argument count */
+
+ if ( parsePtr->numWords < 3 ) {
+ /* Fail at run time, not in compilation */
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we
+ * need to emit code to compute and push the name at runtime. We use a
+ * frame slot (entry in the array of local vars) if we are compiling a
+ * procedure body and if the name is simple text that does not include
+ * namespace qualifiers.
+ */
+
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ result = TclPushVarName( interp, varTokenPtr, envPtr,
+ TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ /* Push the "index" args and the new element value. */
+
+ for ( i = 2; i < parsePtr->numWords; ++i ) {
+
+ /* Advance to next arg */
+
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+
+ /* Push an arg */
+
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
+ varTokenPtr[1].size), envPtr);
+ } else {
+ result = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if ( result != TCL_OK ) {
+ return result;
+ }
+ }
+ }
+
+ /*
+ * Duplicate the variable name if it's been pushed.
+ */
+
+ if ( !simpleVarName || localIndex < 0 ) {
+ if ( !simpleVarName || isScalar ) {
+ tempDepth = parsePtr->numWords - 2;
+ } else {
+ tempDepth = parsePtr->numWords - 1;
+ }
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
+ }
+
+ /*
+ * Duplicate an array index if one's been pushed
+ */
+
+ if ( simpleVarName && !isScalar ) {
+ if ( localIndex < 0 ) {
+ tempDepth = parsePtr->numWords - 1;
+ } else {
+ tempDepth = parsePtr->numWords - 2;
+ }
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr );
+ }
+
+ /*
+ * Emit code to load the variable's value.
+ */
+
+ if ( !simpleVarName ) {
+ TclEmitOpcode( INST_LOAD_STK, envPtr );
+ } else if ( isScalar ) {
+ if ( localIndex < 0 ) {
+ TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr );
+ } else if ( localIndex < 0x100 ) {
+ TclEmitInstInt1( INST_LOAD_SCALAR1, localIndex, envPtr );
+ } else {
+ TclEmitInstInt4( INST_LOAD_SCALAR4, localIndex, envPtr );
+ }
+ } else {
+ if ( localIndex < 0 ) {
+ TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr );
+ } else if ( localIndex < 0x100 ) {
+ TclEmitInstInt1( INST_LOAD_ARRAY1, localIndex, envPtr );
+ } else {
+ TclEmitInstInt4( INST_LOAD_ARRAY4, localIndex, envPtr );
+ }
+ }
+
+ /*
+ * Emit the correct variety of 'lset' instruction
+ */
+
+ if ( parsePtr->numWords == 4 ) {
+ TclEmitOpcode( INST_LSET_LIST, envPtr );
+ } else {
+ TclEmitInstInt4( INST_LSET_FLAT, (parsePtr->numWords - 1), envPtr );
+ }
+
+ /*
+ * Emit code to put the value back in the variable
+ */
+
+ if ( !simpleVarName ) {
+ TclEmitOpcode( INST_STORE_STK, envPtr );
+ } else if ( isScalar ) {
+ if ( localIndex < 0 ) {
+ TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr );
+ } else if ( localIndex < 0x100 ) {
+ TclEmitInstInt1( INST_STORE_SCALAR1, localIndex, envPtr );
+ } else {
+ TclEmitInstInt4( INST_STORE_SCALAR4, localIndex, envPtr );
+ }
+ } else {
+ if ( localIndex < 0 ) {
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr );
+ } else if ( localIndex < 0x100 ) {
+ TclEmitInstInt1( INST_STORE_ARRAY1, localIndex, envPtr );
+ } else {
+ TclEmitInstInt4( INST_STORE_ARRAY4, localIndex, envPtr );
+ }
+ }
+
+ return TCL_OK;
+
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileRegexpCmd --
+ *
+ * Procedure called to compile the "regexp" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * the compilation was successful. If the "regexp" command is too
+ * complex for this function, then TCL_OUT_LINE_COMPILE is returned,
+ * indicating that the command should be compiled "out of line"
+ * (that is, not byte-compiled). If an error occurs, TCL_ERROR is
+ * returned, and the interpreter result contains an error message.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "regexp" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileRegexpCmd(interp, parsePtr, envPtr)
+ Tcl_Interp* interp; /* Tcl interpreter for error reporting */
+ Tcl_Parse* parsePtr; /* Points to a parse structure for
+ * the command */
+ CompileEnv* envPtr; /* Holds the resulting instructions */
+{
+ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing
+ * the parse of the RE or string */
+ int i, len, code, exactMatch, nocase;
+ char *str;
+
+ /*
+ * We are only interested in compiling simple regexp cases.
+ * Currently supported compile cases are:
+ * regexp ?-nocase? ?--? staticString $var
+ * regexp ?-nocase? ?--? {^staticString$} $var
+ */
+ if (parsePtr->numWords < 3) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ nocase = 0;
+ varTokenPtr = parsePtr->tokenPtr;
+
+ /*
+ * We only look for -nocase and -- as options. Everything else
+ * gets pushed to runtime execution. This is different than regexp's
+ * runtime option handling, but satisfies our stricter needs.
+ */
+ for (i = 1; i < parsePtr->numWords - 2; i++) {
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ /* Not a simple string - punt to runtime. */
+ return TCL_OUT_LINE_COMPILE;
+ }
+ str = (char *) varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
+ if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
+ i++;
+ break;
+ } else if ((len > 1)
+ && (strncmp(str, "-nocase", (unsigned) len) == 0)) {
+ nocase = 1;
+ } else {
+ /* Not an option we recognize. */
+ return TCL_OUT_LINE_COMPILE;
+ }
+ }
+
+ if ((parsePtr->numWords - i) != 2) {
+ /* We don't support capturing to variables */
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Get the regexp string. If it is not a simple string, punt to runtime.
+ * If it has a '-', it could be an incorrectly formed regexp command.
+ */
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ str = (char *) varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
+ if ((varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) || (*str == '-')) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ if (len == 0) {
+ /*
+ * The semantics of regexp are always match on re == "".
+ */
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * Make a copy of the string that is null-terminated for checks which
+ * require such.
+ */
+ str = (char *) ckalloc((unsigned) len + 1);
+ strncpy(str, varTokenPtr[1].start, (size_t) len);
+ str[len] = '\0';
+
+ /*
+ * On the first (pattern) arg, check to see if any RE special characters
+ * are in the word. If not, this is the same as 'string equal'.
+ */
+#if 0
+ if ((len > 2) && (*str == '.') && (str[1] == '*')) {
/*
- * The var name isn't simple: compile and push it.
+ * We can't modify the string after we have ckalloc'ed it, so this
+ * code will have to change before being used.
+ */
+ str += 2; len -= 2;
+ }
+ if ((len > 2) && (str[len-3] != '\\')
+ && (str[len-2] == '.') && (str[len-1] == '*')) {
+ len -= 2;
+ }
+#endif
+ if ((len > 1) && (str[0] == '^') && (str[len-1] == '$')
+ && (str[len-2] != '\\')) {
+ /*
+ * It appears and exact search was requested (ie ^foo$), so strip
+ * off the special chars and signal exactMatch. Defer the stripping
+ * to the TclEmitPush so the str ptr is not modified.
+ */
+ exactMatch = 1;
+ } else {
+ exactMatch = 0;
+ }
+
+ /*
+ * Don't do anything with REs with other special chars. Also check if
+ * this is a bad RE (do this at the end because it can be expensive).
+ * If so, let it complain at runtime.
+ */
+ if ((strpbrk(str, "*+?{}()[].\\|^$") != NULL)
+ || (Tcl_RegExpCompile(NULL, str) == NULL)) {
+ ckfree((char *) str);
+ return TCL_OUT_LINE_COMPILE;
+ }
+ if (exactMatch) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr, str+1, len-2), envPtr);
+ } else {
+ /*
+ * This needs to find the substring anywhere in the string, so
+ * use string match and *foo*.
*/
+ char *newStr = ckalloc((unsigned) len + 3);
+ newStr[0] = '*';
+ strncpy(newStr + 1, str, (size_t) len);
+ newStr[len+1] = '*';
+ newStr[len+2] = '\0';
+ TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len+2), envPtr);
+ ckfree((char *) newStr);
+ }
+ ckfree((char *) str);
+ /*
+ * Push the string arg
+ */
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr,
+ varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
+ } else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
- goto done;
+ return code;
}
- maxDepth += envPtr->maxStackDepth;
}
-
+
+ if (exactMatch && !nocase) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ }
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileReturnCmd --
+ *
+ * Procedure called to compile the "return" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if the
+ * compilation was successful. If the particular return command is
+ * too complex for this function (ie, return with any flags like "-code"
+ * or "-errorinfo"), TCL_OUT_LINE_COMPILE is returned, indicating that
+ * the command should be compiled "out of line" (eg, not byte compiled).
+ * If an error occurs then the interpreter's result contains a standard
+ * error message.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "return" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileReturnCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ int code;
+
+ /*
+ * If we're not in a procedure, don't compile.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ switch (parsePtr->numWords) {
+ case 1: {
+ /*
+ * Simple case: [return]
+ * Just push the literal string "".
+ */
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ break;
+ }
+ case 2: {
+ /*
+ * More complex cases:
+ * [return "foo"]
+ * [return $value]
+ * [return [otherCmd]]
+ */
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * [return "foo"] case: the parse token is a simple word,
+ * so just push it.
+ */
+ TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
+ varTokenPtr[1].size), envPtr);
+ } else {
+ /*
+ * Parse token is more complex, so compile it; this handles the
+ * variable reference and nested command cases. If the
+ * parse token can be byte-compiled, then this instance of
+ * "return" will be byte-compiled; otherwise it will be
+ * out line compiled.
+ */
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ break;
+ }
+ default: {
+ /*
+ * Most complex return cases: everything else, including
+ * [return -code error], etc.
+ */
+ return TCL_OUT_LINE_COMPILE;
+ }
+ }
+
+ /*
+ * The INST_DONE opcode actually causes the branching out of the
+ * subroutine, and takes the top stack item as the return result
+ * (which is why we pushed the value above).
+ */
+ TclEmitOpcode(INST_DONE, envPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileSetCmd --
+ *
+ * Procedure called to compile the "set" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is normally TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message. If
+ * complation fails because the set command requires a second level of
+ * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
+ * set command should be compiled "out of line" by emitting code to
+ * invoke its command procedure (Tcl_SetCmd) at runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "set" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileSetCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int isAssignment, isScalar, simpleVarName, localIndex, numWords;
+ int code = TCL_OK;
+
+ numWords = parsePtr->numWords;
+ if ((numWords != 2) && (numWords != 3)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"set varName ?newValue?\"", -1);
+ return TCL_ERROR;
+ }
+ isAssignment = (numWords == 3);
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we
+ * need to emit code to compute and push the name at runtime. We use a
+ * frame slot (entry in the array of local vars) if we are compiling a
+ * procedure body and if the name is simple text that does not include
+ * namespace qualifiers.
+ */
+
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+
+ code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
+ &localIndex, &simpleVarName, &isScalar);
+ if (code != TCL_OK) {
+ goto done;
+ }
+
/*
* If we are doing an assignment, push the new value.
*/
-
+
if (isAssignment) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start,
- valueTokenPtr[1].size, /*onHeap*/ 0), envPtr);
- maxDepth += 1;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
+ valueTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
- maxDepth += envPtr->maxStackDepth;
}
}
-
+
/*
* Emit instructions to set/get the variable.
*/
if (simpleVarName) {
- if (elName == NULL) {
+ if (isScalar) {
if (localIndex >= 0) {
if (localIndex <= 255) {
TclEmitInstInt1((isAssignment?
}
} else {
TclEmitOpcode((isAssignment?
- INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
- envPtr);
+ INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), envPtr);
}
} else {
if (localIndex >= 0) {
}
} else {
TclEmitOpcode((isAssignment?
- INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
- envPtr);
+ INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), envPtr);
+ }
+ }
+ } else {
+ TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
+ }
+
+ done:
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileStringCmd --
+ *
+ * Procedure called to compile the "string" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if the
+ * compilation was successful. If the command cannot be byte-compiled,
+ * TCL_OUT_LINE_COMPILE is returned. If an error occurs then the
+ * interpreter's result contains an error message, and TCL_ERROR is
+ * returned.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "string" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileStringCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *opTokenPtr, *varTokenPtr;
+ Tcl_Obj *opObj;
+ int index;
+ int code;
+
+ static CONST char *options[] = {
+ "bytelength", "compare", "equal", "first",
+ "index", "is", "last", "length",
+ "map", "match", "range", "repeat",
+ "replace", "tolower", "toupper", "totitle",
+ "trim", "trimleft", "trimright",
+ "wordend", "wordstart", (char *) NULL
+ };
+ enum options {
+ STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
+ STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
+ STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
+ STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
+ STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
+ STR_WORDEND, STR_WORDSTART
+ };
+
+ if (parsePtr->numWords < 2) {
+ /* Fail at run time, not in compilation */
+ return TCL_OUT_LINE_COMPILE;
+ }
+ opTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+
+ opObj = Tcl_NewStringObj(opTokenPtr->start, opTokenPtr->size);
+ if (Tcl_GetIndexFromObj(interp, opObj, options, "option", 0,
+ &index) != TCL_OK) {
+ Tcl_DecrRefCount(opObj);
+ Tcl_ResetResult(interp);
+ return TCL_OUT_LINE_COMPILE;
+ }
+ Tcl_DecrRefCount(opObj);
+
+ varTokenPtr = opTokenPtr + (opTokenPtr->numComponents + 1);
+
+ switch ((enum options) index) {
+ case STR_BYTELENGTH:
+ case STR_FIRST:
+ case STR_IS:
+ case STR_LAST:
+ case STR_MAP:
+ case STR_RANGE:
+ case STR_REPEAT:
+ case STR_REPLACE:
+ case STR_TOLOWER:
+ case STR_TOUPPER:
+ case STR_TOTITLE:
+ case STR_TRIM:
+ case STR_TRIMLEFT:
+ case STR_TRIMRIGHT:
+ case STR_WORDEND:
+ case STR_WORDSTART:
+ /*
+ * All other cases: compile out of line.
+ */
+ return TCL_OUT_LINE_COMPILE;
+
+ case STR_COMPARE:
+ case STR_EQUAL: {
+ int i;
+ /*
+ * If there are any flags to the command, we can't byte compile it
+ * because the INST_STR_EQ bytecode doesn't support flags.
+ */
+
+ if (parsePtr->numWords != 4) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Push the two operands onto the stack.
+ */
+
+ for (i = 0; i < 2; i++) {
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr,
+ varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
+ } else {
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ }
+
+ TclEmitOpcode(((((enum options) index) == STR_COMPARE) ?
+ INST_STR_CMP : INST_STR_EQ), envPtr);
+ return TCL_OK;
+ }
+ case STR_INDEX: {
+ int i;
+
+ if (parsePtr->numWords != 4) {
+ /* Fail at run time, not in compilation */
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Push the two operands onto the stack.
+ */
+
+ for (i = 0; i < 2; i++) {
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr,
+ varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
+ } else {
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ }
+
+ TclEmitOpcode(INST_STR_INDEX, envPtr);
+ return TCL_OK;
+ }
+ case STR_LENGTH: {
+ if (parsePtr->numWords != 3) {
+ /* Fail at run time, not in compilation */
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Here someone is asking for the length of a static string.
+ * Just push the actual character (not byte) length.
+ */
+ char buf[TCL_INTEGER_SPACE];
+ int len = Tcl_NumUtfChars(varTokenPtr[1].start,
+ varTokenPtr[1].size);
+ len = sprintf(buf, "%d", len);
+ TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
+ return TCL_OK;
+ } else {
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ TclEmitOpcode(INST_STR_LEN, envPtr);
+ return TCL_OK;
+ }
+ case STR_MATCH: {
+ int i, length, exactMatch = 0, nocase = 0;
+ CONST char *str;
+
+ if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
+ /* Fail at run time, not in compilation */
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ if (parsePtr->numWords == 5) {
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+ str = varTokenPtr[1].start;
+ length = varTokenPtr[1].size;
+ if ((length > 1) &&
+ strncmp(str, "-nocase", (size_t) length) == 0) {
+ nocase = 1;
+ } else {
+ /* Fail at run time, not in compilation */
+ return TCL_OUT_LINE_COMPILE;
+ }
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ }
+
+ for (i = 0; i < 2; i++) {
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ str = varTokenPtr[1].start;
+ length = varTokenPtr[1].size;
+ if (!nocase && (i == 0)) {
+ /*
+ * On the first (pattern) arg, check to see if any
+ * glob special characters are in the word '*[]?\\'.
+ * If not, this is the same as 'string equal'. We
+ * can use strpbrk here because the glob chars are all
+ * in the ascii-7 range. If -nocase was specified,
+ * we can't do this because INST_STR_EQ has no support
+ * for nocase.
+ */
+ Tcl_Obj *copy = Tcl_NewStringObj(str, length);
+ Tcl_IncrRefCount(copy);
+ exactMatch = (strpbrk(Tcl_GetString(copy),
+ "*[]?\\") == NULL);
+ Tcl_DecrRefCount(copy);
+ }
+ TclEmitPush(
+ TclRegisterNewLiteral(envPtr, str, length), envPtr);
+ } else {
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ }
+
+ if (exactMatch) {
+ TclEmitOpcode(INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+ }
+ return TCL_OK;
+ }
+ }
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileVariableCmd --
+ *
+ * Procedure called to reserve the local variables for the
+ * "variable" command. The command itself is *not* compiled.
+ *
+ * Results:
+ * Always returns TCL_OUT_LINE_COMPILE.
+ *
+ * Side effects:
+ * Indexed local variables are added to the environment.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclCompileVariableCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ int i, numWords;
+ CONST char *varName, *tail;
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ numWords = parsePtr->numWords;
+
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ for (i = 1; i < numWords; i += 2) {
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ varName = varTokenPtr[1].start;
+ tail = varName + varTokenPtr[1].size - 1;
+ if ((*tail == ')') || (tail < varName)) continue;
+ while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
+ tail--;
}
+ if ((*tail == ':') && (tail > varName)) {
+ tail++;
+ }
+ (void) TclFindCompiledLocal(tail, (tail-varName+1),
+ /*create*/ 1, /*flags*/ 0, envPtr->procPtr);
+ varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
- } else {
- TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK),
- envPtr);
- }
-
- done:
- if (gotElemParse) {
- Tcl_FreeParse(&elemParse);
}
- envPtr->maxStackDepth = maxDepth;
- return code;
+ return TCL_OUT_LINE_COMPILE;
}
\f
/*
* indicating that the while command should be compiled "out of line"
* by emitting code to invoke its command procedure at runtime.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "while" command.
- *
* Side effects:
* Instructions are added to envPtr to execute the "while" command
* at runtime.
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *testTokenPtr, *bodyTokenPtr;
- JumpFixup jumpFalseFixup;
- unsigned char *jumpPc;
- int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset;
- int range, maxDepth, code;
+ JumpFixup jumpEvalCondFixup;
+ int testCodeOffset, bodyCodeOffset, jumpDist;
+ int range, code;
char buffer[32 + TCL_INTEGER_SPACE];
+ int savedStackDepth = envPtr->currStackDepth;
+ int loopMayEnd = 1; /* This is set to 0 if it is recognized as
+ * an infinite loop. */
+ Tcl_Obj *boolObj;
+ int boolVal;
- envPtr->maxStackDepth = 0;
- maxDepth = 0;
if (parsePtr->numWords != 3) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
* If the test expression requires substitutions, don't compile the
* while command inline. E.g., the expression might cause the loop to
* never execute or execute forever, as in "while "$x < 5" {}".
+ *
+ * Bail out also if the body expression requires substitutions
+ * in order to insure correct behaviour [Bug 219166]
*/
testTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
- if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
+ if ((testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)
+ || (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD)) {
return TCL_OUT_LINE_COMPILE;
}
/*
+ * Find out if the condition is a constant.
+ */
+
+ boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
+ Tcl_IncrRefCount(boolObj);
+ code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
+ Tcl_DecrRefCount(boolObj);
+ if (code == TCL_OK) {
+ if (boolVal) {
+ /*
+ * it is an infinite loop
+ */
+
+ loopMayEnd = 0;
+ } else {
+ /*
+ * This is an empty loop: "while 0 {...}" or such.
+ * Compile no bytecodes.
+ */
+
+ goto pushResult;
+ }
+ }
+
+ /*
* Create a ExceptionRange record for the loop body. This is used to
* implement break and continue.
*/
envPtr->maxExceptDepth =
TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
- envPtr->exceptArrayPtr[range].continueOffset =
- (envPtr->codeNext - envPtr->codeStart);
/*
- * Compile the test expression then emit the conditional jump that
- * terminates the while. We already know it's a simple word.
+ * Jump to the evaluation of the condition. This code uses the "loop
+ * rotation" optimisation (which eliminates one branch from the loop).
+ * "while cond body" produces then:
+ * goto A
+ * B: body : bodyCodeOffset
+ * A: cond -> result : testCodeOffset, continueOffset
+ * if (result) goto B
+ *
+ * The infinite loop "while 1 body" produces:
+ * B: body : all three offsets here
+ * goto B
*/
- testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
- code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (code != TCL_OK) {
- if (code == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"while\" test expression)", -1);
- }
- goto error;
+ if (loopMayEnd) {
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpEvalCondFixup);
+ testCodeOffset = 0; /* avoid compiler warning */
+ } else {
+ testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
}
- maxDepth = envPtr->maxStackDepth;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+
/*
* Compile the loop body.
*/
- bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
- envPtr->exceptArrayPtr[range].codeOffset =
- (envPtr->codeNext - envPtr->codeStart);
+ bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
+ envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"while\" body line %d)",
}
goto error;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
envPtr->exceptArrayPtr[range].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - envPtr->exceptArrayPtr[range].codeOffset;
+ (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Jump back to the test at the top of the loop. Generate a 4 byte jump
- * if the distance to the test is > 120 bytes. This is conservative and
- * ensures that we won't have to replace this jump if we later need to
- * replace the ifFalse jump with a 4 byte jump.
- */
-
- jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
- jumpBackDist = (jumpBackOffset - testCodeOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
- }
/*
- * Fix the target of the jumpFalse after the test.
+ * Compile the test expression then emit the conditional jump that
+ * terminates the while. We already know it's a simple word.
*/
- jumpDist = (envPtr->codeNext - envPtr->codeStart)
- - jumpFalseFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body's starting PC offset since it moved down.
- */
-
- envPtr->exceptArrayPtr[range].codeOffset += 3;
-
- /*
- * Update the jump back to the test at the top of the loop since it
- * also moved down 3 bytes.
- */
-
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- jumpBackDist += 3;
- if (jumpBackDist > 120) {
- TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
+ if (loopMayEnd) {
+ testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
+ bodyCodeOffset += 3;
+ testCodeOffset += 3;
+ }
+ envPtr->currStackDepth = savedStackDepth;
+ code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"while\" test expression)", -1);
+ }
+ goto error;
+ }
+ envPtr->currStackDepth = savedStackDepth + 1;
+
+ jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
+ if (jumpDist > 127) {
+ TclEmitInstInt4(INST_JUMP_TRUE4, -jumpDist, envPtr);
} else {
- TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
+ TclEmitInstInt1(INST_JUMP_TRUE1, -jumpDist, envPtr);
}
+ } else {
+ jumpDist = (envPtr->codeNext - envPtr->codeStart) - bodyCodeOffset;
+ if (jumpDist > 127) {
+ TclEmitInstInt4(INST_JUMP4, -jumpDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, -jumpDist, envPtr);
+ }
}
+
/*
- * Set the loop's break target.
+ * Set the loop's body, continue and break offsets.
*/
+ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
+ envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
envPtr->exceptArrayPtr[range].breakOffset =
(envPtr->codeNext - envPtr->codeStart);
* The while command's result is an empty string.
*/
- TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
- envPtr->maxStackDepth = maxDepth;
+ pushResult:
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
envPtr->exceptDepth--;
return TCL_OK;
error:
- envPtr->maxStackDepth = maxDepth;
envPtr->exceptDepth--;
return code;
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPushVarName --
+ *
+ * Procedure used in the compiling where pushing a variable name
+ * is necessary (append, lappend, set).
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is normally TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "set" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
+ simpleVarNamePtr, isScalarPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Token *varTokenPtr; /* Points to a variable token. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+ int flags; /* takes TCL_CREATE_VAR or
+ * TCL_NO_LARGE_INDEX */
+ int *localIndexPtr; /* must not be NULL */
+ int *simpleVarNamePtr; /* must not be NULL */
+ int *isScalarPtr; /* must not be NULL */
+{
+ register CONST char *p;
+ CONST char *name, *elName;
+ register int i, n;
+ int nameChars, elNameChars, simpleVarName, localIndex;
+ int code = TCL_OK;
+
+ Tcl_Token *elemTokenPtr = NULL;
+ int elemTokenCount = 0;
+ int allocedTokens = 0;
+ int removedParen = 0;
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we
+ * need to emit code to compute and push the name at runtime. We use a
+ * frame slot (entry in the array of local vars) if we are compiling a
+ * procedure body and if the name is simple text that does not include
+ * namespace qualifiers.
+ */
+
+ simpleVarName = 0;
+ name = elName = NULL;
+ nameChars = elNameChars = 0;
+ localIndex = -1;
+
+ /*
+ * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
+ * curly braces surround the variable name.
+ * This really matters for array elements to handle things like
+ * set {x($foo)} 5
+ * which raises an undefined var error if we are not careful here.
+ */
+
+ if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
+ (varTokenPtr->start[0] != '{')) {
+ /*
+ * A simple variable name. Divide it up into "name" and "elName"
+ * strings. If it is not a local variable, look it up at runtime.
+ */
+ simpleVarName = 1;
+
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ if ( *(name + nameChars - 1) == ')') {
+ /*
+ * last char is ')' => potential array reference.
+ */
+
+ for (i = 0, p = name; i < nameChars; i++, p++) {
+ if (*p == '(') {
+ elName = p + 1;
+ elNameChars = nameChars - i - 2;
+ nameChars = i ;
+ break;
+ }
+ }
+
+ if ((elName != NULL) && elNameChars) {
+ /*
+ * An array element, the element name is a simple
+ * string: assemble the corresponding token.
+ */
+
+ elemTokenPtr = (Tcl_Token *) ckalloc(sizeof(Tcl_Token));
+ allocedTokens = 1;
+ elemTokenPtr->type = TCL_TOKEN_TEXT;
+ elemTokenPtr->start = elName;
+ elemTokenPtr->size = elNameChars;
+ elemTokenPtr->numComponents = 0;
+ elemTokenCount = 1;
+ }
+ }
+ } else if (((n = varTokenPtr->numComponents) > 1)
+ && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
+ && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
+ && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
+
+ /*
+ * Check for parentheses inside first token
+ */
+
+ simpleVarName = 0;
+ for (i = 0, p = varTokenPtr[1].start;
+ i < varTokenPtr[1].size; i++, p++) {
+ if (*p == '(') {
+ simpleVarName = 1;
+ break;
+ }
+ }
+ if (simpleVarName) {
+ int remainingChars;
+
+ /*
+ * Check the last token: if it is just ')', do not count
+ * it. Otherwise, remove the ')' and flag so that it is
+ * restored at the end.
+ */
+
+ if (varTokenPtr[n].size == 1) {
+ --n;
+ } else {
+ --varTokenPtr[n].size;
+ removedParen = n;
+ }
+
+ name = varTokenPtr[1].start;
+ nameChars = p - varTokenPtr[1].start;
+ elName = p + 1;
+ remainingChars = (varTokenPtr[2].start - p) - 1;
+ elNameChars = (varTokenPtr[n].start - p) + varTokenPtr[n].size - 2;
+
+ if (remainingChars) {
+ /*
+ * Make a first token with the extra characters in the first
+ * token.
+ */
+
+ elemTokenPtr = (Tcl_Token *) ckalloc(n * sizeof(Tcl_Token));
+ allocedTokens = 1;
+ elemTokenPtr->type = TCL_TOKEN_TEXT;
+ elemTokenPtr->start = elName;
+ elemTokenPtr->size = remainingChars;
+ elemTokenPtr->numComponents = 0;
+ elemTokenCount = n;
+
+ /*
+ * Copy the remaining tokens.
+ */
+
+ memcpy((void *) (elemTokenPtr+1), (void *) (&varTokenPtr[2]),
+ ((n-1) * sizeof(Tcl_Token)));
+ } else {
+ /*
+ * Use the already available tokens.
+ */
+
+ elemTokenPtr = &varTokenPtr[2];
+ elemTokenCount = n - 1;
+ }
+ }
+ }
+
+ if (simpleVarName) {
+ /*
+ * See whether name has any namespace separators (::'s).
+ */
+
+ int hasNsQualifiers = 0;
+ for (i = 0, p = name; i < nameChars; i++, p++) {
+ if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
+ hasNsQualifiers = 1;
+ break;
+ }
+ }
+
+ /*
+ * Look up the var name's index in the array of local vars in the
+ * proc frame. If retrieving the var's value and it doesn't already
+ * exist, push its name and look it up at runtime.
+ */
+
+ if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
+ localIndex = TclFindCompiledLocal(name, nameChars,
+ /*create*/ (flags & TCL_CREATE_VAR),
+ /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
+ envPtr->procPtr);
+ if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
+ /* we'll push the name */
+ localIndex = -1;
+ }
+ }
+ if (localIndex < 0) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
+ }
+
+ /*
+ * Compile the element script, if any.
+ */
+ if (elName != NULL) {
+ if (elNameChars) {
+ code = TclCompileTokens(interp, elemTokenPtr,
+ elemTokenCount, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ } else {
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ }
+ }
+ } else {
+ /*
+ * The var name isn't simple: compile and push it.
+ */
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ }
+ done:
+ if (removedParen) {
+ ++varTokenPtr[removedParen].size;
+ }
+ if (allocedTokens) {
+ ckfree((char *) elemTokenPtr);
+ }
+ *localIndexPtr = localIndex;
+ *simpleVarNamePtr = simpleVarName;
+ *isScalarPtr = (elName == NULL);
+ return code;
+}
* This file contains the code to compile Tcl expressions.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Structure filled with information about
* the parsed expression. */
- char *expr; /* The expression that was originally passed
+ CONST char *expr; /* The expression that was originally passed
* to TclCompileExpr. */
- char *lastChar; /* Points just after last byte of expr. */
+ CONST char *lastChar; /* Points just after last byte of expr. */
int hasOperators; /* Set 1 if the expr has operators; 0 if
* expr is only a primary. If 1 after
* compiling an expr, a tryCvtToNumeric
* instruction is emitted to convert the
* primary to a number if possible. */
- int exprIsJustVarRef; /* Set 1 if the expr consists of just a
- * variable reference as in the expression
- * of "if $b then...". Otherwise 0. If 1 the
- * expr is compiled out-of-line in order to
- * implement expr's 2 level substitution
- * semantics properly. */
- int exprIsComparison; /* Set 1 if the top-level operator in the
- * expr is a comparison. Otherwise 0. If 1,
- * because the operands might be strings,
- * the expr is compiled out-of-line in order
- * to implement expr's 2 level substitution
- * semantics properly. */
} ExprInfo;
/*
#define OP_QUESTY 18
#define OP_LNOT 19
#define OP_BITNOT 20
+#define OP_STREQ 21
+#define OP_STRNEQ 22
/*
* Table describing the expression operators. Entries in this table must
* Ignored if numOperands is 0. */
} OperatorDesc;
-OperatorDesc operatorTable[] = {
+static OperatorDesc operatorTable[] = {
{"*", 2, INST_MULT},
{"/", 2, INST_DIV},
{"%", 2, INST_MOD},
{"?", 0},
{"!", 1, INST_LNOT},
{"~", 1, INST_BITNOT},
+ {"eq", 2, INST_STR_EQ},
+ {"ne", 2, INST_STR_NEQ},
{NULL}
};
ExprInfo *infoPtr, CompileEnv *envPtr,
Tcl_Token **endPtrPtr));
static int CompileMathFuncCall _ANSI_ARGS_((
- Tcl_Token *exprTokenPtr, char *funcName,
+ Tcl_Token *exprTokenPtr, CONST char *funcName,
ExprInfo *infoPtr, CompileEnv *envPtr,
Tcl_Token **endPtrPtr));
static int CompileSubExpr _ANSI_ARGS_((
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * envPtr->exprIsJustVarRef is set 1 if the expression consisted of
- * a single variable reference as in the expression of "if $b then...".
- * Otherwise it is set 0. This is used to implement Tcl's two level
- * expression substitution semantics properly.
- *
- * envPtr->exprIsComparison is set 1 if the top-level operator in the
- * expr is a comparison. Otherwise it is set 0. If 1, because the
- * operands might be strings, the expr is compiled out-of-line in order
- * to implement expr's 2 level substitution semantics properly.
- *
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
int
TclCompileExpr(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *script; /* The source script to compile. */
+ CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* string consists of all bytes up to the
* first null character. */
ExprInfo info;
Tcl_Parse parse;
Tcl_HashEntry *hPtr;
- int maxDepth, new, i, code;
+ int new, i, code;
/*
* If this is the first time we've been called, initialize the table
info.expr = script;
info.lastChar = (script + numBytes);
info.hasOperators = 0;
- info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */
- info.exprIsComparison = 0;
/*
* Parse the expression then compile it.
*/
- maxDepth = 0;
code = Tcl_ParseExpr(interp, script, numBytes, &parse);
if (code != TCL_OK) {
goto done;
Tcl_FreeParse(&parse);
goto done;
}
- maxDepth = envPtr->maxStackDepth;
if (!info.hasOperators) {
/*
Tcl_FreeParse(&parse);
done:
- envPtr->maxStackDepth = maxDepth;
- envPtr->exprIsJustVarRef = info.exprIsJustVarRef;
- envPtr->exprIsComparison = info.exprIsComparison;
return code;
}
\f
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the subexpression.
- *
- * envPtr->exprIsJustVarRef is set 1 if the subexpression consisted of
- * a single variable reference as in the expression of "if $b then...".
- * Otherwise it is set 0. This is used to implement Tcl's two level
- * expression substitution semantics properly.
- *
- * envPtr->exprIsComparison is set 1 if the top-level operator in the
- * subexpression is a comparison. Otherwise it is set 0. If 1, because
- * the operands might be strings, the expr is compiled out-of-line in
- * order to implement expr's 2 level substitution semantics properly.
- *
* Side effects:
* Adds instructions to envPtr to evaluate the subexpression.
*
Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
OperatorDesc *opDescPtr;
Tcl_HashEntry *hPtr;
- char *operator;
- int maxDepth, objIndex, opIndex, length, code;
+ CONST char *operator;
+ Tcl_DString opBuf;
+ int objIndex, opIndex, length, code;
char buffer[TCL_UTF_MAX];
if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
exprTokenPtr->type);
}
- maxDepth = 0;
code = TCL_OK;
/*
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += (tokenPtr->numComponents + 1);
- infoPtr->exprIsJustVarRef = 0;
break;
case TCL_TOKEN_TEXT:
if (tokenPtr->size > 0) {
- objIndex = TclRegisterLiteral(envPtr, tokenPtr->start,
- tokenPtr->size, /*onHeap*/ 0);
+ objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start,
+ tokenPtr->size);
} else {
- objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
+ objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
tokenPtr += 1;
- infoPtr->exprIsJustVarRef = 0;
break;
case TCL_TOKEN_BS:
length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
buffer);
if (length > 0) {
- objIndex = TclRegisterLiteral(envPtr, buffer, length,
- /*onHeap*/ 0);
+ objIndex = TclRegisterNewLiteral(envPtr, buffer, length);
} else {
- objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
+ objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
tokenPtr += 1;
- infoPtr->exprIsJustVarRef = 0;
break;
case TCL_TOKEN_COMMAND:
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += 1;
- infoPtr->exprIsJustVarRef = 0;
break;
case TCL_TOKEN_VARIABLE:
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_SUB_EXPR:
- infoPtr->exprIsComparison = 0;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += (tokenPtr->numComponents + 1);
break;
- case TCL_TOKEN_OPERATOR: {
- Tcl_DString operatorDString;
-
- Tcl_DStringInit(&operatorDString);
- Tcl_DStringAppend(&operatorDString, tokenPtr->start,
- tokenPtr->size);
- operator = Tcl_DStringValue(&operatorDString);
+ case TCL_TOKEN_OPERATOR:
+ /*
+ * Look up the operator. If the operator isn't found, treat it
+ * as a math function.
+ */
+ Tcl_DStringInit(&opBuf);
+ operator = Tcl_DStringAppend(&opBuf,
+ tokenPtr->start, tokenPtr->size);
hPtr = Tcl_FindHashEntry(&opHashTable, operator);
if (hPtr == NULL) {
code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
envPtr, &endPtr);
- Tcl_DStringFree(&operatorDString);
+ Tcl_DStringFree(&opBuf);
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr = endPtr;
- infoPtr->exprIsJustVarRef = 0;
- infoPtr->exprIsComparison = 0;
break;
}
- Tcl_DStringFree(&operatorDString);
+ Tcl_DStringFree(&opBuf);
opIndex = (int) Tcl_GetHashValue(hPtr);
opDescPtr = &(operatorTable[opIndex]);
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += (tokenPtr->numComponents + 1);
if (opDescPtr->numOperands == 2) {
if (code != TCL_OK) {
goto done;
}
- maxDepth = TclMax((envPtr->maxStackDepth + 1),
- maxDepth);
tokenPtr += (tokenPtr->numComponents + 1);
}
TclEmitOpcode(opDescPtr->instruction, envPtr);
infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- infoPtr->exprIsComparison =
- ((opIndex >= OP_LESS) && (opIndex <= OP_NEQ));
break;
}
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += (tokenPtr->numComponents + 1);
/*
if (code != TCL_OK) {
goto done;
}
- maxDepth = TclMax((envPtr->maxStackDepth + 1),
- maxDepth);
tokenPtr += (tokenPtr->numComponents + 1);
TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB),
envPtr);
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr = endPtr;
break;
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr = endPtr;
break;
opIndex);
} /* end switch on operator requiring special treatment */
infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- infoPtr->exprIsComparison = 0;
break;
- }
default:
panic("CompileSubExpr: unexpected token type %d\n",
}
done:
- envPtr->maxStackDepth = maxDepth;
return code;
}
\f
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
/* Used to fix up jumps used to convert the
* first operand to 0 or 1. */
Tcl_Token *tokenPtr;
- int dist, maxDepth, code;
+ int dist, code;
+ int savedStackDepth = envPtr->currStackDepth;
/*
* Emit code for the first operand.
*/
- maxDepth = 0;
tokenPtr = exprTokenPtr+2;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += (tokenPtr->numComponents + 1);
/*
*/
TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
- TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr);
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
badDist:
panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
}
- TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr);
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
goto badDist;
if (code != TCL_OK) {
goto done;
}
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
tokenPtr += (tokenPtr->numComponents + 1);
/*
*endPtrPtr = tokenPtr;
done:
- envPtr->maxStackDepth = maxDepth;
+ envPtr->currStackDepth = savedStackDepth + 1;
return code;
}
\f
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
* around the then and else expressions when
* their target PCs are determined. */
Tcl_Token *tokenPtr;
- int elseCodeOffset, dist, maxDepth, code;
+ int elseCodeOffset, dist, code;
+ int savedStackDepth = envPtr->currStackDepth;
/*
* Emit code for the test.
*/
- maxDepth = 0;
tokenPtr = exprTokenPtr+2;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
tokenPtr += (tokenPtr->numComponents + 1);
/*
if (code != TCL_OK) {
goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
tokenPtr += (tokenPtr->numComponents + 1);
if (!infoPtr->hasOperators) {
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
* Compile the "else" expression.
*/
+ envPtr->currStackDepth = savedStackDepth;
elseCodeOffset = (envPtr->codeNext - envPtr->codeStart);
infoPtr->hasOperators = 0;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
tokenPtr += (tokenPtr->numComponents + 1);
if (!infoPtr->hasOperators) {
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
*endPtrPtr = tokenPtr;
done:
- envPtr->maxStackDepth = maxDepth;
+ envPtr->currStackDepth = savedStackDepth + 1;
return code;
}
\f
* endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the function.
- *
* Side effects:
* Adds instructions to envPtr to evaluate the math function at
* runtime.
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the math function call. */
- char *funcName; /* Name of the math function. */
+ CONST char *funcName; /* Name of the math function. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
MathFunc *mathFuncPtr;
Tcl_HashEntry *hPtr;
Tcl_Token *tokenPtr, *afterSubexprPtr;
- int maxDepth, code, i;
+ int code, i;
/*
* Look up the MathFunc record for the function.
*/
code = TCL_OK;
- maxDepth = 0;
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
*/
if (mathFuncPtr->builtinFuncIndex < 0) {
- TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0),
- envPtr);
- maxDepth = 1;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr);
}
/*
code = TCL_ERROR;
goto done;
}
- infoPtr->exprIsComparison = 0;
code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
if (code != TCL_OK) {
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
- maxDepth++;
}
if (tokenPtr != afterSubexprPtr) {
Tcl_ResetResult(interp);
*/
if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
- TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
+ /*
+ * Adjust the current stack depth by the number of arguments
+ * of the builtin function. This cannot be handled by the
+ * TclEmitInstInt1 macro as the number of arguments is not
+ * passed as an operand.
+ */
+
+ if (envPtr->maxStackDepth < envPtr->currStackDepth) {
+ envPtr->maxStackDepth = envPtr->currStackDepth;
+ }
+ TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
mathFuncPtr->builtinFuncIndex, envPtr);
+ envPtr->currStackDepth -= mathFuncPtr->numArgs;
} else {
TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
}
*endPtrPtr = afterSubexprPtr;
done:
- envPtr->maxStackDepth = maxDepth;
return code;
}
\f
sprintf(buffer, "syntax error in expression \"%.*s\"",
((numBytes > 60)? 60 : numBytes), infoPtr->expr);
+ Tcl_ResetResult(infoPtr->interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
buffer, (char *) NULL);
}
* sequence of instructions ("bytecodes").
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* This variable is linked to the Tcl variable "tcl_traceCompile".
*/
+#ifdef TCL_COMPILE_DEBUG
int tclTraceCompile = 0;
static int traceInitialized = 0;
+#endif
/*
* A table describing the Tcl bytecode instructions. Entries in this table
* existence of a procedure call frame to distinguish these.
*/
-InstructionDesc instructionTable[] = {
- /* Name Bytes #Opnds Operand types Stack top, next */
- {"done", 1, 0, {OPERAND_NONE}},
- /* Finish ByteCode execution and return stktop (top stack item) */
- {"push1", 2, 1, {OPERAND_UINT1}},
- /* Push object at ByteCode objArray[op1] */
- {"push4", 5, 1, {OPERAND_UINT4}},
- /* Push object at ByteCode objArray[op4] */
- {"pop", 1, 0, {OPERAND_NONE}},
- /* Pop the topmost stack object */
- {"dup", 1, 0, {OPERAND_NONE}},
- /* Duplicate the topmost stack object and push the result */
- {"concat1", 2, 1, {OPERAND_UINT1}},
- /* Concatenate the top op1 items and push result */
- {"invokeStk1", 2, 1, {OPERAND_UINT1}},
- /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
- {"invokeStk4", 5, 1, {OPERAND_UINT4}},
- /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
- {"evalStk", 1, 0, {OPERAND_NONE}},
- /* Evaluate command in stktop using Tcl_EvalObj. */
- {"exprStk", 1, 0, {OPERAND_NONE}},
- /* Execute expression in stktop using Tcl_ExprStringObj. */
+InstructionDesc tclInstructionTable[] = {
+ /* Name Bytes stackEffect #Opnds Operand types Stack top, next */
+ {"done", 1, -1, 0, {OPERAND_NONE}},
+ /* Finish ByteCode execution and return stktop (top stack item) */
+ {"push1", 2, +1, 1, {OPERAND_UINT1}},
+ /* Push object at ByteCode objArray[op1] */
+ {"push4", 5, +1, 1, {OPERAND_UINT4}},
+ /* Push object at ByteCode objArray[op4] */
+ {"pop", 1, -1, 0, {OPERAND_NONE}},
+ /* Pop the topmost stack object */
+ {"dup", 1, +1, 0, {OPERAND_NONE}},
+ /* Duplicate the topmost stack object and push the result */
+ {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Concatenate the top op1 items and push result */
+ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
+ {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
+ {"evalStk", 1, 0, 0, {OPERAND_NONE}},
+ /* Evaluate command in stktop using Tcl_EvalObj. */
+ {"exprStk", 1, 0, 0, {OPERAND_NONE}},
+ /* Execute expression in stktop using Tcl_ExprStringObj. */
- {"loadScalar1", 2, 1, {OPERAND_UINT1}},
- /* Load scalar variable at index op1 <= 255 in call frame */
- {"loadScalar4", 5, 1, {OPERAND_UINT4}},
- /* Load scalar variable at index op1 >= 256 in call frame */
- {"loadScalarStk", 1, 0, {OPERAND_NONE}},
- /* Load scalar variable; scalar's name is stktop */
- {"loadArray1", 2, 1, {OPERAND_UINT1}},
- /* Load array element; array at slot op1<=255, element is stktop */
- {"loadArray4", 5, 1, {OPERAND_UINT4}},
- /* Load array element; array at slot op1 > 255, element is stktop */
- {"loadArrayStk", 1, 0, {OPERAND_NONE}},
- /* Load array element; element is stktop, array name is stknext */
- {"loadStk", 1, 0, {OPERAND_NONE}},
- /* Load general variable; unparsed variable name is stktop */
- {"storeScalar1", 2, 1, {OPERAND_UINT1}},
- /* Store scalar variable at op1<=255 in frame; value is stktop */
- {"storeScalar4", 5, 1, {OPERAND_UINT4}},
- /* Store scalar variable at op1 > 255 in frame; value is stktop */
- {"storeScalarStk", 1, 0, {OPERAND_NONE}},
- /* Store scalar; value is stktop, scalar name is stknext */
- {"storeArray1", 2, 1, {OPERAND_UINT1}},
- /* Store array element; array at op1<=255, value is top then elem */
- {"storeArray4", 5, 1, {OPERAND_UINT4}},
- /* Store array element; array at op1>=256, value is top then elem */
- {"storeArrayStk", 1, 0, {OPERAND_NONE}},
- /* Store array element; value is stktop, then elem, array names */
- {"storeStk", 1, 0, {OPERAND_NONE}},
- /* Store general variable; value is stktop, then unparsed name */
+ {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}},
+ /* Load scalar variable at index op1 <= 255 in call frame */
+ {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}},
+ /* Load scalar variable at index op1 >= 256 in call frame */
+ {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},
+ /* Load scalar variable; scalar's name is stktop */
+ {"loadArray1", 2, 0, 1, {OPERAND_UINT1}},
+ /* Load array element; array at slot op1<=255, element is stktop */
+ {"loadArray4", 5, 0, 1, {OPERAND_UINT4}},
+ /* Load array element; array at slot op1 > 255, element is stktop */
+ {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Load array element; element is stktop, array name is stknext */
+ {"loadStk", 1, 0, 0, {OPERAND_NONE}},
+ /* Load general variable; unparsed variable name is stktop */
+ {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}},
+ /* Store scalar variable at op1<=255 in frame; value is stktop */
+ {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}},
+ /* Store scalar variable at op1 > 255 in frame; value is stktop */
+ {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Store scalar; value is stktop, scalar name is stknext */
+ {"storeArray1", 2, -1, 1, {OPERAND_UINT1}},
+ /* Store array element; array at op1<=255, value is top then elem */
+ {"storeArray4", 5, -1, 1, {OPERAND_UINT4}},
+ /* Store array element; array at op1>=256, value is top then elem */
+ {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ /* Store array element; value is stktop, then elem, array names */
+ {"storeStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Store general variable; value is stktop, then unparsed name */
- {"incrScalar1", 2, 1, {OPERAND_UINT1}},
- /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
- {"incrScalarStk", 1, 0, {OPERAND_NONE}},
- /* Incr scalar; incr amount is stktop, scalar's name is stknext */
- {"incrArray1", 2, 1, {OPERAND_UINT1}},
- /* Incr array elem; arr at slot op1<=255, amount is top then elem */
- {"incrArrayStk", 1, 0, {OPERAND_NONE}},
- /* Incr array element; amount is top then elem then array names */
- {"incrStk", 1, 0, {OPERAND_NONE}},
- /* Incr general variable; amount is stktop then unparsed var name */
- {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
- /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
- {"incrScalarStkImm", 2, 1, {OPERAND_INT1}},
- /* Incr scalar; scalar name is stktop; incr amount is op1 */
- {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
- /* Incr array elem; array at slot op1 <= 255, elem is stktop,
+ {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}},
+ /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
+ {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Incr scalar; incr amount is stktop, scalar's name is stknext */
+ {"incrArray1", 2, -1, 1, {OPERAND_UINT1}},
+ /* Incr array elem; arr at slot op1<=255, amount is top then elem */
+ {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ /* Incr array element; amount is top then elem then array names */
+ {"incrStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Incr general variable; amount is stktop then unparsed var name */
+ {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
+ {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}},
+ /* Incr scalar; scalar name is stktop; incr amount is op1 */
+ {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ /* Incr array elem; array at slot op1 <= 255, elem is stktop,
* amount is 2nd operand byte */
- {"incrArrayStkImm", 2, 1, {OPERAND_INT1}},
- /* Incr array element; elem is top then array name, amount is op1 */
- {"incrStkImm", 2, 1, {OPERAND_INT1}},
- /* Incr general variable; unparsed name is top, amount is op1 */
+ {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}},
+ /* Incr array element; elem is top then array name, amount is op1 */
+ {"incrStkImm", 2, 0, 1, {OPERAND_INT1}},
+ /* Incr general variable; unparsed name is top, amount is op1 */
- {"jump1", 2, 1, {OPERAND_INT1}},
- /* Jump relative to (pc + op1) */
- {"jump4", 5, 1, {OPERAND_INT4}},
- /* Jump relative to (pc + op4) */
- {"jumpTrue1", 2, 1, {OPERAND_INT1}},
- /* Jump relative to (pc + op1) if stktop expr object is true */
- {"jumpTrue4", 5, 1, {OPERAND_INT4}},
- /* Jump relative to (pc + op4) if stktop expr object is true */
- {"jumpFalse1", 2, 1, {OPERAND_INT1}},
- /* Jump relative to (pc + op1) if stktop expr object is false */
- {"jumpFalse4", 5, 1, {OPERAND_INT4}},
- /* Jump relative to (pc + op4) if stktop expr object is false */
-
- {"lor", 1, 0, {OPERAND_NONE}},
- /* Logical or: push (stknext || stktop) */
- {"land", 1, 0, {OPERAND_NONE}},
- /* Logical and: push (stknext && stktop) */
- {"bitor", 1, 0, {OPERAND_NONE}},
- /* Bitwise or: push (stknext | stktop) */
- {"bitxor", 1, 0, {OPERAND_NONE}},
- /* Bitwise xor push (stknext ^ stktop) */
- {"bitand", 1, 0, {OPERAND_NONE}},
- /* Bitwise and: push (stknext & stktop) */
- {"eq", 1, 0, {OPERAND_NONE}},
- /* Equal: push (stknext == stktop) */
- {"neq", 1, 0, {OPERAND_NONE}},
- /* Not equal: push (stknext != stktop) */
- {"lt", 1, 0, {OPERAND_NONE}},
- /* Less: push (stknext < stktop) */
- {"gt", 1, 0, {OPERAND_NONE}},
- /* Greater: push (stknext || stktop) */
- {"le", 1, 0, {OPERAND_NONE}},
- /* Logical or: push (stknext || stktop) */
- {"ge", 1, 0, {OPERAND_NONE}},
- /* Logical or: push (stknext || stktop) */
- {"lshift", 1, 0, {OPERAND_NONE}},
- /* Left shift: push (stknext << stktop) */
- {"rshift", 1, 0, {OPERAND_NONE}},
- /* Right shift: push (stknext >> stktop) */
- {"add", 1, 0, {OPERAND_NONE}},
- /* Add: push (stknext + stktop) */
- {"sub", 1, 0, {OPERAND_NONE}},
- /* Sub: push (stkext - stktop) */
- {"mult", 1, 0, {OPERAND_NONE}},
- /* Multiply: push (stknext * stktop) */
- {"div", 1, 0, {OPERAND_NONE}},
- /* Divide: push (stknext / stktop) */
- {"mod", 1, 0, {OPERAND_NONE}},
- /* Mod: push (stknext % stktop) */
- {"uplus", 1, 0, {OPERAND_NONE}},
- /* Unary plus: push +stktop */
- {"uminus", 1, 0, {OPERAND_NONE}},
- /* Unary minus: push -stktop */
- {"bitnot", 1, 0, {OPERAND_NONE}},
- /* Bitwise not: push ~stktop */
- {"not", 1, 0, {OPERAND_NONE}},
- /* Logical not: push !stktop */
- {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}},
- /* Call builtin math function with index op1; any args are on stk */
- {"callFunc1", 2, 1, {OPERAND_UINT1}},
- /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
- {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}},
- /* Try converting stktop to first int then double if possible. */
-
- {"break", 1, 0, {OPERAND_NONE}},
- /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
- {"continue", 1, 0, {OPERAND_NONE}},
- /* Skip to next iteration of closest enclosing loop; if none,
+ {"jump1", 2, 0, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) */
+ {"jump4", 5, 0, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) */
+ {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) if stktop expr object is true */
+ {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) if stktop expr object is true */
+ {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) if stktop expr object is false */
+ {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) if stktop expr object is false */
+
+ {"lor", 1, -1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"land", 1, -1, 0, {OPERAND_NONE}},
+ /* Logical and: push (stknext && stktop) */
+ {"bitor", 1, -1, 0, {OPERAND_NONE}},
+ /* Bitwise or: push (stknext | stktop) */
+ {"bitxor", 1, -1, 0, {OPERAND_NONE}},
+ /* Bitwise xor push (stknext ^ stktop) */
+ {"bitand", 1, -1, 0, {OPERAND_NONE}},
+ /* Bitwise and: push (stknext & stktop) */
+ {"eq", 1, -1, 0, {OPERAND_NONE}},
+ /* Equal: push (stknext == stktop) */
+ {"neq", 1, -1, 0, {OPERAND_NONE}},
+ /* Not equal: push (stknext != stktop) */
+ {"lt", 1, -1, 0, {OPERAND_NONE}},
+ /* Less: push (stknext < stktop) */
+ {"gt", 1, -1, 0, {OPERAND_NONE}},
+ /* Greater: push (stknext || stktop) */
+ {"le", 1, -1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"ge", 1, -1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"lshift", 1, -1, 0, {OPERAND_NONE}},
+ /* Left shift: push (stknext << stktop) */
+ {"rshift", 1, -1, 0, {OPERAND_NONE}},
+ /* Right shift: push (stknext >> stktop) */
+ {"add", 1, -1, 0, {OPERAND_NONE}},
+ /* Add: push (stknext + stktop) */
+ {"sub", 1, -1, 0, {OPERAND_NONE}},
+ /* Sub: push (stkext - stktop) */
+ {"mult", 1, -1, 0, {OPERAND_NONE}},
+ /* Multiply: push (stknext * stktop) */
+ {"div", 1, -1, 0, {OPERAND_NONE}},
+ /* Divide: push (stknext / stktop) */
+ {"mod", 1, -1, 0, {OPERAND_NONE}},
+ /* Mod: push (stknext % stktop) */
+ {"uplus", 1, 0, 0, {OPERAND_NONE}},
+ /* Unary plus: push +stktop */
+ {"uminus", 1, 0, 0, {OPERAND_NONE}},
+ /* Unary minus: push -stktop */
+ {"bitnot", 1, 0, 0, {OPERAND_NONE}},
+ /* Bitwise not: push ~stktop */
+ {"not", 1, 0, 0, {OPERAND_NONE}},
+ /* Logical not: push !stktop */
+ {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}},
+ /* Call builtin math function with index op1; any args are on stk */
+ {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
+ {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},
+ /* Try converting stktop to first int then double if possible. */
+
+ {"break", 1, 0, 0, {OPERAND_NONE}},
+ /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
+ {"continue", 1, 0, 0, {OPERAND_NONE}},
+ /* Skip to next iteration of closest enclosing loop; if none,
* return TCL_CONTINUE code. */
- {"foreach_start4", 5, 1, {OPERAND_UINT4}},
- /* Initialize execution of a foreach loop. Operand is aux data index
+ {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}},
+ /* Initialize execution of a foreach loop. Operand is aux data index
* of the ForeachInfo structure for the foreach command. */
- {"foreach_step4", 5, 1, {OPERAND_UINT4}},
- /* "Step" or begin next iteration of foreach loop. Push 0 if to
+ {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}},
+ /* "Step" or begin next iteration of foreach loop. Push 0 if to
* terminate loop, else push 1. */
- {"beginCatch4", 5, 1, {OPERAND_UINT4}},
- /* Record start of catch with the operand's exception index.
+ {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}},
+ /* Record start of catch with the operand's exception index.
* Push the current stack depth onto a special catch stack. */
- {"endCatch", 1, 0, {OPERAND_NONE}},
- /* End of last catch. Pop the bytecode interpreter's catch stack. */
- {"pushResult", 1, 0, {OPERAND_NONE}},
- /* Push the interpreter's object result onto the stack. */
- {"pushReturnCode", 1, 0, {OPERAND_NONE}},
- /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
+ {"endCatch", 1, 0, 0, {OPERAND_NONE}},
+ /* End of last catch. Pop the bytecode interpreter's catch stack. */
+ {"pushResult", 1, +1, 0, {OPERAND_NONE}},
+ /* Push the interpreter's object result onto the stack. */
+ {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}},
+ /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
* a new object onto the stack. */
+ {"streq", 1, -1, 0, {OPERAND_NONE}},
+ /* Str Equal: push (stknext eq stktop) */
+ {"strneq", 1, -1, 0, {OPERAND_NONE}},
+ /* Str !Equal: push (stknext neq stktop) */
+ {"strcmp", 1, -1, 0, {OPERAND_NONE}},
+ /* Str Compare: push (stknext cmp stktop) */
+ {"strlen", 1, 0, 0, {OPERAND_NONE}},
+ /* Str Length: push (strlen stktop) */
+ {"strindex", 1, -1, 0, {OPERAND_NONE}},
+ /* Str Index: push (strindex stknext stktop) */
+ {"strmatch", 2, -1, 1, {OPERAND_INT1}},
+ /* Str Match: push (strmatch stknext stktop) opnd == nocase */
+ {"list", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* List: push (stk1 stk2 ... stktop) */
+ {"listindex", 1, -1, 0, {OPERAND_NONE}},
+ /* List Index: push (listindex stknext stktop) */
+ {"listlength", 1, 0, 0, {OPERAND_NONE}},
+ /* List Len: push (listlength stktop) */
+ {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}},
+ /* Append scalar variable at op1<=255 in frame; value is stktop */
+ {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}},
+ /* Append scalar variable at op1 > 255 in frame; value is stktop */
+ {"appendArray1", 2, -1, 1, {OPERAND_UINT1}},
+ /* Append array element; array at op1<=255, value is top then elem */
+ {"appendArray4", 5, -1, 1, {OPERAND_UINT4}},
+ /* Append array element; array at op1>=256, value is top then elem */
+ {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ /* Append array element; value is stktop, then elem, array names */
+ {"appendStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Append general variable; value is stktop, then unparsed name */
+ {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}},
+ /* Lappend scalar variable at op1<=255 in frame; value is stktop */
+ {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}},
+ /* Lappend scalar variable at op1 > 255 in frame; value is stktop */
+ {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}},
+ /* Lappend array element; array at op1<=255, value is top then elem */
+ {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}},
+ /* Lappend array element; array at op1>=256, value is top then elem */
+ {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ /* Lappend array element; value is stktop, then elem, array names */
+ {"lappendStk", 1, -1, 0, {OPERAND_NONE}},
+ /* Lappend general variable; value is stktop, then unparsed name */
+ {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* Lindex with generalized args, operand is number of stacked objs
+ * used: (operand-1) entries from stktop are the indices; then list
+ * to process. */
+ {"over", 5, +1, 1, {OPERAND_UINT4}},
+ /* Duplicate the arg-th element from top of stack (TOS=0) */
+ {"lsetList", 1, -2, 0, {OPERAND_NONE}},
+ /* Four-arg version of 'lset'. stktop is old value; next is
+ * new element value, next is the index list; pushes new value */
+ {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* Three- or >=5-arg version of 'lset', operand is number of
+ * stacked objs: stktop is old value, next is new element value, next
+ * come (operand-2) indices; pushes the new value.
+ */
{0}
};
static int GetCmdLocEncodingSize _ANSI_ARGS_((
CompileEnv *envPtr));
static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
- char *script, char *command, int length));
+ CONST char *script, CONST char *command,
+ int length));
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats _ANSI_ARGS_((
ByteCode *codePtr));
int length, nested, result;
char *string;
+#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
if (Tcl_LinkVar(interp, "tcl_traceCompile",
(char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
}
traceInitialized = 1;
}
+#endif
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
TclInitByteCodeObj(objPtr, &compEnv);
#ifdef TCL_COMPILE_DEBUG
- if (tclTraceCompile == 2) {
+ if (tclTraceCompile >= 2) {
TclPrintByteCodeObj(interp, objPtr);
}
#endif /* TCL_COMPILE_DEBUG */
(double) (codePtr->numAuxDataItems * sizeof(AuxData));
statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
- TclpGetTime(&destroyTime);
+ Tcl_GetTime(&destroyTime);
lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
if (lifetimeSec > 2000) { /* avoid overflow */
lifetimeSec = 2000;
envPtr->exceptDepth = 0;
envPtr->maxExceptDepth = 0;
envPtr->maxStackDepth = 0;
+ envPtr->currStackDepth = 0;
TclInitLiteralTable(&(envPtr->localLitTable));
- envPtr->exprIsJustVarRef = 0;
- envPtr->exprIsComparison = 0;
envPtr->codeStart = envPtr->staticCodeSpace;
envPtr->codeNext = envPtr->codeStart;
* interp->termOffset is set to the offset of the character in the
* script just after the last one successfully processed; this will be
* the offset of the ']' if (flags & TCL_BRACKET_TERM).
- * envPtr->maxStackDepth is set to the maximum number of stack elements
- * needed to execute the script's commands.
*
* Side effects:
* Adds instructions to envPtr to evaluate the script at runtime.
int
TclCompileScript(interp, script, numBytes, nested, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting. */
- char *script; /* The source script to compile. */
+ CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Parse parse;
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute all cmds. */
int lastTopLevelCmdIndex = -1;
/* Index of most recent toplevel command in
* the command location table. Initialized
int startCodeOffset = -1; /* Offset of first byte of current command's
* code. Init. to avoid compiler warning. */
unsigned char *entryCodeNext = envPtr->codeNext;
- char *p, *next;
+ CONST char *p, *next;
Namespace *cmdNsPtr;
Command *cmdPtr;
Tcl_Token *tokenPtr;
commandLength -= 1;
}
+#ifdef TCL_COMPILE_DEBUG
/*
* If tracing, print a line for each top level command compiled.
*/
TclMin(commandLength, 55));
fprintf(stdout, "\n");
}
-
+#endif
/*
* Each iteration of the following loop compiles one word
* from the command.
if ((cmdPtr != NULL)
&& (cmdPtr->compileProc != NULL)
+ && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
code = (*(cmdPtr->compileProc))(interp, &parse,
envPtr);
if (code == TCL_OK) {
- maxDepth = TclMax(envPtr->maxStackDepth,
- maxDepth);
goto finishCommand;
} else if (code == TCL_OUT_LINE_COMPILE) {
/* do nothing */
* reduce runtime lookups.
*/
- objIndex = TclRegisterLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size,
- /*onHeap*/ 0);
+ objIndex = TclRegisterNewLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size);
if (cmdPtr != NULL) {
TclSetCmdNameObj(interp,
envPtr->literalArrayPtr[objIndex].objPtr,
cmdPtr);
}
} else {
- objIndex = TclRegisterLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size,
- /*onHeap*/ 0);
+ objIndex = TclRegisterNewLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size);
}
TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax((wordIdx + 1), maxDepth);
} else {
/*
* The word is not a simple string of characters.
if (code != TCL_OK) {
goto error;
}
- maxDepth = TclMax((wordIdx + envPtr->maxStackDepth),
- maxDepth);
}
}
if (envPtr->codeNext == entryCodeNext) {
TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
envPtr);
- maxDepth = 1;
}
if ((nested != 0) && (p > script) && (p[-1] == ']')) {
} else {
iPtr->termOffset = (p - script);
}
- envPtr->maxStackDepth = maxDepth;
Tcl_DStringFree(&ds);
return TCL_OK;
Tcl_FreeParse(&parse);
}
iPtr->termOffset = (p - script);
- envPtr->maxStackDepth = maxDepth;
Tcl_DStringFree(&ds);
return code;
}
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the tokens.
- *
* Side effects:
* Instructions are added to envPtr to push and evaluate the tokens
* at runtime.
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[TCL_UTF_MAX];
- char *name, *p;
- int numObjsToConcat, nameBytes, hasNsQualifiers, localVar;
- int length, maxDepth, depthForVar, i, code;
+ CONST char *name, *p;
+ int numObjsToConcat, nameBytes, localVarName, localVar;
+ int length, i, code;
unsigned char *entryCodeNext = envPtr->codeNext;
Tcl_DStringInit(&textBuffer);
- maxDepth = 0;
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
- maxDepth = TclMax(numObjsToConcat, maxDepth);
Tcl_DStringFree(&textBuffer);
}
if (code != TCL_OK) {
goto error;
}
- maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth),
- maxDepth);
numObjsToConcat++;
break;
Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
- maxDepth = TclMax(numObjsToConcat, maxDepth);
Tcl_DStringFree(&textBuffer);
}
/*
- * Check if the name contains any namespace qualifiers.
+ * Determine how the variable name should be handled: if it contains
+ * any namespace qualifiers it is not a local variable (localVarName=-1);
+ * if it looks like an array element and the token has a single component,
+ * it should not be created here [Bug 569438] (localVarName=0); otherwise,
+ * the local variable can safely be created (localVarName=1).
*/
name = tokenPtr[1].start;
nameBytes = tokenPtr[1].size;
- hasNsQualifiers = 0;
- for (i = 0, p = name; i < nameBytes; i++, p++) {
- if ((*p == ':') && (i < (nameBytes-1))
- && (*(p+1) == ':')) {
- hasNsQualifiers = 1;
- break;
+ localVarName = -1;
+ if (envPtr->procPtr != NULL) {
+ localVarName = 1;
+ for (i = 0, p = name; i < nameBytes; i++, p++) {
+ if ((*p == ':') && (i < (nameBytes-1))
+ && (*(p+1) == ':')) {
+ localVarName = -1;
+ break;
+ } else if ((*p == '(')
+ && (tokenPtr->numComponents == 1)
+ && (*(name + nameBytes - 1) == ')')) {
+ localVarName = 0;
+ break;
+ }
}
}
/*
* Either push the variable's name, or find its index in
- * the array of local variables in a procedure frame.
+ * the array of local variables in a procedure frame.
*/
- depthForVar = 0;
- if ((envPtr->procPtr == NULL) || hasNsQualifiers) {
- localVar = -1;
- TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes,
- /*onHeap*/ 0), envPtr);
- depthForVar = 1;
- } else {
+ localVar = -1;
+ if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes,
- /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
- if (localVar < 0) {
- TclEmitPush(TclRegisterLiteral(envPtr, name,
- nameBytes, /*onHeap*/ 0), envPtr);
- depthForVar = 1;
- }
+ localVarName, /*flags*/ 0, envPtr->procPtr);
+ }
+ if (localVar < 0) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
+ envPtr);
}
/*
code = TclCompileTokens(interp, tokenPtr+2,
tokenPtr->numComponents-1, envPtr);
if (code != TCL_OK) {
- sprintf(buffer,
+ char errorBuffer[150];
+ sprintf(errorBuffer,
"\n (parsing index for array \"%.*s\")",
((nameBytes > 100)? 100 : nameBytes), name);
- Tcl_AddObjErrorInfo(interp, buffer, -1);
+ Tcl_AddObjErrorInfo(interp, errorBuffer, -1);
goto error;
}
- depthForVar += envPtr->maxStackDepth;
if (localVar < 0) {
TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
} else if (localVar <= 255) {
envPtr);
}
}
- maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth);
numObjsToConcat++;
count -= tokenPtr->numComponents;
tokenPtr += tokenPtr->numComponents;
Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
- maxDepth = TclMax(numObjsToConcat, maxDepth);
}
/*
if (envPtr->codeNext == entryCodeNext) {
TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
envPtr);
- maxDepth = 1;
}
Tcl_DStringFree(&textBuffer);
- envPtr->maxStackDepth = maxDepth;
return TCL_OK;
error:
Tcl_DStringFree(&textBuffer);
- envPtr->maxStackDepth = maxDepth;
return code;
}
\f
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the tokens.
- *
* Side effects:
* Instructions are added to envPtr to execute the tokens at runtime.
*
* into an inline sequence of instructions.
*/
- envPtr->maxStackDepth = 0;
if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
/*nested*/ 0, envPtr);
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
* Side effects:
* Instructions are added to envPtr to execute the expression.
*
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
Tcl_Token *wordPtr;
- int maxDepth, range, numBytes, i, code;
- char *script;
- int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
- int saveExprIsComparison = envPtr->exprIsComparison;
+ int range, numBytes, i, code;
+ CONST char *script;
- envPtr->maxStackDepth = 0;
- maxDepth = 0;
range = -1;
code = TCL_OK;
if (i < (numWords - 1)) {
TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
envPtr);
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
- } else {
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
}
wordPtr += (wordPtr->numComponents + 1);
}
TclEmitOpcode(INST_EXPR_STK, envPtr);
}
- envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
- envPtr->exprIsComparison = saveExprIsComparison;
- envPtr->maxStackDepth = maxDepth;
return code;
}
\f
codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExceptDepth = envPtr->maxExceptDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
-
+
p += sizeof(ByteCode);
codePtr->codeStart = p;
memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
#ifdef TCL_COMPILE_STATS
codePtr->structureSize = structureSize
- (sizeof(size_t) + sizeof(Tcl_Time));
- TclpGetTime(&(codePtr->createTime));
+ Tcl_GetTime(&(codePtr->createTime));
RecordByteCodeStats(codePtr);
#endif /* TCL_COMPILE_STATS */
LogCompilationInfo(interp, script, command, length)
Tcl_Interp *interp; /* Interpreter in which to log the
* information. */
- char *script; /* First character in script containing
+ CONST char *script; /* First character in script containing
* command (must be <= command). */
- char *command; /* First character in command that
+ CONST char *command; /* First character in command that
* generated the error. */
int length; /* Number of bytes in command (-1 means
* use all bytes up to first null byte). */
{
char buffer[200];
- register char *p;
+ register CONST char *p;
char *ellipsis = "";
Interp *iPtr = (Interp *) interp;
int
TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
- register char *name; /* Points to first character of the name of
+ register CONST char *name; /* Points to first character of the name of
* a scalar or array variable. If NULL, a
* temporary var should be created. */
int nameBytes; /* Number of bytes in the name. */
localPtr->nextPtr = NULL;
localPtr->nameLength = nameBytes;
localPtr->frameIndex = localVar;
- localPtr->flags = flags;
+ localPtr->flags = flags | VAR_UNDEFINED;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
- varPtr->flags = (localPtr->flags | VAR_UNDEFINED);
+ varPtr->flags = localPtr->flags;
}
varPtr++;
}
*/
void
-TclExpandCodeArray(envPtr)
- CompileEnv *envPtr; /* Points to the CompileEnv whose code array
+TclExpandCodeArray(envArgPtr)
+ void *envArgPtr; /* Points to the CompileEnv whose code array
* must be enlarged. */
{
+ CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array
+ * must be enlarged. */
+
/*
* envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
* code bytes are stored between envPtr->codeStart and
*
* Results:
* Returns a pointer to the global instruction table, same as the
- * expression (&instructionTable[0]).
+ * expression (&tclInstructionTable[0]).
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-InstructionDesc *
+void * /* == InstructionDesc* == */
TclGetInstructionTable()
{
- return &instructionTable[0];
+ return &tclInstructionTable[0];
}
\f
/*
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
- register InstructionDesc *instDesc = &instructionTable[opCode];
+ register InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned int pcOffset = (pc - codeStart);
int opnd, i, j;
void
TclPrintSource(outFile, string, maxChars)
FILE *outFile; /* The file to print the source to. */
- char *string; /* The string to print. */
+ CONST char *string; /* The string to print. */
int maxChars; /* Maximum number of chars to print. */
{
- register char *p;
+ register CONST char *p;
register int i = 0;
if (string == NULL) {
statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
- statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++;
+ statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;
statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
statsPtr->currentLitBytes +=
statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
}
#endif /* TCL_COMPILE_STATS */
-
* tclCompile.h --
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*------------------------------------------------------------------------
*/
-/*
- * Variable that denotes the command name Tcl object type. Objects of this
- * type cache the Command pointer that results from looking up command names
- * in the command hashtable.
- */
-
-extern Tcl_ObjType tclCmdNameType;
-
+#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
*/
extern int tclTraceCompile;
+#endif
+#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether execution tracing is enabled and, if so,
* what level of tracing is desired:
*/
extern int tclTraceExec;
+#endif
/*
*------------------------------------------------------------------------
int maxStackDepth; /* Maximum number of stack elements needed
* to execute the code. Set by compilation
* procedures before returning. */
+ int currStackDepth; /* Current stack depth. */
LiteralTable localLitTable; /* Contains LiteralEntry's describing
* all Tcl objects referenced by this
* compiled code. Indexed by the string
* representations of the literals. Used to
* avoid creating duplicate objects. */
- int exprIsJustVarRef; /* Set 1 if the expression last compiled by
- * TclCompileExpr consisted of just a
- * variable reference as in the expression
- * of "if $b then...". Otherwise 0. Used
- * to implement expr's 2 level substitution
- * semantics properly. */
- int exprIsComparison; /* Set 1 if the top-level operator in the
- * expression last compiled is a comparison.
- * Otherwise 0. If 1, since the operands
- * might be strings, the expr is compiled
- * out-of-line to implement expr's 2 level
- * substitution semantics properly. */
unsigned char *codeStart; /* Points to the first byte of the code. */
unsigned char *codeNext; /* Points to next code array byte to use. */
unsigned char *codeEnd; /* Points just after the last allocated
} ByteCode;
/*
- * Opcodes for the Tcl bytecode instructions. These must correspond to the
- * entries in the table of instruction descriptions, instructionTable, in
- * tclCompile.c. Also, the order and number of the expression opcodes
- * (e.g., INST_LOR) must match the entries in the array operatorStrings in
- * tclExecute.c.
+ * Opcodes for the Tcl bytecode instructions. These must correspond to
+ * the entries in the table of instruction descriptions,
+ * tclInstructionTable, in tclCompile.c. Also, the order and number of
+ * the expression opcodes (e.g., INST_LOR) must match the entries in
+ * the array operatorStrings in tclExecute.c.
*/
/* Opcodes 0 to 9 */
#define INST_PUSH_RESULT 71
#define INST_PUSH_RETURN_CODE 72
+/* Opcodes 73 to 78 */
+#define INST_STR_EQ 73
+#define INST_STR_NEQ 74
+#define INST_STR_CMP 75
+#define INST_STR_LEN 76
+#define INST_STR_INDEX 77
+#define INST_STR_MATCH 78
+
+/* Opcodes 78 to 81 */
+#define INST_LIST 79
+#define INST_LIST_INDEX 80
+#define INST_LIST_LENGTH 81
+
+/* Opcodes 82 to 87 */
+#define INST_APPEND_SCALAR1 82
+#define INST_APPEND_SCALAR4 83
+#define INST_APPEND_ARRAY1 84
+#define INST_APPEND_ARRAY4 85
+#define INST_APPEND_ARRAY_STK 86
+#define INST_APPEND_STK 87
+
+/* Opcodes 88 to 93 */
+#define INST_LAPPEND_SCALAR1 88
+#define INST_LAPPEND_SCALAR4 89
+#define INST_LAPPEND_ARRAY1 90
+#define INST_LAPPEND_ARRAY4 91
+#define INST_LAPPEND_ARRAY_STK 92
+#define INST_LAPPEND_STK 93
+
+/* TIP #22 - LINDEX operator with flat arg list */
+
+#define INST_LIST_INDEX_MULTI 94
+
+/*
+ * TIP #33 - 'lset' command. Code gen also required a Forth-like
+ * OVER operation.
+ */
+
+#define INST_OVER 95
+#define INST_LSET_LIST 96
+#define INST_LSET_FLAT 97
+
/* The last opcode */
-#define LAST_INST_OPCODE 72
+#define LAST_INST_OPCODE 97
/*
* Table describing the Tcl bytecode instructions: their name (for
typedef struct InstructionDesc {
char *name; /* Name of instruction. */
int numBytes; /* Total number of bytes for instruction. */
+ int stackEffect; /* The worst-case balance stack effect of the
+ * instruction, used for stack requirements
+ * computations. The value INT_MIN signals
+ * that the instruction's worst case effect
+ * is (1-opnd1).
+ */
int numOperands; /* Number of operands. */
InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
/* The type of each operand. */
} InstructionDesc;
-extern InstructionDesc instructionTable[];
+extern InstructionDesc tclInstructionTable[];
/*
* Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte. Each value denotes a builtin Tcl math function. These
- * values must correspond to the entries in the builtinFuncTable array
+ * values must correspond to the entries in the tclBuiltinFuncTable array
* below and to the values stored in the tclInt.h MathFunc structure's
* builtinFuncIndex field.
*/
#define BUILTIN_FUNC_RAND 22
#define BUILTIN_FUNC_ROUND 23
#define BUILTIN_FUNC_SRAND 24
+#define BUILTIN_FUNC_WIDE 25
-#define LAST_BUILTIN_FUNC 24
+#define LAST_BUILTIN_FUNC 25
/*
* Table describing the built-in math functions. Entries in this table are
* function when invoking it. */
} BuiltinFunc;
-extern BuiltinFunc builtinFuncTable[];
+extern BuiltinFunc tclBuiltinFuncTable[];
/*
* Compilation of some Tcl constructs such as if commands and the logical or
extern AuxDataType tclForeachInfoType;
+
/*
- * Structure containing a cached pointer to a command that is the result
- * of resolving the command's name in some namespace. It is the internal
- * representation for a cmdName object. It contains the pointer along
- * with some information that is used to check the pointer's validity.
- */
-
-typedef struct ResolvedCmdName {
- Command *cmdPtr; /* A cached Command pointer. */
- Namespace *refNsPtr; /* Points to the namespace containing the
- * reference (not the namespace that
- * contains the referenced command). */
- long refNsId; /* refNsPtr's unique namespace id. Used to
- * verify that refNsPtr is still valid
- * (e.g., it's possible that the cmd's
- * containing namespace was deleted and a
- * new one created at the same address). */
- int refNsCmdEpoch; /* Value of the referencing namespace's
- * cmdRefEpoch when the pointer was cached.
- * Before using the cached pointer, we check
- * if the namespace's epoch was incremented;
- * if so, this cached pointer is invalid. */
- int cmdEpoch; /* Value of the command's cmdEpoch when this
- * pointer was cached. Before using the
- * cached pointer, we check if the cmd's
- * epoch was incremented; if so, the cmd was
- * renamed, deleted, hidden, or exposed, and
- * so the pointer is invalid. */
- int refCount; /* Reference count: 1 for each cmdName
- * object that has a pointer to this
- * ResolvedCmdName structure as its internal
- * rep. This structure can be freed when
- * refCount becomes zero. */
-} ResolvedCmdName;
+ *----------------------------------------------------------------
+ * Procedures exported by tclBasic.c to be used within the engine.
+ *----------------------------------------------------------------
+ */
+
+EXTERN int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[], CONST char *command, int length,
+ int flags));
+EXTERN int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));
+
+
+/*
+ *----------------------------------------------------------------
+ * Procedures exported by the engine to be used by tclBasic.c
+ *----------------------------------------------------------------
+ */
+
+EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
/*
*----------------------------------------------------------------
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr));
EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp,
- char *script, int numBytes,
+ CONST char *script, int numBytes,
CompileEnv *envPtr));
EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr));
EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp,
- char *script, int numBytes, int nested,
+ CONST char *script, int numBytes, int nested,
CompileEnv *envPtr));
EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_((
unsigned char *pc, int catchOnly,
ByteCode* codePtr));
-EXTERN InstructionDesc * TclGetInstructionTable _ANSI_ARGS_(());
-EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
- ByteCode *codePtr));
-EXTERN void TclExpandCodeArray _ANSI_ARGS_((
- CompileEnv *envPtr));
EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void));
-EXTERN int TclFindCompiledLocal _ANSI_ARGS_((char *name,
+EXTERN int TclFindCompiledLocal _ANSI_ARGS_((CONST char *name,
int nameChars, int create, int flags,
Proc *procPtr));
EXTERN LiteralEntry * TclLookupLiteralEntry _ANSI_ARGS_((
EXTERN void TclPrintObject _ANSI_ARGS_((FILE *outFile,
Tcl_Obj *objPtr, int maxChars));
EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
- char *string, int maxChars));
+ CONST char *string, int maxChars));
EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
EXTERN int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr,
char *bytes, int length, int onHeap));
EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_((
CompileEnv *envPtr));
#endif
+EXTERN int TclCompileVariableCmd _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Parse *parsePtr, CompileEnv *envPtr));
/*
*----------------------------------------------------------------
*/
/*
+ * Form of TclRegisterLiteral with onHeap == 0.
+ * In that case, it is safe to cast away CONSTness, and it
+ * is cleanest to do that here, all in one place.
+ */
+
+#define TclRegisterNewLiteral(envPtr, bytes, length) \
+ TclRegisterLiteral(envPtr, (char *)(bytes), length, /*onHeap*/ 0)
+
+/*
+ * Macro used to update the stack requirements.
+ * It is called by the macros TclEmitOpCode, TclEmitInst1 and
+ * TclEmitInst4.
+ * Remark that the very last instruction of a bytecode always
+ * reduces the stack level: INST_DONE or INST_POP, so that the
+ * maxStackdepth is always updated.
+ */
+
+#define TclUpdateStackReqs(op, i, envPtr) \
+ {\
+ int delta = tclInstructionTable[(op)].stackEffect;\
+ if (delta) {\
+ if (delta < 0) {\
+ if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
+ (envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
+ }\
+ if (delta == INT_MIN) {\
+ delta = 1 - (i);\
+ }\
+ }\
+ (envPtr)->currStackDepth += delta;\
+ }\
+ }
+
+/*
* Macro to emit an opcode byte into a CompileEnv's code array.
* The ANSI C "prototype" for this macro is:
*
#define TclEmitOpcode(op, envPtr) \
if ((envPtr)->codeNext == (envPtr)->codeEnd) \
TclExpandCodeArray(envPtr); \
- *(envPtr)->codeNext++ = (unsigned char) (op)
+ *(envPtr)->codeNext++ = (unsigned char) (op);\
+ TclUpdateStackReqs(op, 0, envPtr)
/*
* Macro to emit an integer operand.
* CompileEnv *envPtr));
*/
+
#define TclEmitInstInt1(op, i, envPtr) \
if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \
TclExpandCodeArray(envPtr); \
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
- *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))
+ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i));\
+ TclUpdateStackReqs(op, i, envPtr)
#define TclEmitInstInt4(op, i, envPtr) \
if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 8); \
*(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) )
+ (unsigned char) ((unsigned int) (i) );\
+ TclUpdateStackReqs(op, i, envPtr)
/*
* Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
*/
#define TclEmitPush(objIndex, envPtr) \
- if ((objIndex) <= 255) { \
- TclEmitInstInt1(INST_PUSH1, (objIndex), (envPtr)); \
- } else { \
- TclEmitInstInt4(INST_PUSH4, (objIndex), (envPtr)); \
+ {\
+ register int objIndexCopy = (objIndex);\
+ if (objIndexCopy <= 255) { \
+ TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \
+ } else { \
+ TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \
+ }\
}
/*
# define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLCOMPILATION */
+
+
+
+
+
#include "tclInt.h"
#include "tclPort.h"
-#ifdef MAC_TCL
+#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH)
# define EPOCH 1904
# define START_OF_TIME 1904
# define END_OF_TIME 2039
result = Convert(Month, (time_t) tm->tm_mday, Year,
(time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec,
MER24, DSTmaybe, &Julian);
+
+ /*
+ * The Julian time returned above is behind by one day, if "month"
+ * or "year" is used to specify relative time and the GMT flag is true.
+ * This problem occurs only when the current time is closer to
+ * midnight, the difference being not more than its time difference
+ * with GMT. For example, in US/Pacific time zone, the problem occurs
+ * whenever the current time is between midnight to 8:00am or 7:00amDST.
+ * See Bug# 413397 for more details and sample script.
+ * To resolve this bug, we simply add the number of seconds corresponding
+ * to timezone difference with GMT to Julian time, if GMT flag is true.
+ */
+
+ if (TclDateTimezone == 0) {
+ Julian += TclpGetTimeZone((unsigned long) Start) * 60L;
+ }
+
/*
* The following iteration takes into account the case were we jump
* into a "short month". Far example, "one month from Jan 31" will
goto TclDatestack; /* reset registers in driver code */
}
-
*/
/* 0 */
-EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, char * version,
+EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp* interp,
+ CONST char* name, CONST char* version,
ClientData clientData));
/* 1 */
-EXTERN char * Tcl_PkgRequireEx _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, char * version, int exact,
+EXTERN CONST84_RETURN char * Tcl_PkgRequireEx _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ CONST char * version, int exact,
ClientData * clientDataPtr));
/* 2 */
-EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(char *,format));
+EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format));
/* 3 */
EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size));
/* 4 */
unsigned int size));
/* 6 */
EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size,
- char * file, int line));
+ CONST char * file, int line));
/* 7 */
-EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char * ptr, char * file,
- int line));
+EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char * ptr,
+ CONST char * file, int line));
/* 8 */
EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char * ptr,
- unsigned int size, char * file, int line));
+ unsigned int size, CONST char * file,
+ int line));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 9 */
EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask,
/* 15 */
EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr));
/* 16 */
-EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj * objPtr,
- char * bytes, int length));
+EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj* objPtr,
+ CONST char* bytes, int length));
/* 17 */
EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc,
Tcl_Obj *CONST objv[]));
Tcl_Obj * objPtr, Tcl_ObjType * typePtr));
/* 19 */
EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj * objPtr,
- char * file, int line));
+ CONST char * file, int line));
/* 20 */
EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj * objPtr,
- char * file, int line));
+ CONST char * file, int line));
/* 21 */
EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj * objPtr,
- char * file, int line));
+ CONST char * file, int line));
/* 22 */
EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue,
- char * file, int line));
+ CONST char * file, int line));
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj _ANSI_ARGS_((
- unsigned char * bytes, int length,
- char * file, int line));
+ CONST unsigned char * bytes, int length,
+ CONST char * file, int line));
/* 24 */
EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue,
- char * file, int line));
+ CONST char * file, int line));
/* 25 */
EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc,
- Tcl_Obj *CONST objv[], char * file, int line));
+ Tcl_Obj *CONST * objv, CONST char * file,
+ int line));
/* 26 */
EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue,
- char * file, int line));
+ CONST char * file, int line));
/* 27 */
-EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char * file, int line));
+EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((CONST char * file,
+ int line));
/* 28 */
EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((CONST char * bytes,
- int length, char * file, int line));
+ int length, CONST char * file, int line));
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr));
/* 30 */
EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr));
/* 31 */
EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, int * boolPtr));
+ CONST char * str, int * boolPtr));
/* 32 */
EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * objPtr,
Tcl_Obj * objPtr, int * lengthPtr));
/* 34 */
EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, double * doublePtr));
+ CONST char * str, double * doublePtr));
/* 35 */
EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * objPtr,
double * doublePtr));
/* 36 */
EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Obj * objPtr, char ** tablePtr,
- char * msg, int flags, int * indexPtr));
+ Tcl_Obj * objPtr, CONST84 char ** tablePtr,
+ CONST char * msg, int flags, int * indexPtr));
/* 37 */
EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, int * intPtr));
+ CONST char * str, int * intPtr));
/* 38 */
EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int * intPtr));
EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, long * longPtr));
/* 40 */
-EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((char * typeName));
+EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((CONST char * typeName));
/* 41 */
EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj * objPtr,
int * lengthPtr));
Tcl_Obj ** objPtrPtr));
/* 47 */
EXTERN int Tcl_ListObjLength _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Obj * listPtr, int * intPtr));
+ Tcl_Obj * listPtr, int * lengthPtr));
/* 48 */
EXTERN int Tcl_ListObjReplace _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * listPtr, int first, int count,
EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue));
/* 50 */
EXTERN Tcl_Obj * Tcl_NewByteArrayObj _ANSI_ARGS_((
- unsigned char * bytes, int length));
+ CONST unsigned char* bytes, int length));
/* 51 */
EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue));
/* 52 */
int length));
/* 59 */
EXTERN void Tcl_SetByteArrayObj _ANSI_ARGS_((Tcl_Obj * objPtr,
- unsigned char * bytes, int length));
+ CONST unsigned char * bytes, int length));
/* 60 */
EXTERN void Tcl_SetDoubleObj _ANSI_ARGS_((Tcl_Obj * objPtr,
double doubleValue));
EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj * objPtr,
int length));
/* 65 */
-EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj * objPtr,
- char * bytes, int length));
+EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj* objPtr,
+ CONST char* bytes, int length));
/* 66 */
EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp * interp,
CONST char * message));
int * readPtr));
/* 78 */
EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((
- Tcl_Interp * interp, char * optionName,
- char * optionList));
+ Tcl_Interp * interp, CONST char * optionName,
+ CONST char * optionList));
/* 79 */
EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_InterpDeleteProc * proc,
EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Channel chan));
/* 82 */
-EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char * cmd));
+EXTERN int Tcl_CommandComplete _ANSI_ARGS_((CONST char * cmd));
/* 83 */
-EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char ** argv));
+EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc,
+ CONST84 char * CONST * argv));
/* 84 */
EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char * src,
char * dst, int flags));
int flags));
/* 86 */
EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp * slave,
- char * slaveCmd, Tcl_Interp * target,
- char * targetCmd, int argc, char ** argv));
+ CONST char * slaveCmd, Tcl_Interp * target,
+ CONST char * targetCmd, int argc,
+ CONST84 char * CONST * argv));
/* 87 */
EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp * slave,
- char * slaveCmd, Tcl_Interp * target,
- char * targetCmd, int objc,
+ CONST char * slaveCmd, Tcl_Interp * target,
+ CONST char * targetCmd, int objc,
Tcl_Obj *CONST objv[]));
/* 88 */
EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_((
- Tcl_ChannelType * typePtr, char * chanName,
+ Tcl_ChannelType * typePtr,
+ CONST char * chanName,
ClientData instanceData, int mask));
/* 89 */
EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_((
Tcl_CloseProc * proc, ClientData clientData));
/* 91 */
EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp * interp,
- char * cmdName, Tcl_CmdProc * proc,
+ CONST char * cmdName, Tcl_CmdProc * proc,
ClientData clientData,
Tcl_CmdDeleteProc * deleteProc));
/* 92 */
EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void));
/* 95 */
EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, int numArgs,
+ CONST char * name, int numArgs,
Tcl_ValueType * argTypes,
Tcl_MathProc * proc, ClientData clientData));
/* 96 */
EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_((
- Tcl_Interp * interp, char * cmdName,
+ Tcl_Interp * interp, CONST char * cmdName,
Tcl_ObjCmdProc * proc, ClientData clientData,
Tcl_CmdDeleteProc * deleteProc));
/* 97 */
EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp * interp,
- char * slaveName, int isSafe));
+ CONST char * slaveName, int isSafe));
/* 98 */
EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds,
Tcl_TimerProc * proc, ClientData clientData));
ClientData clientData));
/* 100 */
EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp * interp,
- char * name));
+ CONST char * name));
/* 101 */
EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_((
Tcl_Channel chan, Tcl_ChannelProc * proc,
Tcl_CloseProc * proc, ClientData clientData));
/* 103 */
EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp * interp,
- char * cmdName));
+ CONST char * cmdName));
/* 104 */
EXTERN int Tcl_DeleteCommandFromToken _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Command command));
/* 126 */
EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan));
/* 127 */
-EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void));
+EXTERN CONST84_RETURN char * Tcl_ErrnoId _ANSI_ARGS_((void));
/* 128 */
-EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
+EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
/* 129 */
EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp,
- char * string));
+ CONST char * string));
/* 130 */
EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp,
- char * fileName));
+ CONST char * fileName));
/* 131 */
EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr));
EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
/* 134 */
EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp * interp,
- char * hiddenCmdToken, char * cmdName));
+ CONST char * hiddenCmdToken,
+ CONST char * cmdName));
/* 135 */
EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, int * ptr));
+ CONST char * str, int * ptr));
/* 136 */
EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int * ptr));
/* 137 */
EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, double * ptr));
+ CONST char * str, double * ptr));
/* 138 */
EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, double * ptr));
/* 139 */
EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, long * ptr));
+ CONST char * str, long * ptr));
/* 140 */
EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, long * ptr));
Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr));
/* 142 */
EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp,
- char * string));
+ CONST char * string));
/* 143 */
EXTERN void Tcl_Finalize _ANSI_ARGS_((void));
/* 144 */
EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp * interp));
/* 148 */
EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp * interp,
- char * slaveCmd,
+ CONST char * slaveCmd,
Tcl_Interp ** targetInterpPtr,
- char ** targetCmdPtr, int * argcPtr,
- char *** argvPtr));
+ CONST84 char ** targetCmdPtr, int * argcPtr,
+ CONST84 char *** argvPtr));
/* 149 */
EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp * interp,
- char * slaveCmd,
+ CONST char * slaveCmd,
Tcl_Interp ** targetInterpPtr,
- char ** targetCmdPtr, int * objcPtr,
+ CONST84 char ** targetCmdPtr, int * objcPtr,
Tcl_Obj *** objv));
/* 150 */
EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, Tcl_InterpDeleteProc ** procPtr));
+ CONST char * name,
+ Tcl_InterpDeleteProc ** procPtr));
/* 151 */
EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp * interp,
- char * chanName, int * modePtr));
+ CONST char * chanName, int * modePtr));
/* 152 */
EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_((
Tcl_Channel chan));
/* 155 */
EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan));
/* 156 */
-EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN CONST84_RETURN char * Tcl_GetChannelName _ANSI_ARGS_((
+ Tcl_Channel chan));
/* 157 */
EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Channel chan,
- char * optionName, Tcl_DString * dsPtr));
+ CONST char * optionName, Tcl_DString * dsPtr));
/* 158 */
EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
/* 159 */
EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
- char * cmdName, Tcl_CmdInfo * infoPtr));
+ CONST char * cmdName, Tcl_CmdInfo * infoPtr));
/* 160 */
-EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Command command));
+EXTERN CONST84_RETURN char * Tcl_GetCommandName _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Command command));
/* 161 */
EXTERN int Tcl_GetErrno _ANSI_ARGS_((void));
/* 162 */
-EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void));
+EXTERN CONST84_RETURN char * Tcl_GetHostName _ANSI_ARGS_((void));
/* 163 */
EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((
Tcl_Interp * askInterp,
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 167 */
EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, int forWriting, int checkUsage,
- ClientData * filePtr));
+ CONST char * str, int forWriting,
+ int checkUsage, ClientData * filePtr));
#endif /* UNIX */
/* 168 */
-EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char * path));
+EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((CONST char * path));
/* 169 */
EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan,
Tcl_DString * dsPtr));
EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void));
/* 172 */
EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp * interp,
- char * slaveName));
+ CONST char * slaveName));
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type));
/* 174 */
-EXTERN char * Tcl_GetStringResult _ANSI_ARGS_((Tcl_Interp * interp));
+EXTERN CONST84_RETURN char * Tcl_GetStringResult _ANSI_ARGS_((
+ Tcl_Interp * interp));
/* 175 */
-EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName, int flags));
+EXTERN CONST84_RETURN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags));
/* 176 */
-EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, int flags));
+EXTERN CONST84_RETURN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ int flags));
/* 177 */
EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp * interp,
- char * command));
+ CONST char * command));
/* 178 */
EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr));
/* 179 */
EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp * interp,
- char * cmdName, char * hiddenCmdToken));
+ CONST char * cmdName,
+ CONST char * hiddenCmdToken));
/* 180 */
EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp * interp));
/* 181 */
/* 185 */
EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp));
/* 186 */
-EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char ** argv,
+EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc,
+ CONST84 char * CONST * argv,
Tcl_DString * resultPtr));
/* 187 */
EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName, char * addr, int type));
+ CONST char * varName, char * addr, int type));
/* Slot 188 is reserved */
/* 189 */
EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle,
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_((
ClientData tcpSocket));
/* 192 */
-EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char ** argv));
+EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc,
+ CONST84 char * CONST * argv));
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_((
Tcl_HashSearch * searchPtr));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 197 */
EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_((
- Tcl_Interp * interp, int argc, char ** argv,
- int flags));
+ Tcl_Interp * interp, int argc,
+ CONST84 char ** argv, int flags));
#endif /* UNIX */
#ifdef __WIN32__
/* 197 */
EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_((
- Tcl_Interp * interp, int argc, char ** argv,
- int flags));
+ Tcl_Interp * interp, int argc,
+ CONST84 char ** argv, int flags));
#endif /* __WIN32__ */
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp,
- char * fileName, char * modeString,
- int permissions));
+ CONST char * fileName,
+ CONST char * modeString, int permissions));
/* 199 */
EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp * interp,
- int port, char * address, char * myaddr,
- int myport, int async));
+ int port, CONST char * address,
+ CONST char * myaddr, int myport, int async));
/* 200 */
EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp * interp,
- int port, char * host,
+ int port, CONST char * host,
Tcl_TcpAcceptProc * acceptProc,
ClientData callbackData));
/* 201 */
/* 203 */
EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * string));
/* 204 */
-EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp));
+EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp));
/* 205 */
EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event * evPtr,
Tcl_QueuePosition position));
#endif /* __WIN32__ */
/* 208 */
EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp * interp,
- char * cmd, int flags));
+ CONST char * cmd, int flags));
/* 209 */
EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * cmdPtr,
Tcl_ObjType * typePtr));
/* 212 */
EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp,
- char * string));
+ CONST char * string));
/* 213 */
EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_RegExp regexp, CONST char * str,
CONST char * start));
/* 214 */
EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, char * pattern));
+ CONST char * str, CONST char * pattern));
/* 215 */
EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp,
- int index, char ** startPtr, char ** endPtr));
+ int index, CONST84 char ** startPtr,
+ CONST84 char ** endPtr));
/* 216 */
EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
/* 217 */
EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char * str,
int length, int * flagPtr));
/* 220 */
-EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, int offset,
- int mode));
+EXTERN int Tcl_SeekOld _ANSI_ARGS_((Tcl_Channel chan,
+ int offset, int mode));
/* 221 */
EXTERN int Tcl_ServiceAll _ANSI_ARGS_((void));
/* 222 */
EXTERN int Tcl_ServiceEvent _ANSI_ARGS_((int flags));
/* 223 */
EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, Tcl_InterpDeleteProc * proc,
+ CONST char * name,
+ Tcl_InterpDeleteProc * proc,
ClientData clientData));
/* 224 */
EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_((
/* 225 */
EXTERN int Tcl_SetChannelOption _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Channel chan,
- char * optionName, char * newValue));
+ CONST char * optionName,
+ CONST char * newValue));
/* 226 */
EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
- char * cmdName, Tcl_CmdInfo * infoPtr));
+ CONST char * cmdName,
+ CONST Tcl_CmdInfo * infoPtr));
/* 227 */
EXTERN void Tcl_SetErrno _ANSI_ARGS_((int err));
/* 228 */
EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel,
int type));
/* 237 */
-EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName, char * newValue, int flags));
-/* 238 */
-EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, char * newValue,
+EXTERN CONST84_RETURN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, CONST char * newValue,
int flags));
+/* 238 */
+EXTERN CONST84_RETURN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * part1, CONST char * part2,
+ CONST char * newValue, int flags));
/* 239 */
-EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig));
+EXTERN CONST84_RETURN char * Tcl_SignalId _ANSI_ARGS_((int sig));
/* 240 */
-EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
+EXTERN CONST84_RETURN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
/* 241 */
EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp));
/* 242 */
EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp,
CONST char * listStr, int * argcPtr,
- char *** argvPtr));
+ CONST84 char *** argvPtr));
/* 243 */
EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char * path,
- int * argcPtr, char *** argvPtr));
+ int * argcPtr, CONST84 char *** argvPtr));
/* 244 */
EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp,
- char * pkgName,
+ CONST char * pkgName,
Tcl_PackageInitProc * initProc,
Tcl_PackageInitProc * safeInitProc));
/* 245 */
EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str,
CONST char * pattern));
/* 246 */
-EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN int Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan));
/* 247 */
EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName, int flags,
+ CONST char * varName, int flags,
Tcl_VarTraceProc * proc,
ClientData clientData));
/* 248 */
EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, int flags,
- Tcl_VarTraceProc * proc,
+ CONST char * part1, CONST char * part2,
+ int flags, Tcl_VarTraceProc * proc,
ClientData clientData));
/* 249 */
EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((
- Tcl_Interp * interp, char * name,
+ Tcl_Interp * interp, CONST char * name,
Tcl_DString * bufferPtr));
/* 250 */
-EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, char * str,
- int len, int atHead));
+EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * str, int len, int atHead));
/* 251 */
EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName));
+ CONST char * varName));
/* 252 */
EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Channel chan));
/* 253 */
EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName, int flags));
+ CONST char * varName, int flags));
/* 254 */
EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, int flags));
+ CONST char * part1, CONST char * part2,
+ int flags));
/* 255 */
EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName, int flags,
+ CONST char * varName, int flags,
Tcl_VarTraceProc * proc,
ClientData clientData));
/* 256 */
EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, int flags,
- Tcl_VarTraceProc * proc,
+ CONST char * part1, CONST char * part2,
+ int flags, Tcl_VarTraceProc * proc,
ClientData clientData));
/* 257 */
EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName));
+ CONST char * varName));
/* 258 */
EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * frameName, char * varName,
- char * localName, int flags));
+ CONST char * frameName, CONST char * varName,
+ CONST char * localName, int flags));
/* 259 */
EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp * interp,
- char * frameName, char * part1, char * part2,
- char * localName, int flags));
+ CONST char * frameName, CONST char * part1,
+ CONST char * part2, CONST char * localName,
+ int flags));
/* 260 */
EXTERN int Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
/* 261 */
EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName, int flags,
+ CONST char * varName, int flags,
Tcl_VarTraceProc * procPtr,
ClientData prevClientData));
/* 262 */
EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, int flags,
- Tcl_VarTraceProc * procPtr,
+ CONST char * part1, CONST char * part2,
+ int flags, Tcl_VarTraceProc * procPtr,
ClientData prevClientData));
/* 263 */
-EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, char * s,
- int slen));
+EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * s, int slen));
/* 264 */
EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp * interp,
int objc, Tcl_Obj *CONST objv[],
- char * message));
+ CONST char * message));
/* 265 */
-EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char * fileName));
+EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((
+ CONST char * fileName));
/* 266 */
-EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char * file,
+EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((CONST char * file,
int line));
/* 267 */
EXTERN void Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp,
EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_((
Tcl_Obj * objPtr, va_list argList));
/* 269 */
-EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable * tablePtr));
+EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr));
/* 270 */
-EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, char ** termPtr));
+EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * str, CONST84 char ** termPtr));
/* 271 */
-EXTERN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, char * version, int exact));
+EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, CONST char * version,
+ int exact));
/* 272 */
-EXTERN char * Tcl_PkgPresentEx _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, char * version, int exact,
+EXTERN CONST84_RETURN char * Tcl_PkgPresentEx _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name,
+ CONST char * version, int exact,
ClientData * clientDataPtr));
/* 273 */
EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, char * version));
+ CONST char * name, CONST char * version));
/* 274 */
-EXTERN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, char * version, int exact));
+EXTERN CONST84_RETURN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, CONST char * version,
+ int exact));
/* 275 */
EXTERN void Tcl_SetErrorCodeVA _ANSI_ARGS_((Tcl_Interp * interp,
va_list argList));
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int * statPtr,
int options));
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
-/* 278 */
-EXTERN void Tcl_PanicVA _ANSI_ARGS_((char * format,
- va_list argList));
-#endif /* UNIX */
-#ifdef __WIN32__
/* 278 */
-EXTERN void Tcl_PanicVA _ANSI_ARGS_((char * format,
+EXTERN void Tcl_PanicVA _ANSI_ARGS_((CONST char * format,
va_list argList));
-#endif /* __WIN32__ */
/* 279 */
EXTERN void Tcl_GetVersion _ANSI_ARGS_((int * major, int * minor,
int * patchLevel, int * type));
Tcl_Channel chan));
/* 283 */
EXTERN Tcl_Channel Tcl_GetStackedChannel _ANSI_ARGS_((Tcl_Channel chan));
-/* Slot 284 is reserved */
+/* 284 */
+EXTERN void Tcl_SetMainLoop _ANSI_ARGS_((Tcl_MainLoopProc * proc));
/* Slot 285 is reserved */
/* 286 */
EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr,
Tcl_SavedResult * statePtr));
/* 291 */
EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp,
- char * script, int numBytes, int flags));
+ CONST char * script, int numBytes, int flags));
/* 292 */
EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp,
int objc, Tcl_Obj *CONST objv[], int flags));
EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp,
CONST char * name));
/* 302 */
-EXTERN char * Tcl_GetEncodingName _ANSI_ARGS_((
+EXTERN CONST84_RETURN char * Tcl_GetEncodingName _ANSI_ARGS_((
Tcl_Encoding encoding));
/* 303 */
EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_((
/* 304 */
EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * objPtr,
- char ** tablePtr, int offset, char * msg,
- int flags, int * indexPtr));
+ CONST VOID * tablePtr, int offset,
+ CONST char * msg, int flags, int * indexPtr));
/* 305 */
EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_((
Tcl_ThreadDataKey * keyPtr, int size));
/* 306 */
EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, int flags));
+ CONST char * part1, CONST char * part2,
+ int flags));
/* 307 */
EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void));
/* 308 */
Tcl_Interp * interp, CONST char * name));
/* 317 */
EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2,
+ CONST char * part1, CONST char * part2,
Tcl_Obj * newValuePtr, int flags));
/* 318 */
EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId));
/* 324 */
EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf));
/* 325 */
-EXTERN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src,
+EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src,
int index));
/* 326 */
EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src,
EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src,
int * readPtr, char * dst));
/* 328 */
-EXTERN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src,
+EXTERN CONST84_RETURN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src,
int ch));
/* 329 */
-EXTERN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src,
+EXTERN CONST84_RETURN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src,
int ch));
/* 330 */
-EXTERN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src));
+EXTERN CONST84_RETURN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src));
/* 331 */
-EXTERN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src,
+EXTERN CONST84_RETURN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src,
CONST char * start));
/* 332 */
EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp,
/* 340 */
EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr));
/* 341 */
-EXTERN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
+EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
/* 342 */
-EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((char * path));
+EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((
+ CONST char * path));
/* 343 */
EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
/* 344 */
/* 351 */
EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch));
/* 352 */
-EXTERN int Tcl_UniCharLen _ANSI_ARGS_((Tcl_UniChar * str));
+EXTERN int Tcl_UniCharLen _ANSI_ARGS_((CONST Tcl_UniChar * str));
/* 353 */
EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar * cs,
CONST Tcl_UniChar * ct, unsigned long n));
EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr));
/* 359 */
EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
- char * script, char * command, int length));
+ CONST char * script, CONST char * command,
+ int length));
/* 360 */
EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int numBytes,
+ CONST char * string, int numBytes,
Tcl_Parse * parsePtr, int append,
- char ** termPtr));
+ CONST84 char ** termPtr));
/* 361 */
EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int numBytes, int nested,
- Tcl_Parse * parsePtr));
+ CONST char * string, int numBytes,
+ int nested, Tcl_Parse * parsePtr));
/* 362 */
EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int numBytes,
+ CONST char * string, int numBytes,
Tcl_Parse * parsePtr));
/* 363 */
EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_((
- Tcl_Interp * interp, char * string,
+ Tcl_Interp * interp, CONST char * string,
int numBytes, Tcl_Parse * parsePtr,
- int append, char ** termPtr));
+ int append, CONST84 char ** termPtr));
/* 364 */
EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int numBytes,
+ CONST char * string, int numBytes,
Tcl_Parse * parsePtr, int append));
/* 365 */
EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp,
EXTERN void Tcl_RegExpGetInfo _ANSI_ARGS_((Tcl_RegExp regexp,
Tcl_RegExpInfo * infoPtr));
/* 378 */
-EXTERN Tcl_Obj * Tcl_NewUnicodeObj _ANSI_ARGS_((Tcl_UniChar * unicode,
- int numChars));
+EXTERN Tcl_Obj * Tcl_NewUnicodeObj _ANSI_ARGS_((
+ CONST Tcl_UniChar * unicode, int numChars));
/* 379 */
EXTERN void Tcl_SetUnicodeObj _ANSI_ARGS_((Tcl_Obj * objPtr,
- Tcl_UniChar * unicode, int numChars));
+ CONST Tcl_UniChar * unicode, int numChars));
/* 380 */
EXTERN int Tcl_GetCharLength _ANSI_ARGS_((Tcl_Obj * objPtr));
/* 381 */
int first, int last));
/* 384 */
EXTERN void Tcl_AppendUnicodeToObj _ANSI_ARGS_((Tcl_Obj * objPtr,
- Tcl_UniChar * unicode, int length));
+ CONST Tcl_UniChar * unicode, int length));
/* 385 */
EXTERN int Tcl_RegExpMatchObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * stringObj, Tcl_Obj * patternObj));
EXTERN int Tcl_GetChannelNames _ANSI_ARGS_((Tcl_Interp * interp));
/* 389 */
EXTERN int Tcl_GetChannelNamesEx _ANSI_ARGS_((
- Tcl_Interp * interp, char * pattern));
+ Tcl_Interp * interp, CONST char * pattern));
/* 390 */
EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp * interp, int objc,
char * dst, int bytesToRead));
/* 395 */
EXTERN int Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan,
- char * src, int srcLen));
+ CONST char * src, int srcLen));
/* 396 */
EXTERN Tcl_Channel Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan));
/* 397 */
EXTERN int Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan));
/* 398 */
-EXTERN char * Tcl_ChannelName _ANSI_ARGS_((
+EXTERN CONST84_RETURN char * Tcl_ChannelName _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion _ANSI_ARGS_((
/* 411 */
EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
+/* 412 */
+EXTERN int Tcl_JoinThread _ANSI_ARGS_((Tcl_ThreadId id,
+ int* result));
+/* 413 */
+EXTERN int Tcl_IsChannelShared _ANSI_ARGS_((Tcl_Channel channel));
+/* 414 */
+EXTERN int Tcl_IsChannelRegistered _ANSI_ARGS_((
+ Tcl_Interp* interp, Tcl_Channel channel));
+/* 415 */
+EXTERN void Tcl_CutChannel _ANSI_ARGS_((Tcl_Channel channel));
+/* 416 */
+EXTERN void Tcl_SpliceChannel _ANSI_ARGS_((Tcl_Channel channel));
+/* 417 */
+EXTERN void Tcl_ClearChannelHandlers _ANSI_ARGS_((
+ Tcl_Channel channel));
+/* 418 */
+EXTERN int Tcl_IsChannelExisting _ANSI_ARGS_((
+ CONST char* channelName));
+/* 419 */
+EXTERN int Tcl_UniCharNcasecmp _ANSI_ARGS_((
+ CONST Tcl_UniChar * cs,
+ CONST Tcl_UniChar * ct, unsigned long n));
+/* 420 */
+EXTERN int Tcl_UniCharCaseMatch _ANSI_ARGS_((
+ CONST Tcl_UniChar * ustr,
+ CONST Tcl_UniChar * pattern, int nocase));
+/* 421 */
+EXTERN Tcl_HashEntry * Tcl_FindHashEntry _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, CONST char * key));
+/* 422 */
+EXTERN Tcl_HashEntry * Tcl_CreateHashEntry _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, CONST char * key,
+ int * newPtr));
+/* 423 */
+EXTERN void Tcl_InitCustomHashTable _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr, int keyType,
+ Tcl_HashKeyType * typePtr));
+/* 424 */
+EXTERN void Tcl_InitObjHashTable _ANSI_ARGS_((
+ Tcl_HashTable * tablePtr));
+/* 425 */
+EXTERN ClientData Tcl_CommandTraceInfo _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * varName,
+ int flags, Tcl_CommandTraceProc * procPtr,
+ ClientData prevClientData));
+/* 426 */
+EXTERN int Tcl_TraceCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags,
+ Tcl_CommandTraceProc * proc,
+ ClientData clientData));
+/* 427 */
+EXTERN void Tcl_UntraceCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * varName, int flags,
+ Tcl_CommandTraceProc * proc,
+ ClientData clientData));
+/* 428 */
+EXTERN char * Tcl_AttemptAlloc _ANSI_ARGS_((unsigned int size));
+/* 429 */
+EXTERN char * Tcl_AttemptDbCkalloc _ANSI_ARGS_((unsigned int size,
+ CONST char * file, int line));
+/* 430 */
+EXTERN char * Tcl_AttemptRealloc _ANSI_ARGS_((char * ptr,
+ unsigned int size));
+/* 431 */
+EXTERN char * Tcl_AttemptDbCkrealloc _ANSI_ARGS_((char * ptr,
+ unsigned int size, CONST char * file,
+ int line));
+/* 432 */
+EXTERN int Tcl_AttemptSetObjLength _ANSI_ARGS_((
+ Tcl_Obj * objPtr, int length));
+/* 433 */
+EXTERN Tcl_ThreadId Tcl_GetChannelThread _ANSI_ARGS_((
+ Tcl_Channel channel));
+/* 434 */
+EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ int * lengthPtr));
+/* 435 */
+EXTERN int Tcl_GetMathFuncInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name, int * numArgsPtr,
+ Tcl_ValueType ** argTypesPtr,
+ Tcl_MathProc ** procPtr,
+ ClientData * clientDataPtr));
+/* 436 */
+EXTERN Tcl_Obj * Tcl_ListMathFuncs _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * pattern));
+/* 437 */
+EXTERN Tcl_Obj * Tcl_SubstObj _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int flags));
+/* 438 */
+EXTERN int Tcl_DetachChannel _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Channel channel));
+/* 439 */
+EXTERN int Tcl_IsStandardChannel _ANSI_ARGS_((
+ Tcl_Channel channel));
+/* 440 */
+EXTERN int Tcl_FSCopyFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr,
+ Tcl_Obj * destPathPtr));
+/* 441 */
+EXTERN int Tcl_FSCopyDirectory _ANSI_ARGS_((
+ Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr,
+ Tcl_Obj ** errorPtr));
+/* 442 */
+EXTERN int Tcl_FSCreateDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 443 */
+EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 444 */
+EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * pathPtr, CONST char * sym1,
+ CONST char * sym2,
+ Tcl_PackageInitProc ** proc1Ptr,
+ Tcl_PackageInitProc ** proc2Ptr,
+ Tcl_LoadHandle * handlePtr,
+ Tcl_FSUnloadFileProc ** unloadProcPtr));
+/* 445 */
+EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * result,
+ Tcl_Obj * pathPtr, CONST char * pattern,
+ Tcl_GlobTypeData * types));
+/* 446 */
+EXTERN Tcl_Obj * Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_Obj * toPtr, int linkAction));
+/* 447 */
+EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ int recursive, Tcl_Obj ** errorPtr));
+/* 448 */
+EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr,
+ Tcl_Obj * destPathPtr));
+/* 449 */
+EXTERN int Tcl_FSLstat _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_StatBuf * buf));
+/* 450 */
+EXTERN int Tcl_FSUtime _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ struct utimbuf * tval));
+/* 451 */
+EXTERN int Tcl_FSFileAttrsGet _ANSI_ARGS_((Tcl_Interp * interp,
+ int index, Tcl_Obj * pathPtr,
+ Tcl_Obj ** objPtrRef));
+/* 452 */
+EXTERN int Tcl_FSFileAttrsSet _ANSI_ARGS_((Tcl_Interp * interp,
+ int index, Tcl_Obj * pathPtr,
+ Tcl_Obj * objPtr));
+/* 453 */
+EXTERN CONST char ** Tcl_FSFileAttrStrings _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_Obj ** objPtrRef));
+/* 454 */
+EXTERN int Tcl_FSStat _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ Tcl_StatBuf * buf));
+/* 455 */
+EXTERN int Tcl_FSAccess _ANSI_ARGS_((Tcl_Obj * pathPtr,
+ int mode));
+/* 456 */
+EXTERN Tcl_Channel Tcl_FSOpenFileChannel _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * pathPtr,
+ CONST char * modeString, int permissions));
+/* 457 */
+EXTERN Tcl_Obj* Tcl_FSGetCwd _ANSI_ARGS_((Tcl_Interp * interp));
+/* 458 */
+EXTERN int Tcl_FSChdir _ANSI_ARGS_((Tcl_Obj * pathPtr));
+/* 459 */
+EXTERN int Tcl_FSConvertToPathType _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * pathPtr));
+/* 460 */
+EXTERN Tcl_Obj* Tcl_FSJoinPath _ANSI_ARGS_((Tcl_Obj * listObj,
+ int elements));
+/* 461 */
+EXTERN Tcl_Obj* Tcl_FSSplitPath _ANSI_ARGS_((Tcl_Obj* pathPtr,
+ int * lenPtr));
+/* 462 */
+EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj* firstPtr,
+ Tcl_Obj* secondPtr));
+/* 463 */
+EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathObjPtr));
+/* 464 */
+EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr,
+ int objc, Tcl_Obj *CONST objv[]));
+/* 465 */
+EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr));
+/* 466 */
+EXTERN Tcl_Obj* Tcl_FSGetTranslatedPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathPtr));
+/* 467 */
+EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * fileName));
+/* 468 */
+EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_((
+ Tcl_Filesystem* fromFilesystem,
+ ClientData clientData));
+/* 469 */
+EXTERN CONST char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+/* 470 */
+EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr));
+/* 471 */
+EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+/* 472 */
+EXTERN Tcl_Obj* Tcl_FSListVolumes _ANSI_ARGS_((void));
+/* 473 */
+EXTERN int Tcl_FSRegister _ANSI_ARGS_((ClientData clientData,
+ Tcl_Filesystem * fsPtr));
+/* 474 */
+EXTERN int Tcl_FSUnregister _ANSI_ARGS_((Tcl_Filesystem * fsPtr));
+/* 475 */
+EXTERN ClientData Tcl_FSData _ANSI_ARGS_((Tcl_Filesystem * fsPtr));
+/* 476 */
+EXTERN CONST char* Tcl_FSGetTranslatedStringPath _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj* pathPtr));
+/* 477 */
+EXTERN Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_((
+ Tcl_Obj* pathObjPtr));
+/* 478 */
+EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathObjPtr));
+/* 479 */
+EXTERN int Tcl_OutputBuffered _ANSI_ARGS_((Tcl_Channel chan));
+/* 480 */
+EXTERN void Tcl_FSMountsChanged _ANSI_ARGS_((
+ Tcl_Filesystem * fsPtr));
+/* 481 */
+EXTERN int Tcl_EvalTokensStandard _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Token * tokenPtr,
+ int count));
+/* 482 */
+EXTERN void Tcl_GetTime _ANSI_ARGS_((Tcl_Time* timeBuf));
+/* 483 */
+EXTERN Tcl_Trace Tcl_CreateObjTrace _ANSI_ARGS_((Tcl_Interp* interp,
+ int level, int flags,
+ Tcl_CmdObjTraceProc* objProc,
+ ClientData clientData,
+ Tcl_CmdObjTraceDeleteProc* delProc));
+/* 484 */
+EXTERN int Tcl_GetCommandInfoFromToken _ANSI_ARGS_((
+ Tcl_Command token, Tcl_CmdInfo* infoPtr));
+/* 485 */
+EXTERN int Tcl_SetCommandInfoFromToken _ANSI_ARGS_((
+ Tcl_Command token,
+ CONST Tcl_CmdInfo* infoPtr));
+/* 486 */
+EXTERN Tcl_Obj * Tcl_DbNewWideIntObj _ANSI_ARGS_((
+ Tcl_WideInt wideValue, CONST char * file,
+ int line));
+/* 487 */
+EXTERN int Tcl_GetWideIntFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ Tcl_WideInt * widePtr));
+/* 488 */
+EXTERN Tcl_Obj * Tcl_NewWideIntObj _ANSI_ARGS_((Tcl_WideInt wideValue));
+/* 489 */
+EXTERN void Tcl_SetWideIntObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ Tcl_WideInt wideValue));
+/* 490 */
+EXTERN Tcl_StatBuf * Tcl_AllocStatBuf _ANSI_ARGS_((void));
+/* 491 */
+EXTERN Tcl_WideInt Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_WideInt offset, int mode));
+/* 492 */
+EXTERN Tcl_WideInt Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
+/* 493 */
+EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_((
+ Tcl_ChannelType * chanTypePtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
int magic;
struct TclStubHooks *hooks;
- int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, ClientData clientData)); /* 0 */
- char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 1 */
- void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */
+ int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
+ CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
+ void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
- char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, char * file, int line)); /* 6 */
- int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, char * file, int line)); /* 7 */
- char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, char * file, int line)); /* 8 */
+ char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
+ int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
+ char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); /* 9 */
#endif /* UNIX */
int (*tcl_WaitForEvent) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 13 */
int (*tcl_AppendAllObjTypes) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 14 */
void (*tcl_AppendStringsToObj) _ANSI_ARGS_(TCL_VARARGS(Tcl_Obj *,objPtr)); /* 15 */
- void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 16 */
+ void (*tcl_AppendToObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 16 */
Tcl_Obj * (*tcl_ConcatObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 17 */
int (*tcl_ConvertToType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_ObjType * typePtr)); /* 18 */
- void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, char * file, int line)); /* 19 */
- void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, char * file, int line)); /* 20 */
- int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, char * file, int line)); /* 21 */
- Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, char * file, int line)); /* 22 */
- Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((unsigned char * bytes, int length, char * file, int line)); /* 23 */
- Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, char * file, int line)); /* 24 */
- Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[], char * file, int line)); /* 25 */
- Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, char * file, int line)); /* 26 */
- Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((char * file, int line)); /* 27 */
- Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, char * file, int line)); /* 28 */
+ void (*tcl_DbDecrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 19 */
+ void (*tcl_DbIncrRefCount) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 20 */
+ int (*tcl_DbIsShared) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST char * file, int line)); /* 21 */
+ Tcl_Obj * (*tcl_DbNewBooleanObj) _ANSI_ARGS_((int boolValue, CONST char * file, int line)); /* 22 */
+ Tcl_Obj * (*tcl_DbNewByteArrayObj) _ANSI_ARGS_((CONST unsigned char * bytes, int length, CONST char * file, int line)); /* 23 */
+ Tcl_Obj * (*tcl_DbNewDoubleObj) _ANSI_ARGS_((double doubleValue, CONST char * file, int line)); /* 24 */
+ Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST * objv, CONST char * file, int line)); /* 25 */
+ Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, CONST char * file, int line)); /* 26 */
+ Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((CONST char * file, int line)); /* 27 */
+ Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, CONST char * file, int line)); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */
void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */
- int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * boolPtr)); /* 31 */
+ int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * boolPtr)); /* 31 */
int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */
unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */
- int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * doublePtr)); /* 34 */
+ int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * doublePtr)); /* 34 */
int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */
- int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, char * msg, int flags, int * indexPtr)); /* 36 */
- int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * intPtr)); /* 37 */
+ int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST84 char ** tablePtr, CONST char * msg, int flags, int * indexPtr)); /* 36 */
+ int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * intPtr)); /* 37 */
int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */
int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */
- Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((char * typeName)); /* 40 */
+ Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((CONST char * typeName)); /* 40 */
char * (*tcl_GetStringFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 41 */
void (*tcl_InvalidateStringRep) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 42 */
int (*tcl_ListObjAppendList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * elemListPtr)); /* 43 */
int (*tcl_ListObjAppendElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, Tcl_Obj * objPtr)); /* 44 */
int (*tcl_ListObjGetElements) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * objcPtr, Tcl_Obj *** objvPtr)); /* 45 */
int (*tcl_ListObjIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj ** objPtrPtr)); /* 46 */
- int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * intPtr)); /* 47 */
+ int (*tcl_ListObjLength) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int * lengthPtr)); /* 47 */
int (*tcl_ListObjReplace) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[])); /* 48 */
Tcl_Obj * (*tcl_NewBooleanObj) _ANSI_ARGS_((int boolValue)); /* 49 */
- Tcl_Obj * (*tcl_NewByteArrayObj) _ANSI_ARGS_((unsigned char * bytes, int length)); /* 50 */
+ Tcl_Obj * (*tcl_NewByteArrayObj) _ANSI_ARGS_((CONST unsigned char* bytes, int length)); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) _ANSI_ARGS_((double doubleValue)); /* 51 */
Tcl_Obj * (*tcl_NewIntObj) _ANSI_ARGS_((int intValue)); /* 52 */
Tcl_Obj * (*tcl_NewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 53 */
Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((CONST char * bytes, int length)); /* 56 */
void (*tcl_SetBooleanObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int boolValue)); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 58 */
- void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, unsigned char * bytes, int length)); /* 59 */
+ void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST unsigned char * bytes, int length)); /* 59 */
void (*tcl_SetDoubleObj) _ANSI_ARGS_((Tcl_Obj * objPtr, double doubleValue)); /* 60 */
void (*tcl_SetIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int intValue)); /* 61 */
void (*tcl_SetListObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int objc, Tcl_Obj *CONST objv[])); /* 62 */
void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
- void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 65 */
+ void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj* objPtr, CONST char* bytes, int length)); /* 65 */
void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
- int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, char * optionName, char * optionList)); /* 78 */
+ int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * optionName, CONST char * optionList)); /* 78 */
void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 79 */
void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc * idleProc, ClientData clientData)); /* 80 */
int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 81 */
- int (*tcl_CommandComplete) _ANSI_ARGS_((char * cmd)); /* 82 */
- char * (*tcl_Concat) _ANSI_ARGS_((int argc, char ** argv)); /* 83 */
+ int (*tcl_CommandComplete) _ANSI_ARGS_((CONST char * cmd)); /* 82 */
+ char * (*tcl_Concat) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 83 */
int (*tcl_ConvertElement) _ANSI_ARGS_((CONST char * src, char * dst, int flags)); /* 84 */
int (*tcl_ConvertCountedElement) _ANSI_ARGS_((CONST char * src, int length, char * dst, int flags)); /* 85 */
- int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, char * slaveCmd, Tcl_Interp * target, char * targetCmd, int argc, char ** argv)); /* 86 */
- int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, char * slaveCmd, Tcl_Interp * target, char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */
- Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, char * chanName, ClientData instanceData, int mask)); /* 88 */
+ int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int argc, CONST84 char * CONST * argv)); /* 86 */
+ int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */
+ Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, CONST char * chanName, ClientData instanceData, int mask)); /* 88 */
void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc * proc, ClientData clientData)); /* 89 */
void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 90 */
- Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
+ Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 92 */
void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) _ANSI_ARGS_((void)); /* 94 */
- void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp * interp, char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 95 */
- Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 96 */
- Tcl_Interp * (*tcl_CreateSlave) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveName, int isSafe)); /* 97 */
+ void (*tcl_CreateMathFunc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int numArgs, Tcl_ValueType * argTypes, Tcl_MathProc * proc, ClientData clientData)); /* 95 */
+ Tcl_Command (*tcl_CreateObjCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 96 */
+ Tcl_Interp * (*tcl_CreateSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName, int isSafe)); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) _ANSI_ARGS_((int milliseconds, Tcl_TimerProc * proc, ClientData clientData)); /* 98 */
Tcl_Trace (*tcl_CreateTrace) _ANSI_ARGS_((Tcl_Interp * interp, int level, Tcl_CmdTraceProc * proc, ClientData clientData)); /* 99 */
- void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 100 */
+ void (*tcl_DeleteAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 100 */
void (*tcl_DeleteChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_ChannelProc * proc, ClientData clientData)); /* 101 */
void (*tcl_DeleteCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 102 */
- int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName)); /* 103 */
+ int (*tcl_DeleteCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName)); /* 103 */
int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */
void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */
void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */
void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */
void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */
int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
- char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
- char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
- int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 129 */
- int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName)); /* 130 */
+ CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
+ CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
+ int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 129 */
+ int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */
int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
- int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * hiddenCmdToken, char * cmdName)); /* 134 */
- int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * ptr)); /* 135 */
+ int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
+ int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */
int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
- int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * ptr)); /* 137 */
+ int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */
int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
- int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * ptr)); /* 139 */
+ int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */
int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
- int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 142 */
+ int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */
void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
- int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveCmd, Tcl_Interp ** targetInterpPtr, char ** targetCmdPtr, int * argcPtr, char *** argvPtr)); /* 148 */
- int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveCmd, Tcl_Interp ** targetInterpPtr, char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
- ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
- Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * chanName, int * modePtr)); /* 151 */
+ int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 148 */
+ int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
+ ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
+ Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanName, int * modePtr)); /* 151 */
int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */
int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData * handlePtr)); /* 153 */
ClientData (*tcl_GetChannelInstanceData) _ANSI_ARGS_((Tcl_Channel chan)); /* 154 */
int (*tcl_GetChannelMode) _ANSI_ARGS_((Tcl_Channel chan)); /* 155 */
- char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
- int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, char * optionName, Tcl_DString * dsPtr)); /* 157 */
+ CONST84_RETURN char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
+ int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, Tcl_DString * dsPtr)); /* 157 */
Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */
- int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
- char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
+ int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
+ CONST84_RETURN char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
- char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
+ CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */
CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
- int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
+ int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
void *reserved167;
#ifdef MAC_TCL
void *reserved167;
#endif /* MAC_TCL */
- Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((char * path)); /* 168 */
+ Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */
int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */
int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */
int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */
- Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, char * slaveName)); /* 172 */
+ Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) _ANSI_ARGS_((int type)); /* 173 */
- char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */
- char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags)); /* 175 */
- char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 176 */
- int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, char * command)); /* 177 */
+ CONST84_RETURN char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */
+ CONST84_RETURN char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 175 */
+ CONST84_RETURN char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 176 */
+ int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command)); /* 177 */
int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 178 */
- int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, char * hiddenCmdToken)); /* 179 */
+ int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); /* 179 */
int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 180 */
void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType)); /* 181 */
int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */
int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */
int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */
int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */
- char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, char ** argv, Tcl_DString * resultPtr)); /* 186 */
- int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * addr, int type)); /* 187 */
+ char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 186 */
+ int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, char * addr, int type)); /* 187 */
void *reserved188;
Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */
int (*tcl_MakeSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) _ANSI_ARGS_((ClientData tcpSocket)); /* 191 */
- char * (*tcl_Merge) _ANSI_ARGS_((int argc, char ** argv)); /* 192 */
+ char * (*tcl_Merge) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) _ANSI_ARGS_((Tcl_HashSearch * searchPtr)); /* 193 */
void (*tcl_NotifyChannel) _ANSI_ARGS_((Tcl_Channel channel, int mask)); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); /* 196 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
- Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 197 */
+ Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* UNIX */
#ifdef __WIN32__
- Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 197 */
+ Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved197;
#endif /* MAC_TCL */
- Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 198 */
- Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, char * address, char * myaddr, int myport, int async)); /* 199 */
- Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
+ Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */
+ Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */
+ Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */
int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */
- char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
+ CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */
int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifdef MAC_TCL
void *reserved207;
#endif /* MAC_TCL */
- int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, char * cmd, int flags)); /* 208 */
+ int (*tcl_RecordAndEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmd, int flags)); /* 208 */
int (*tcl_RecordAndEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * cmdPtr, int flags)); /* 209 */
void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */
void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */
- Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 212 */
+ Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 212 */
int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */
- int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * pattern)); /* 214 */
- void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, char ** startPtr, char ** endPtr)); /* 215 */
+ int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST char * pattern)); /* 214 */
+ void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, CONST84 char ** startPtr, CONST84 char ** endPtr)); /* 215 */
void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */
void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */
int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */
int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */
- int (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
+ int (*tcl_SeekOld) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
- void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
+ void (*tcl_SetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 223 */
void (*tcl_SetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan, int sz)); /* 224 */
- int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, char * optionName, char * newValue)); /* 225 */
- int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * cmdName, Tcl_CmdInfo * infoPtr)); /* 226 */
+ int (*tcl_SetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, CONST char * newValue)); /* 225 */
+ int (*tcl_SetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST Tcl_CmdInfo * infoPtr)); /* 226 */
void (*tcl_SetErrno) _ANSI_ARGS_((int err)); /* 227 */
void (*tcl_SetErrorCode) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 228 */
void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
- char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, char * newValue, int flags)); /* 237 */
- char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, char * newValue, int flags)); /* 238 */
- char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
- char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
+ CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */
+ CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */
+ CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
+ CONST84_RETURN char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */
- int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, char *** argvPtr)); /* 242 */
- void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, char *** argvPtr)); /* 243 */
- void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */
+ int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, CONST84 char *** argvPtr)); /* 242 */
+ void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */
+ void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */
int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */
- int (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
- int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */
- int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */
- char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_DString * bufferPtr)); /* 249 */
- int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, char * str, int len, int atHead)); /* 250 */
- void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 251 */
+ int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
+ int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */
+ int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */
+ char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 249 */
+ int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, CONST char * str, int len, int atHead)); /* 250 */
+ void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 251 */
int (*tcl_UnregisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 252 */
- int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags)); /* 253 */
- int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 254 */
- void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
- void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
- void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 257 */
- int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, char * frameName, char * varName, char * localName, int flags)); /* 258 */
- int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * frameName, char * part1, char * part2, char * localName, int flags)); /* 259 */
+ int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
+ int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
+ void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
+ void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
+ void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
+ int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
+ int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
- ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
- ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
- int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, char * s, int slen)); /* 263 */
- void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], char * message)); /* 264 */
- int (*tcl_DumpActiveMemory) _ANSI_ARGS_((char * fileName)); /* 265 */
- void (*tcl_ValidateAllMemory) _ANSI_ARGS_((char * file, int line)); /* 266 */
+ ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
+ ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
+ int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
+ void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
+ int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
+ void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */
- char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
- char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char ** termPtr)); /* 270 */
- char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); /* 271 */
- char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 272 */
- int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version)); /* 273 */
- char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); /* 274 */
+ CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
+ CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 270 */
+ CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */
+ CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */
+ int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */
+ CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */
void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
- void (*tcl_PanicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */
-#endif /* UNIX */
-#ifdef __WIN32__
- void (*tcl_PanicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */
-#endif /* __WIN32__ */
-#ifdef MAC_TCL
- void *reserved278;
-#endif /* MAC_TCL */
+ void (*tcl_PanicVA) _ANSI_ARGS_((CONST char * format, va_list argList)); /* 278 */
void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */
void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */
Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
- void *reserved284;
+ void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */
void *reserved285;
void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */
void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */
void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */
- int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, char * script, int numBytes, int flags)); /* 291 */
+ int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, int numBytes, int flags)); /* 291 */
int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */
int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */
void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */
void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */
- char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
+ CONST84_RETURN char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */
- int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, int offset, char * msg, int flags, int * indexPtr)); /* 304 */
+ int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST VOID * tablePtr, int offset, CONST char * msg, int flags, int * indexPtr)); /* 304 */
VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
- Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 306 */
+ Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 306 */
ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
- Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
+ Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */
Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */
Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */
- char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
+ CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */
int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
- char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
- char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
- char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
- char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
+ CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
+ CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
+ CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
+ CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */
int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */
int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */
int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */
char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */
- char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
- void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((char * path)); /* 342 */
+ CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
+ void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((CONST char * path)); /* 342 */
void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
- int (*tcl_UniCharLen) _ANSI_ARGS_((Tcl_UniChar * str)); /* 352 */
+ int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */
int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */
char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
- void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * script, char * command, int length)); /* 359 */
- int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 360 */
- int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
- int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
- int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 363 */
- int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
+ void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */
+ int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */
+ int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
+ int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
+ int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */
+ int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */
int (*tcl_UniCharIsPunct) _ANSI_ARGS_((int ch)); /* 375 */
int (*tcl_RegExpExecObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, Tcl_Obj * objPtr, int offset, int nmatches, int flags)); /* 376 */
void (*tcl_RegExpGetInfo) _ANSI_ARGS_((Tcl_RegExp regexp, Tcl_RegExpInfo * infoPtr)); /* 377 */
- Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((Tcl_UniChar * unicode, int numChars)); /* 378 */
- void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_UniChar * unicode, int numChars)); /* 379 */
+ Tcl_Obj * (*tcl_NewUnicodeObj) _ANSI_ARGS_((CONST Tcl_UniChar * unicode, int numChars)); /* 378 */
+ void (*tcl_SetUnicodeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int numChars)); /* 379 */
int (*tcl_GetCharLength) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 380 */
Tcl_UniChar (*tcl_GetUniChar) _ANSI_ARGS_((Tcl_Obj * objPtr, int index)); /* 381 */
Tcl_UniChar * (*tcl_GetUnicode) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 382 */
Tcl_Obj * (*tcl_GetRange) _ANSI_ARGS_((Tcl_Obj * objPtr, int first, int last)); /* 383 */
- void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_UniChar * unicode, int length)); /* 384 */
+ void (*tcl_AppendUnicodeToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, CONST Tcl_UniChar * unicode, int length)); /* 384 */
int (*tcl_RegExpMatchObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * stringObj, Tcl_Obj * patternObj)); /* 385 */
void (*tcl_SetNotifier) _ANSI_ARGS_((Tcl_NotifierProcs * notifierProcPtr)); /* 386 */
Tcl_Mutex * (*tcl_GetAllocMutex) _ANSI_ARGS_((void)); /* 387 */
int (*tcl_GetChannelNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 388 */
- int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, char * pattern)); /* 389 */
+ int (*tcl_GetChannelNamesEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 389 */
int (*tcl_ProcObjCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 390 */
void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */
int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId * idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */
int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 394 */
- int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, char * src, int srcLen)); /* 395 */
+ int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */
int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */
- char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */
+ CONST84_RETURN char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 400 */
Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 401 */
Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 409 */
Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 410 */
Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 411 */
+ int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId id, int* result)); /* 412 */
+ int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */
+ int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */
+ void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */
+ void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */
+ void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */
+ int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */
+ int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 419 */
+ int (*tcl_UniCharCaseMatch) _ANSI_ARGS_((CONST Tcl_UniChar * ustr, CONST Tcl_UniChar * pattern, int nocase)); /* 420 */
+ Tcl_HashEntry * (*tcl_FindHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key)); /* 421 */
+ Tcl_HashEntry * (*tcl_CreateHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, CONST char * key, int * newPtr)); /* 422 */
+ void (*tcl_InitCustomHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType, Tcl_HashKeyType * typePtr)); /* 423 */
+ void (*tcl_InitObjHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 424 */
+ ClientData (*tcl_CommandTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * procPtr, ClientData prevClientData)); /* 425 */
+ int (*tcl_TraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 426 */
+ void (*tcl_UntraceCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_CommandTraceProc * proc, ClientData clientData)); /* 427 */
+ char * (*tcl_AttemptAlloc) _ANSI_ARGS_((unsigned int size)); /* 428 */
+ char * (*tcl_AttemptDbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 429 */
+ char * (*tcl_AttemptRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 430 */
+ char * (*tcl_AttemptDbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 431 */
+ int (*tcl_AttemptSetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 432 */
+ Tcl_ThreadId (*tcl_GetChannelThread) _ANSI_ARGS_((Tcl_Channel channel)); /* 433 */
+ Tcl_UniChar * (*tcl_GetUnicodeFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 434 */
+ int (*tcl_GetMathFuncInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int * numArgsPtr, Tcl_ValueType ** argTypesPtr, Tcl_MathProc ** procPtr, ClientData * clientDataPtr)); /* 435 */
+ Tcl_Obj * (*tcl_ListMathFuncs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pattern)); /* 436 */
+ Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
+ int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */
+ int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
+ int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */
+ int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */
+ int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */
+ int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */
+ int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, Tcl_LoadHandle * handlePtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */
+ int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */
+ Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr, int linkAction)); /* 446 */
+ int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */
+ int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */
+ int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */
+ int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */
+ int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */
+ int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */
+ CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */
+ int (*tcl_FSStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 454 */
+ int (*tcl_FSAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 455 */
+ Tcl_Channel (*tcl_FSOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * modeString, int permissions)); /* 456 */
+ Tcl_Obj* (*tcl_FSGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 457 */
+ int (*tcl_FSChdir) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 458 */
+ int (*tcl_FSConvertToPathType) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr)); /* 459 */
+ Tcl_Obj* (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj * listObj, int elements)); /* 460 */
+ Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
+ int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
+ Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
+ Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
+ ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
+ Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
+ int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
+ Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Filesystem* fromFilesystem, ClientData clientData)); /* 468 */
+ CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */
+ Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */
+ Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */
+ Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */
+ int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */
+ int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
+ ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */
+ CONST char* (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 476 */
+ Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 477 */
+ Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */
+ int (*tcl_OutputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 479 */
+ void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */
+ int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */
+ void (*tcl_GetTime) _ANSI_ARGS_((Tcl_Time* timeBuf)); /* 482 */
+ Tcl_Trace (*tcl_CreateObjTrace) _ANSI_ARGS_((Tcl_Interp* interp, int level, int flags, Tcl_CmdObjTraceProc* objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc* delProc)); /* 483 */
+ int (*tcl_GetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, Tcl_CmdInfo* infoPtr)); /* 484 */
+ int (*tcl_SetCommandInfoFromToken) _ANSI_ARGS_((Tcl_Command token, CONST Tcl_CmdInfo* infoPtr)); /* 485 */
+ Tcl_Obj * (*tcl_DbNewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue, CONST char * file, int line)); /* 486 */
+ int (*tcl_GetWideIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_WideInt * widePtr)); /* 487 */
+ Tcl_Obj * (*tcl_NewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue)); /* 488 */
+ void (*tcl_SetWideIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_WideInt wideValue)); /* 489 */
+ Tcl_StatBuf * (*tcl_AllocStatBuf) _ANSI_ARGS_((void)); /* 490 */
+ Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */
+ Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */
+ Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 493 */
} TclStubs;
#ifdef __cplusplus
#define Tcl_ScanCountedElement \
(tclStubsPtr->tcl_ScanCountedElement) /* 219 */
#endif
-#ifndef Tcl_Seek
-#define Tcl_Seek \
- (tclStubsPtr->tcl_Seek) /* 220 */
+#ifndef Tcl_SeekOld
+#define Tcl_SeekOld \
+ (tclStubsPtr->tcl_SeekOld) /* 220 */
#endif
#ifndef Tcl_ServiceAll
#define Tcl_ServiceAll \
#define Tcl_StringMatch \
(tclStubsPtr->tcl_StringMatch) /* 245 */
#endif
-#ifndef Tcl_Tell
-#define Tcl_Tell \
- (tclStubsPtr->tcl_Tell) /* 246 */
+#ifndef Tcl_TellOld
+#define Tcl_TellOld \
+ (tclStubsPtr->tcl_TellOld) /* 246 */
#endif
#ifndef Tcl_TraceVar
#define Tcl_TraceVar \
#define Tcl_WaitPid \
(tclStubsPtr->tcl_WaitPid) /* 277 */
#endif
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
-#ifndef Tcl_PanicVA
-#define Tcl_PanicVA \
- (tclStubsPtr->tcl_PanicVA) /* 278 */
-#endif
-#endif /* UNIX */
-#ifdef __WIN32__
#ifndef Tcl_PanicVA
#define Tcl_PanicVA \
(tclStubsPtr->tcl_PanicVA) /* 278 */
#endif
-#endif /* __WIN32__ */
#ifndef Tcl_GetVersion
#define Tcl_GetVersion \
(tclStubsPtr->tcl_GetVersion) /* 279 */
#define Tcl_GetStackedChannel \
(tclStubsPtr->tcl_GetStackedChannel) /* 283 */
#endif
-/* Slot 284 is reserved */
+#ifndef Tcl_SetMainLoop
+#define Tcl_SetMainLoop \
+ (tclStubsPtr->tcl_SetMainLoop) /* 284 */
+#endif
/* Slot 285 is reserved */
#ifndef Tcl_AppendObjToObj
#define Tcl_AppendObjToObj \
#define Tcl_ChannelHandlerProc \
(tclStubsPtr->tcl_ChannelHandlerProc) /* 411 */
#endif
+#ifndef Tcl_JoinThread
+#define Tcl_JoinThread \
+ (tclStubsPtr->tcl_JoinThread) /* 412 */
+#endif
+#ifndef Tcl_IsChannelShared
+#define Tcl_IsChannelShared \
+ (tclStubsPtr->tcl_IsChannelShared) /* 413 */
+#endif
+#ifndef Tcl_IsChannelRegistered
+#define Tcl_IsChannelRegistered \
+ (tclStubsPtr->tcl_IsChannelRegistered) /* 414 */
+#endif
+#ifndef Tcl_CutChannel
+#define Tcl_CutChannel \
+ (tclStubsPtr->tcl_CutChannel) /* 415 */
+#endif
+#ifndef Tcl_SpliceChannel
+#define Tcl_SpliceChannel \
+ (tclStubsPtr->tcl_SpliceChannel) /* 416 */
+#endif
+#ifndef Tcl_ClearChannelHandlers
+#define Tcl_ClearChannelHandlers \
+ (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */
+#endif
+#ifndef Tcl_IsChannelExisting
+#define Tcl_IsChannelExisting \
+ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */
+#endif
+#ifndef Tcl_UniCharNcasecmp
+#define Tcl_UniCharNcasecmp \
+ (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */
+#endif
+#ifndef Tcl_UniCharCaseMatch
+#define Tcl_UniCharCaseMatch \
+ (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */
+#endif
+#ifndef Tcl_FindHashEntry
+#define Tcl_FindHashEntry \
+ (tclStubsPtr->tcl_FindHashEntry) /* 421 */
+#endif
+#ifndef Tcl_CreateHashEntry
+#define Tcl_CreateHashEntry \
+ (tclStubsPtr->tcl_CreateHashEntry) /* 422 */
+#endif
+#ifndef Tcl_InitCustomHashTable
+#define Tcl_InitCustomHashTable \
+ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */
+#endif
+#ifndef Tcl_InitObjHashTable
+#define Tcl_InitObjHashTable \
+ (tclStubsPtr->tcl_InitObjHashTable) /* 424 */
+#endif
+#ifndef Tcl_CommandTraceInfo
+#define Tcl_CommandTraceInfo \
+ (tclStubsPtr->tcl_CommandTraceInfo) /* 425 */
+#endif
+#ifndef Tcl_TraceCommand
+#define Tcl_TraceCommand \
+ (tclStubsPtr->tcl_TraceCommand) /* 426 */
+#endif
+#ifndef Tcl_UntraceCommand
+#define Tcl_UntraceCommand \
+ (tclStubsPtr->tcl_UntraceCommand) /* 427 */
+#endif
+#ifndef Tcl_AttemptAlloc
+#define Tcl_AttemptAlloc \
+ (tclStubsPtr->tcl_AttemptAlloc) /* 428 */
+#endif
+#ifndef Tcl_AttemptDbCkalloc
+#define Tcl_AttemptDbCkalloc \
+ (tclStubsPtr->tcl_AttemptDbCkalloc) /* 429 */
+#endif
+#ifndef Tcl_AttemptRealloc
+#define Tcl_AttemptRealloc \
+ (tclStubsPtr->tcl_AttemptRealloc) /* 430 */
+#endif
+#ifndef Tcl_AttemptDbCkrealloc
+#define Tcl_AttemptDbCkrealloc \
+ (tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */
+#endif
+#ifndef Tcl_AttemptSetObjLength
+#define Tcl_AttemptSetObjLength \
+ (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */
+#endif
+#ifndef Tcl_GetChannelThread
+#define Tcl_GetChannelThread \
+ (tclStubsPtr->tcl_GetChannelThread) /* 433 */
+#endif
+#ifndef Tcl_GetUnicodeFromObj
+#define Tcl_GetUnicodeFromObj \
+ (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */
+#endif
+#ifndef Tcl_GetMathFuncInfo
+#define Tcl_GetMathFuncInfo \
+ (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */
+#endif
+#ifndef Tcl_ListMathFuncs
+#define Tcl_ListMathFuncs \
+ (tclStubsPtr->tcl_ListMathFuncs) /* 436 */
+#endif
+#ifndef Tcl_SubstObj
+#define Tcl_SubstObj \
+ (tclStubsPtr->tcl_SubstObj) /* 437 */
+#endif
+#ifndef Tcl_DetachChannel
+#define Tcl_DetachChannel \
+ (tclStubsPtr->tcl_DetachChannel) /* 438 */
+#endif
+#ifndef Tcl_IsStandardChannel
+#define Tcl_IsStandardChannel \
+ (tclStubsPtr->tcl_IsStandardChannel) /* 439 */
+#endif
+#ifndef Tcl_FSCopyFile
+#define Tcl_FSCopyFile \
+ (tclStubsPtr->tcl_FSCopyFile) /* 440 */
+#endif
+#ifndef Tcl_FSCopyDirectory
+#define Tcl_FSCopyDirectory \
+ (tclStubsPtr->tcl_FSCopyDirectory) /* 441 */
+#endif
+#ifndef Tcl_FSCreateDirectory
+#define Tcl_FSCreateDirectory \
+ (tclStubsPtr->tcl_FSCreateDirectory) /* 442 */
+#endif
+#ifndef Tcl_FSDeleteFile
+#define Tcl_FSDeleteFile \
+ (tclStubsPtr->tcl_FSDeleteFile) /* 443 */
+#endif
+#ifndef Tcl_FSLoadFile
+#define Tcl_FSLoadFile \
+ (tclStubsPtr->tcl_FSLoadFile) /* 444 */
+#endif
+#ifndef Tcl_FSMatchInDirectory
+#define Tcl_FSMatchInDirectory \
+ (tclStubsPtr->tcl_FSMatchInDirectory) /* 445 */
+#endif
+#ifndef Tcl_FSLink
+#define Tcl_FSLink \
+ (tclStubsPtr->tcl_FSLink) /* 446 */
+#endif
+#ifndef Tcl_FSRemoveDirectory
+#define Tcl_FSRemoveDirectory \
+ (tclStubsPtr->tcl_FSRemoveDirectory) /* 447 */
+#endif
+#ifndef Tcl_FSRenameFile
+#define Tcl_FSRenameFile \
+ (tclStubsPtr->tcl_FSRenameFile) /* 448 */
+#endif
+#ifndef Tcl_FSLstat
+#define Tcl_FSLstat \
+ (tclStubsPtr->tcl_FSLstat) /* 449 */
+#endif
+#ifndef Tcl_FSUtime
+#define Tcl_FSUtime \
+ (tclStubsPtr->tcl_FSUtime) /* 450 */
+#endif
+#ifndef Tcl_FSFileAttrsGet
+#define Tcl_FSFileAttrsGet \
+ (tclStubsPtr->tcl_FSFileAttrsGet) /* 451 */
+#endif
+#ifndef Tcl_FSFileAttrsSet
+#define Tcl_FSFileAttrsSet \
+ (tclStubsPtr->tcl_FSFileAttrsSet) /* 452 */
+#endif
+#ifndef Tcl_FSFileAttrStrings
+#define Tcl_FSFileAttrStrings \
+ (tclStubsPtr->tcl_FSFileAttrStrings) /* 453 */
+#endif
+#ifndef Tcl_FSStat
+#define Tcl_FSStat \
+ (tclStubsPtr->tcl_FSStat) /* 454 */
+#endif
+#ifndef Tcl_FSAccess
+#define Tcl_FSAccess \
+ (tclStubsPtr->tcl_FSAccess) /* 455 */
+#endif
+#ifndef Tcl_FSOpenFileChannel
+#define Tcl_FSOpenFileChannel \
+ (tclStubsPtr->tcl_FSOpenFileChannel) /* 456 */
+#endif
+#ifndef Tcl_FSGetCwd
+#define Tcl_FSGetCwd \
+ (tclStubsPtr->tcl_FSGetCwd) /* 457 */
+#endif
+#ifndef Tcl_FSChdir
+#define Tcl_FSChdir \
+ (tclStubsPtr->tcl_FSChdir) /* 458 */
+#endif
+#ifndef Tcl_FSConvertToPathType
+#define Tcl_FSConvertToPathType \
+ (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */
+#endif
+#ifndef Tcl_FSJoinPath
+#define Tcl_FSJoinPath \
+ (tclStubsPtr->tcl_FSJoinPath) /* 460 */
+#endif
+#ifndef Tcl_FSSplitPath
+#define Tcl_FSSplitPath \
+ (tclStubsPtr->tcl_FSSplitPath) /* 461 */
+#endif
+#ifndef Tcl_FSEqualPaths
+#define Tcl_FSEqualPaths \
+ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */
+#endif
+#ifndef Tcl_FSGetNormalizedPath
+#define Tcl_FSGetNormalizedPath \
+ (tclStubsPtr->tcl_FSGetNormalizedPath) /* 463 */
+#endif
+#ifndef Tcl_FSJoinToPath
+#define Tcl_FSJoinToPath \
+ (tclStubsPtr->tcl_FSJoinToPath) /* 464 */
+#endif
+#ifndef Tcl_FSGetInternalRep
+#define Tcl_FSGetInternalRep \
+ (tclStubsPtr->tcl_FSGetInternalRep) /* 465 */
+#endif
+#ifndef Tcl_FSGetTranslatedPath
+#define Tcl_FSGetTranslatedPath \
+ (tclStubsPtr->tcl_FSGetTranslatedPath) /* 466 */
+#endif
+#ifndef Tcl_FSEvalFile
+#define Tcl_FSEvalFile \
+ (tclStubsPtr->tcl_FSEvalFile) /* 467 */
+#endif
+#ifndef Tcl_FSNewNativePath
+#define Tcl_FSNewNativePath \
+ (tclStubsPtr->tcl_FSNewNativePath) /* 468 */
+#endif
+#ifndef Tcl_FSGetNativePath
+#define Tcl_FSGetNativePath \
+ (tclStubsPtr->tcl_FSGetNativePath) /* 469 */
+#endif
+#ifndef Tcl_FSFileSystemInfo
+#define Tcl_FSFileSystemInfo \
+ (tclStubsPtr->tcl_FSFileSystemInfo) /* 470 */
+#endif
+#ifndef Tcl_FSPathSeparator
+#define Tcl_FSPathSeparator \
+ (tclStubsPtr->tcl_FSPathSeparator) /* 471 */
+#endif
+#ifndef Tcl_FSListVolumes
+#define Tcl_FSListVolumes \
+ (tclStubsPtr->tcl_FSListVolumes) /* 472 */
+#endif
+#ifndef Tcl_FSRegister
+#define Tcl_FSRegister \
+ (tclStubsPtr->tcl_FSRegister) /* 473 */
+#endif
+#ifndef Tcl_FSUnregister
+#define Tcl_FSUnregister \
+ (tclStubsPtr->tcl_FSUnregister) /* 474 */
+#endif
+#ifndef Tcl_FSData
+#define Tcl_FSData \
+ (tclStubsPtr->tcl_FSData) /* 475 */
+#endif
+#ifndef Tcl_FSGetTranslatedStringPath
+#define Tcl_FSGetTranslatedStringPath \
+ (tclStubsPtr->tcl_FSGetTranslatedStringPath) /* 476 */
+#endif
+#ifndef Tcl_FSGetFileSystemForPath
+#define Tcl_FSGetFileSystemForPath \
+ (tclStubsPtr->tcl_FSGetFileSystemForPath) /* 477 */
+#endif
+#ifndef Tcl_FSGetPathType
+#define Tcl_FSGetPathType \
+ (tclStubsPtr->tcl_FSGetPathType) /* 478 */
+#endif
+#ifndef Tcl_OutputBuffered
+#define Tcl_OutputBuffered \
+ (tclStubsPtr->tcl_OutputBuffered) /* 479 */
+#endif
+#ifndef Tcl_FSMountsChanged
+#define Tcl_FSMountsChanged \
+ (tclStubsPtr->tcl_FSMountsChanged) /* 480 */
+#endif
+#ifndef Tcl_EvalTokensStandard
+#define Tcl_EvalTokensStandard \
+ (tclStubsPtr->tcl_EvalTokensStandard) /* 481 */
+#endif
+#ifndef Tcl_GetTime
+#define Tcl_GetTime \
+ (tclStubsPtr->tcl_GetTime) /* 482 */
+#endif
+#ifndef Tcl_CreateObjTrace
+#define Tcl_CreateObjTrace \
+ (tclStubsPtr->tcl_CreateObjTrace) /* 483 */
+#endif
+#ifndef Tcl_GetCommandInfoFromToken
+#define Tcl_GetCommandInfoFromToken \
+ (tclStubsPtr->tcl_GetCommandInfoFromToken) /* 484 */
+#endif
+#ifndef Tcl_SetCommandInfoFromToken
+#define Tcl_SetCommandInfoFromToken \
+ (tclStubsPtr->tcl_SetCommandInfoFromToken) /* 485 */
+#endif
+#ifndef Tcl_DbNewWideIntObj
+#define Tcl_DbNewWideIntObj \
+ (tclStubsPtr->tcl_DbNewWideIntObj) /* 486 */
+#endif
+#ifndef Tcl_GetWideIntFromObj
+#define Tcl_GetWideIntFromObj \
+ (tclStubsPtr->tcl_GetWideIntFromObj) /* 487 */
+#endif
+#ifndef Tcl_NewWideIntObj
+#define Tcl_NewWideIntObj \
+ (tclStubsPtr->tcl_NewWideIntObj) /* 488 */
+#endif
+#ifndef Tcl_SetWideIntObj
+#define Tcl_SetWideIntObj \
+ (tclStubsPtr->tcl_SetWideIntObj) /* 489 */
+#endif
+#ifndef Tcl_AllocStatBuf
+#define Tcl_AllocStatBuf \
+ (tclStubsPtr->tcl_AllocStatBuf) /* 490 */
+#endif
+#ifndef Tcl_Seek
+#define Tcl_Seek \
+ (tclStubsPtr->tcl_Seek) /* 491 */
+#endif
+#ifndef Tcl_Tell
+#define Tcl_Tell \
+ (tclStubsPtr->tcl_Tell) /* 492 */
+#endif
+#ifndef Tcl_ChannelWideSeekProc
+#define Tcl_ChannelWideSeekProc \
+ (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
#endif /* _TCLDECLS */
-
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
- Encoding *encodingPtr;
Tcl_MutexLock(&encodingMutex);
encodingsInitialized = 0;
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
- encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
- if (encodingPtr->freeProc != NULL) {
- (*encodingPtr->freeProc)(encodingPtr->clientData);
- }
- ckfree((char *) encodingPtr->name);
- ckfree((char *) encodingPtr);
+ /*
+ * Call FreeEncoding instead of doing it directly to handle refcounts
+ * like escape encodings use. [Bug #524674]
+ */
+ FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr));
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&encodingTable);
*-------------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetDefaultEncodingDir()
{
return tclDefaultEncodingDir;
void
Tcl_SetDefaultEncodingDir(path)
- char *path;
+ CONST char *path;
{
tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1);
strcpy(tclDefaultEncodingDir, path);
*---------------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetEncodingName(encoding)
Tcl_Encoding encoding; /* The encoding whose name to fetch. */
{
if (pathPtr != NULL) {
int i, objc;
Tcl_Obj **objv;
- Tcl_DString pwdString;
char globArgString[10];
-
+ Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1);
+ Tcl_IncrRefCount(encodingObj);
+
objc = 0;
Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
- Tcl_GetCwd(interp, &pwdString);
-
for (i = 0; i < objc; i++) {
- char *string;
- int j, objc2, length;
- Tcl_Obj **objv2;
-
- string = Tcl_GetStringFromObj(objv[i], NULL);
+ Tcl_Obj *searchIn;
+
+ /*
+ * Construct the path from the element of pathPtr,
+ * joined with 'encoding'.
+ */
+ searchIn = Tcl_FSJoinToPath(objv[i],1,&encodingObj);
+ Tcl_IncrRefCount(searchIn);
Tcl_ResetResult(interp);
/*
*/
strcpy(globArgString, "*.enc");
- if ((Tcl_Chdir(string) == 0)
- && (Tcl_Chdir("encoding") == 0)
- && (TclGlob(interp, globArgString, NULL, 0, NULL) == TCL_OK)) {
- objc2 = 0;
+ /*
+ * The GLOBMODE_TAILS flag returns just the tail of each file
+ * which is the encoding name with a .enc extension
+ */
+ if ((TclGlob(interp, globArgString, searchIn,
+ TCL_GLOBMODE_TAILS, NULL) == TCL_OK)) {
+ int objc2 = 0;
+ Tcl_Obj **objv2;
+ int j;
Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
&objv2);
for (j = 0; j < objc2; j++) {
+ int length;
+ char *string;
string = Tcl_GetStringFromObj(objv2[j], &length);
length -= 4;
if (length > 0) {
}
}
}
- Tcl_Chdir(Tcl_DStringValue(&pwdString));
+ Tcl_DecrRefCount(searchIn);
}
- Tcl_DStringFree(&pwdString);
+ Tcl_DecrRefCount(encodingObj);
}
/*
*
* Tcl_ExternalToUtf --
*
- * Convert a source buffer from the specified encoding into UTF-8,
+ * Convert a source buffer from the specified encoding into UTF-8.
*
* Results:
* The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
CONST char *name;
{
- char *argv[3];
+ CONST char *argv[3];
Tcl_DString pathString;
- char *path;
+ CONST char *path;
Tcl_Channel chan;
+ Tcl_Obj *pathPtr;
- argv[0] = (char *) dir;
+ argv[0] = dir;
argv[1] = "encoding";
- argv[2] = (char *) name;
+ argv[2] = name;
Tcl_DStringInit(&pathString);
Tcl_JoinPath(3, argv, &pathString);
path = Tcl_DStringAppend(&pathString, ".enc", -1);
- chan = Tcl_OpenFileChannel(NULL, path, "r", 0);
+ pathPtr = Tcl_NewStringObj(path,-1);
+
+ Tcl_IncrRefCount(pathPtr);
+ chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0);
+ Tcl_DecrRefCount(pathPtr);
+
Tcl_DStringFree(&pathString);
return chan;
TableEncodingData *dataPtr;
unsigned short *pageMemPtr;
Tcl_EncodingType encType;
- char *hex;
+
+ /*
+ * Speed over memory. Use a full 256 character table to decode hex
+ * sequences in the encoding files.
+ */
+
static char staticHex[] = {
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0,
- 10, 11, 12, 13, 14, 15
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0 ... 15 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 16 ... 31 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 32 ... 47 */
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 48 ... 63 */
+ 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 64 ... 79 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 80 ... 95 */
+ 0, 10, 11, 12, 13, 14, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 96 ... 111 */
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, /* 112 ... 127 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 128 ... 143 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 144 ... 159 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 160 ... 175 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 176 ... 191 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 192 ... 207 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 208 ... 223 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 224 ... 239 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240 ... 255 */
};
- hex = staticHex - '0';
-
Tcl_DStringInit(&lineString);
Tcl_Gets(chan, &lineString);
line = Tcl_DStringValue(&lineString);
Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
p = Tcl_GetString(objPtr);
- hi = (hex[(int)p[0]] << 4) + hex[(int)p[1]];
+ hi = (staticHex[(unsigned int)p[0]] << 4) + staticHex[(unsigned int)p[1]];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
for (lo = 0; lo < 256; lo++) {
if ((lo & 0x0f) == 0) {
p++;
}
- ch = (hex[(int)p[0]] << 12) + (hex[(int)p[1]] << 8)
- + (hex[(int)p[2]] << 4) + hex[(int)p[3]];
+ ch = (staticHex[(unsigned int)p[0]] << 12) + (staticHex[(unsigned int)p[1]] << 8)
+ + (staticHex[(unsigned int)p[2]] << 4) + staticHex[(unsigned int)p[3]];
if (ch != 0) {
used[ch >> 8] = 1;
}
encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1;
encType.clientData = (ClientData) dataPtr;
return Tcl_CreateEncoding(&encType);
-
}
\f
/*
while (1) {
int argc;
- char **argv;
+ CONST char **argv;
char *line;
Tcl_DString lineString;
{
TableEncodingData *dataPtr;
+ /*
+ * Make sure we aren't freeing twice on shutdown. [Bug #219314]
+ */
+
dataPtr = (TableEncodingData *) clientData;
ckfree((char *) dataPtr->toUnicode);
ckfree((char *) dataPtr->fromUnicode);
dstStart = dst;
dstEnd = dst + dstLen - 1;
+ /*
+ * RFC1468 states that the text starts in ASCII, and switches to Japanese
+ * characters, and that the text must end in ASCII. [Patch #474358]
+ */
+
if (flags & TCL_ENCODING_START) {
- unsigned int len;
-
state = 0;
- len = dataPtr->subTables[0].sequenceLen;
- if (dst + dataPtr->initLen + len > dstEnd) {
+ if (dst + dataPtr->initLen > dstEnd) {
*srcReadPtr = 0;
*dstWrotePtr = 0;
return TCL_CONVERT_NOSPACE;
memcpy((VOID *) dst, (VOID *) dataPtr->init,
(size_t) dataPtr->initLen);
dst += dataPtr->initLen;
- memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence,
- (size_t) len);
- dst += len;
} else {
state = (int) *statePtr;
}
tablePrefixBytes = tableDataPtr->prefixBytes;
tableFromUnicode = tableDataPtr->fromUnicode;
- subTablePtr = &dataPtr->subTables[state];
- if (dst + subTablePtr->sequenceLen > dstEnd) {
- result = TCL_CONVERT_NOSPACE;
- break;
+ /*
+ * The state variable has the value of oldState when word is 0.
+ * In this case, the escape sequense should not be copied to dst
+ * because the current character set is not changed.
+ */
+ if (state != oldState) {
+ subTablePtr = &dataPtr->subTables[state];
+ if ((dst + subTablePtr->sequenceLen) > dstEnd) {
+ /*
+ * If there is no space to write the escape sequence, the
+ * state variable must be changed to the value of oldState
+ * variable because this escape sequence must be written
+ * in the next conversion.
+ */
+ state = oldState;
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ memcpy((VOID *) dst, (VOID *) subTablePtr->sequence,
+ (size_t) subTablePtr->sequenceLen);
+ dst += subTablePtr->sequenceLen;
}
- memcpy((VOID *) dst, (VOID *) subTablePtr->sequence,
- (size_t) subTablePtr->sequenceLen);
- dst += subTablePtr->sequenceLen;
}
if (tablePrefixBytes[(word >> 8)] != 0) {
}
if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
- if (dst + dataPtr->finalLen > dstEnd) {
+ unsigned int len = dataPtr->subTables[0].sequenceLen;
+ if (dst + dataPtr->finalLen + (state?len:0) > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
+ if (state) {
+ memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence,
+ (size_t) len);
+ dst += len;
+ }
memcpy((VOID *) dst, (VOID *) dataPtr->final,
(size_t) dataPtr->finalLen);
dst += dataPtr->finalLen;
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */
-/* CYGNUS LOCAL */
-#if defined(__CYGWIN__) && defined(__WIN32__)
-
-/* Under cygwin, the environment is imported from the cygwin DLL. */
-
-__declspec(dllimport) extern char **__cygwin_environ;
-
-#define environ (__cygwin_environ)
-
-/* We need to use a special putenv function to handle PATH. */
-#ifndef USE_PUTENV
-#define USE_PUTENV
-#endif
-#define putenv TclCygwin32Putenv
-#endif
-/* END CYGNUS LOCAL */
-
-#ifdef TCL_THREADS
-
-static Tcl_Mutex envMutex; /* To serialize access to environ */
-#endif
-
static int cacheSize = 0; /* Number of env strings in environCache. */
static char **environCache = NULL;
/* Array containing all of the environment
*/
static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, char *name1, char *name2,
- int flags));
+ Tcl_Interp *interp, CONST char *name1,
+ CONST char *name2, int flags));
static void ReplaceString _ANSI_ARGS_((CONST char *oldStr,
char *newStr));
void TclSetEnv _ANSI_ARGS_((CONST char *name,
CONST char *value));
void TclUnsetEnv _ANSI_ARGS_((CONST char *name));
-/* CYGNUS LOCAL */
#if defined (__CYGWIN__) && defined(__WIN32__)
-static void TclCygwin32Putenv _ANSI_ARGS_((CONST char *string));
+static void TclCygwinPutenv _ANSI_ARGS_((CONST char *string));
#endif
\f
/*
{
Tcl_DString envString;
int index, length, nameLength;
- char *p, *p2, *oldValue;
+ char *p, *oldValue;
+ CONST char *p2;
/*
* Figure out where the entry is going to go. If the name doesn't
newEnviron = (char **) ckalloc((unsigned)
((length + 5) * sizeof(char *)));
-
- /* CYGNUS LOCAL: Added to avoid an error from Purify,
- although I don't personally see where the error would
- occur--ian. */
- memset((VOID *) newEnviron, 0, (length+5) * sizeof(char *));
-
memcpy((VOID *) newEnviron, (VOID *) environ,
length*sizeof(char *));
if (environSize != 0) {
}
environ = newEnviron;
environSize = length + 5;
+#if defined(__APPLE__) && defined(__DYNAMIC__)
+ {
+ char ***e = _NSGetEnviron();
+ *e = environ;
+ }
+#endif
}
index = length;
environ[index + 1] = NULL;
oldValue = NULL;
nameLength = strlen(name);
} else {
- char *env;
+ CONST char *env;
/*
* Compare the new value to the existing value. If they're
if ((index != -1) && (environ[index] == p)) {
ReplaceString(oldValue, p);
+#ifdef HAVE_PUTENV_THAT_COPIES
+ } else {
+ /* This putenv() copies instead of taking ownership */
+ ckfree(p);
+#endif
}
Tcl_MutexUnlock(&envMutex);
+
+ if (!strcmp(name, "HOME")) {
+ /*
+ * If the user's home directory has changed, we must invalidate
+ * the filesystem cache, because '~' expansions will now be
+ * incorrect.
+ */
+ Tcl_FSMountsChanged(NULL);
+ }
}
\f
/*
* form NAME=value. (native) */
{
Tcl_DString nameString;
- int nameLength;
- char *name, *value;
+ CONST char *name;
+ char *value;
if (string == NULL) {
return 0;
name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString);
value = strchr(name, '=');
- if (value == NULL) {
- return 0;
- }
- nameLength = value - name;
- if (nameLength == 0) {
- return 0;
+
+ if ((value != NULL) && (value != name)) {
+ value[0] = '\0';
+ TclSetEnv(name, value+1);
}
- value[0] = '\0';
- TclSetEnv(name, value+1);
Tcl_DStringFree(&nameString);
return 0;
}
CONST char *name; /* Name of variable to remove (UTF-8). */
{
char *oldValue;
- unsigned int length;
+ int length;
int index;
#ifdef USE_PUTENV
Tcl_DString envString;
*----------------------------------------------------------------------
*/
-char *
+CONST char *
TclGetEnv(name, valuePtr)
CONST char *name; /* Name of environment variable to find
* (UTF-8). */
* stored. */
{
int length, index;
- char *result;
+ CONST char *result;
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter whose "env" variable is
* being modified. */
- char *name1; /* Better be "env". */
- char *name2; /* Name of variable being modified, or NULL
+ CONST char *name1; /* Better be "env". */
+ CONST char *name2; /* Name of variable being modified, or NULL
* if whole array is being deleted (UTF-8). */
int flags; /* Indicates what's happening. */
{
*/
if (flags & TCL_TRACE_WRITES) {
- char *value;
+ CONST char *value;
value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
TclSetEnv(name2, value);
if (flags & TCL_TRACE_READS) {
Tcl_DString valueString;
- char *value;
+ CONST char *value;
value = TclGetEnv(name2, &valueString);
if (value == NULL) {
ckfree((char *) environCache);
}
environCache = newCache;
- environCache[cacheSize] = (char *) newStr;
+ environCache[cacheSize] = newStr;
environCache[cacheSize+1] = NULL;
cacheSize += 5;
}
}
}
\f
-/* CYGNUS LOCAL */
#if defined(__CYGWIN__) && defined(__WIN32__)
-#include "windows.h"
+#include <windows.h>
-/* When using cygwin, when an environment variable changes, we need
- to synch with both the cygwin environment (in case the
- application C code calls fork) and the Windows environment (in case
- the application TCL code calls exec, which calls the Windows
- CreateProcess function). */
+/*
+ * When using cygwin, when an environment variable changes, we need to synch
+ * with both the cygwin environment (in case the application C code calls
+ * fork) and the Windows environment (in case the application TCL code calls
+ * exec, which calls the Windows CreateProcess function).
+ */
static void
-TclCygwin32Putenv(str)
- const char *str;
+TclCygwinPutenv(str)
+ const char *str;
{
- char *name, *value;
-
- /* Get the name and value, so that we can change the environment
- variable for Windows. */
- name = (char *) alloca (strlen (str) + 1);
- strcpy (name, str);
- for (value = name; *value != '=' && *value != '\0'; ++value)
- ;
- if (*value == '\0')
- {
- /* Can't happen. */
- return;
+ char *name, *value;
+
+ /* Get the name and value, so that we can change the environment
+ variable for Windows. */
+ name = (char *) alloca (strlen (str) + 1);
+ strcpy (name, str);
+ for (value = name; *value != '=' && *value != '\0'; ++value)
+ ;
+ if (*value == '\0') {
+ /* Can't happen. */
+ return;
+ }
+ *value = '\0';
+ ++value;
+ if (*value == '\0') {
+ value = NULL;
}
- *value = '\0';
- ++value;
- if (*value == '\0')
- value = NULL;
- /* Set the cygwin environment variable. */
+ /* Set the cygwin environment variable. */
#undef putenv
- if (value == NULL)
- unsetenv (name);
- else
- putenv(str);
-
- /* Before changing the environment variable in Windows, if this is
- PATH, we need to convert the value back to a Windows style path.
-
- FIXME: The calling program may now it is running under windows,
- and may have set the path to a Windows path, or, worse, appended
- or prepended a Windows path to PATH. */
- if (strcmp (name, "PATH") != 0)
- {
- /* If this is Path, eliminate any PATH variable, to prevent any
- confusion. */
- if (strcmp (name, "Path") == 0)
- {
- SetEnvironmentVariable ("PATH", (char *) NULL);
- unsetenv ("PATH");
+ if (value == NULL) {
+ unsetenv (name);
+ } else {
+ putenv(str);
+ }
+
+ /*
+ * Before changing the environment variable in Windows, if this is PATH,
+ * we need to convert the value back to a Windows style path.
+ *
+ * FIXME: The calling program may know it is running under windows, and
+ * may have set the path to a Windows path, or, worse, appended or
+ * prepended a Windows path to PATH.
+ */
+ if (strcmp (name, "PATH") != 0) {
+ /* If this is Path, eliminate any PATH variable, to prevent any
+ confusion. */
+ if (strcmp (name, "Path") == 0) {
+ SetEnvironmentVariable ("PATH", (char *) NULL);
+ unsetenv ("PATH");
}
- SetEnvironmentVariable (name, value);
- }
- else
- {
- char *buf;
-
- /* Eliminate any Path variable, to prevent any confusion. */
- SetEnvironmentVariable ("Path", (char *) NULL);
- unsetenv ("Path");
-
- if (value == NULL)
- buf = NULL;
- else
- {
- int size;
-
- size = cygwin_posix_to_win32_path_list_buf_size (value);
- buf = (char *) alloca (size + 1);
- cygwin_posix_to_win32_path_list (value, buf);
+ SetEnvironmentVariable (name, value);
+ } else {
+ char *buf;
+
+ /* Eliminate any Path variable, to prevent any confusion. */
+ SetEnvironmentVariable ("Path", (char *) NULL);
+ unsetenv ("Path");
+
+ if (value == NULL) {
+ buf = NULL;
+ } else {
+ int size;
+
+ size = cygwin_posix_to_win32_path_list_buf_size (value);
+ buf = (char *) alloca (size + 1);
+ cygwin_posix_to_win32_path_list (value, buf);
}
- SetEnvironmentVariable (name, buf);
+ SetEnvironmentVariable (name, buf);
}
}
-#endif /* __CYGWIN__ */
-/* END CYGNUS LOCAL */
-
+#endif /* __CYGWIN__ && __WIN32__ */
static Tcl_ThreadDataKey dataKey;
/*
+ * Common string for the library path for sharing across threads.
+ */
+char *tclLibraryPathStr;
+
+/*
* Prototypes for procedures referenced only in this file:
*/
Tcl_Interp *interp));
static void HandleBgErrors _ANSI_ARGS_((ClientData clientData));
static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, char *name1, char *name2,
- int flags));
+ Tcl_Interp *interp, CONST char *name1,
+ CONST char *name2, int flags));
\f
/*
*----------------------------------------------------------------------
* occurred. */
{
BgError *errPtr;
- char *errResult, *varValue;
+ CONST char *errResult, *varValue;
ErrAssocData *assocPtr;
int length;
ClientData clientData; /* Pointer to ErrAssocData structure. */
{
Tcl_Interp *interp;
- char *argv[2];
+ CONST char *argv[2];
int code;
BgError *errPtr;
ErrAssocData *assocPtr = (ErrAssocData *) clientData;
int len;
string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
- if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) {
+ if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) {
Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
Tcl_WriteChars(errChannel, "\n", -1);
} else {
Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
}
tsdPtr->tclLibraryPath = pathPtr;
+
+ /*
+ * No mutex locking is needed here as up the stack we're within
+ * TclpInitLock().
+ */
+ tclLibraryPathStr = Tcl_GetStringFromObj(pathPtr, NULL);
}
\f
/*
TclGetLibraryPath()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (tsdPtr->tclLibraryPath == NULL) {
+ /*
+ * Grab the shared string and place it into a new thread specific
+ * Tcl_Obj.
+ */
+ tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1);
+
+ /* take ownership */
+ Tcl_IncrRefCount(tsdPtr->tclLibraryPath);
+ }
return tsdPtr->tclLibraryPath;
}
\f
ThreadSpecificData *tsdPtr;
TclpInitLock();
- tsdPtr = TCL_TSD_INIT(&dataKey);
if (subsystemsInitialized != 0) {
subsystemsInitialized = 0;
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+
/*
* Invoke exit handlers first.
*/
Tcl_MutexUnlock(&exitMutex);
/*
- * Clean up the library path now, before we invalidate thread-local
- * storage.
- */
- if (tsdPtr->tclLibraryPath != NULL) {
- Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
- tsdPtr->tclLibraryPath = NULL;
- }
-
- /*
* Clean up after the current thread now, after exit handlers.
* In particular, the testexithandler command sets up something
* that writes to standard output, which gets closed.
TclFinalizeSynchronization();
- /*
- * We defer unloading of packages until very late
- * to avoid memory access issues. Both exit callbacks and
- * synchronization variables may be stored in packages.
+ /**
+ * Finalizing the filesystem must come after anything which
+ * might conceivably interact with the 'Tcl_FS' API. This
+ * will also unload any extensions which have been loaded.
*/
-
- TclFinalizeLoad();
+ TclFinalizeFilesystem();
/*
* There shouldn't be any malloc'ed memory after this.
*/
tsdPtr->inExit = 1;
+
+ /*
+ * Clean up the library path now, before we invalidate thread-local
+ * storage or calling thread exit handlers.
+ */
+
+ if (tsdPtr->tclLibraryPath != NULL) {
+ Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
+ tsdPtr->tclLibraryPath = NULL;
+ }
+
for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
exitPtr = tsdPtr->firstExitPtr) {
/*
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
+ TclFinalizeAsync();
/*
* Blow away all thread local storage blocks.
int
TclInExit()
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- return tsdPtr->inExit;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ TclThreadDataKeyGet(&dataKey);
+ if (tsdPtr == NULL) {
+ return inFinalize;
+ } else {
+ return tsdPtr->inExit;
+ }
}
\f
/*
VwaitVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
- char *name1; /* Name of variable. */
- char *name2; /* Second part of variable name. */
+ CONST char *name1; /* Name of variable. */
+ CONST char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
{
int *donePtr = (int *) clientData;
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
- static char *updateOptions[] = {"idletasks", (char *) NULL};
+ static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
enum updateOptions {REGEXP_IDLETASKS};
if (objc == 1) {
Tcl_ResetResult(interp);
return TCL_OK;
}
-
* commands.
*
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#include "tclInt.h"
#include "tclCompile.h"
-#ifdef NO_FLOAT_H
-# include "../compat/float.h"
-#else
-# include <float.h>
-#endif
#ifndef TCL_NO_MATH
-#include "tclMath.h"
+# include "tclMath.h"
#endif
/*
*/
#ifndef TCL_GENERIC_ONLY
-#include "tclPort.h"
-#else
-#define NO_ERRNO_H
-#endif
+# include "tclPort.h"
+#else /* TCL_GENERIC_ONLY */
+# ifndef NO_FLOAT_H
+# include <float.h>
+# else /* NO_FLOAT_H */
+# ifndef NO_VALUES_H
+# include <values.h>
+# endif /* !NO_VALUES_H */
+# endif /* !NO_FLOAT_H */
+# define NO_ERRNO_H
+#endif /* !TCL_GENERIC_ONLY */
#ifdef NO_ERRNO_H
int errno;
-#define EDOM 33
-#define ERANGE 34
+# define EDOM 33
+# define ERANGE 34
#endif
/*
+ * Need DBL_MAX for IS_INF() macro...
+ */
+#ifndef DBL_MAX
+# ifdef MAXDOUBLE
+# define DBL_MAX MAXDOUBLE
+# else /* !MAXDOUBLE */
+/*
+ * This value is from the Solaris headers, but doubles seem to be the
+ * same size everywhere. Long doubles aren't, but we don't use those.
+ */
+# define DBL_MAX 1.79769313486231570e+308
+# endif /* MAXDOUBLE */
+#endif /* !DBL_MAX */
+
+/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
* initialized.
*/
static int execInitialized = 0;
TCL_DECLARE_MUTEX(execMutex)
+#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether execution tracing is enabled and, if so,
* what level of tracing is desired:
*/
int tclTraceExec = 0;
-
-typedef struct ThreadSpecificData {
- /*
- * The following global variable is use to signal matherr that Tcl
- * is responsible for the arithmetic, so errors can be handled in a
- * fashion appropriate for Tcl. Zero means no Tcl math is in
- * progress; non-zero means Tcl is doing math.
- */
-
- int mathInProgress;
-
-} ThreadSpecificData;
-
-static Tcl_ThreadDataKey dataKey;
-
-/*
- * The variable below serves no useful purpose except to generate
- * a reference to matherr, so that the Tcl version of matherr is
- * linked in rather than the system version. Without this reference
- * the need for matherr won't be discovered during linking until after
- * libtcl.a has been processed, so Tcl's version won't be used.
- */
-
-#ifdef NEED_MATHERR
-extern int matherr();
-int (*tclMatherrPtr)() = matherr;
#endif
/*
static char *operatorStrings[] = {
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!",
- "BUILTIN FUNCTION", "FUNCTION"
+ "BUILTIN FUNCTION", "FUNCTION",
+ "", "", "", "", "", "", "", "", "eq", "ne",
};
-
+
/*
* Mapping from Tcl result codes to strings; used for error and debugging
* messages.
#endif
/*
+ * These are used by evalstats to monitor object usage in Tcl.
+ */
+
+#ifdef TCL_COMPILE_STATS
+long tclObjsAlloced = 0;
+long tclObjsFreed = 0;
+#define TCL_MAX_SHARED_OBJ_STATS 5
+long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
+#endif /* TCL_COMPILE_STATS */
+
+/*
* Macros for testing floating-point values for certain special cases. Test
* for not-a-number by comparing a value against itself; test for infinity
* by comparing against the largest floating-point value.
*/
#define IS_NAN(v) ((v) != (v))
-#ifdef DBL_MAX
-# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
-#else
-# define IS_INF(v) 0
-#endif
+#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
/*
- * Macro to adjust the program counter and restart the instruction execution
- * loop after each instruction is executed.
+ * The new macro for ending an instruction; note that a
+ * reasonable C-optimiser will resolve all branches
+ * at compile time. (result) is always a constant; the macro
+ * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
+ * resolved at runtime for variable (nCleanup).
+ *
+ * ARGUMENTS:
+ * pcAdjustment: how much to increment pc
+ * nCleanup: how many objects to remove from the stack
+ * result: 0 indicates no object should be pushed on the
+ * stack; otherwise, push objResultPtr. If (result < 0),
+ * objResultPtr already has the correct reference count.
*/
-#define ADJUST_PC(instBytes) \
- pc += (instBytes); \
- continue
+#define NEXT_INST_F(pcAdjustment, nCleanup, result) \
+ if (nCleanup == 0) {\
+ if (result != 0) {\
+ if ((result) > 0) {\
+ PUSH_OBJECT(objResultPtr);\
+ } else {\
+ stackPtr[++stackTop] = objResultPtr;\
+ }\
+ } \
+ pc += (pcAdjustment);\
+ goto cleanup0;\
+ } else if (result != 0) {\
+ if ((result) > 0) {\
+ Tcl_IncrRefCount(objResultPtr);\
+ }\
+ pc += (pcAdjustment);\
+ switch (nCleanup) {\
+ case 1: goto cleanup1_pushObjResultPtr;\
+ case 2: goto cleanup2_pushObjResultPtr;\
+ default: panic("ERROR: bad usage of macro NEXT_INST_F");\
+ }\
+ } else {\
+ pc += (pcAdjustment);\
+ switch (nCleanup) {\
+ case 1: goto cleanup1;\
+ case 2: goto cleanup2;\
+ default: panic("ERROR: bad usage of macro NEXT_INST_F");\
+ }\
+ }
+
+#define NEXT_INST_V(pcAdjustment, nCleanup, result) \
+ pc += (pcAdjustment);\
+ cleanup = (nCleanup);\
+ if (result) {\
+ if ((result) > 0) {\
+ Tcl_IncrRefCount(objResultPtr);\
+ }\
+ goto cleanupV_pushObjResultPtr;\
+ } else {\
+ goto cleanupV;\
+ }
+
/*
* Macros used to cache often-referenced Tcl evaluation stack information
#define DECACHE_STACK_INFO() \
eePtr->stackTop = stackTop
+
/*
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
* increments the object's ref count since it makes the stack have another
*/
#ifdef TCL_COMPILE_DEBUG
-#define TRACE(a) \
+# define TRACE(a) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
}
-#define TRACE_WITH_OBJ(a, objPtr) \
+# define TRACE_APPEND(a) \
+ if (traceInstructions) { \
+ printf a; \
+ }
+# define TRACE_WITH_OBJ(a, objPtr) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
- TclPrintObject(stdout, (objPtr), 30); \
+ TclPrintObject(stdout, objPtr, 30); \
fprintf(stdout, "\n"); \
}
-#define O2S(objPtr) \
- Tcl_GetString(objPtr)
-#else
-#define TRACE(a)
-#define TRACE_WITH_OBJ(a, objPtr)
-#define O2S(objPtr)
+# define O2S(objPtr) \
+ (objPtr ? TclGetString(objPtr) : "")
+#else /* !TCL_COMPILE_DEBUG */
+# define TRACE(a)
+# define TRACE_APPEND(a)
+# define TRACE_WITH_OBJ(a, objPtr)
+# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ * Most of the code to support working with wide values is factored
+ * out here because it greatly reduces the number of conditionals
+ * through the rest of the file. Note that this needs to be
+ * conditional because we do not want to alter Tcl's behaviour on
+ * native-64bit platforms...
+ */
+
+#ifndef TCL_WIDE_INT_IS_LONG
+#define W0 Tcl_LongAsWide(0)
+
+/*
+ * Macro to read a string containing either a wide or an int and
+ * decide which it is while decoding it at the same time. This
+ * enforces the policy that integer constants between LONG_MIN and
+ * LONG_MAX (inclusive) are represented by normal longs, and integer
+ * constants outside that range are represented by wide ints.
+ *
+ * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
+ * generates an error message.
+ */
+#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
+ (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \
+ if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
+ && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
+ (objPtr)->typePtr = &tclIntType; \
+ (objPtr)->internalRep.longValue = (longVar) \
+ = Tcl_WideAsLong(wideVar); \
+ }
+#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
+ (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \
+ &(wideVar)); \
+ if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
+ && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
+ (objPtr)->typePtr = &tclIntType; \
+ (objPtr)->internalRep.longValue = (longVar) \
+ = Tcl_WideAsLong(wideVar); \
+ }
+#define IS_INTEGER_TYPE(typePtr) \
+ ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
+/*
+ * Extract a double value from a general numeric object.
+ */
+#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
+ if ((typePtr) == &tclIntType) { \
+ (doubleVar) = (double) (objPtr)->internalRep.longValue; \
+ } else if ((typePtr) == &tclWideIntType) { \
+ (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
+ } else { \
+ (doubleVar) = (objPtr)->internalRep.doubleValue; \
+ }
+/*
+ * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
+ * an obj.
+ */
+#define FORCE_LONG(objPtr, longVar, wideVar) \
+ if ((objPtr)->typePtr == &tclWideIntType) { \
+ (longVar) = Tcl_WideAsLong(wideVar); \
+ }
+/*
+ * For tracing that uses wide values.
+ */
+#define LLTRACE(a) TRACE(a)
+#define LLTRACE_WITH_OBJ(a,b) TRACE_WITH_OBJ(a,b)
+#define LLD "%" TCL_LL_MODIFIER "d"
+#else /* TCL_WIDE_INT_IS_LONG */
+/*
+ * Versions of the above that do not use wide values.
+ */
+#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
+ (resultVar) = Tcl_GetLongFromObj(interp, (objPtr), &(longVar));
+#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
+ (resultVar) = Tcl_GetLongFromObj((Tcl_Interp *) NULL, (objPtr), \
+ &(longVar));
+#define IS_INTEGER_TYPE(typePtr) ((typePtr) == &tclIntType)
+#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
+ if ((typePtr) == &tclIntType) { \
+ (doubleVar) = (double) (objPtr)->internalRep.longValue; \
+ } else { \
+ (doubleVar) = (objPtr)->internalRep.doubleValue; \
+ }
+#define FORCE_LONG(objPtr, longVar, wideVar)
+#define LLTRACE(a)
+#define LLTRACE_WITH_OBJ(a,b)
+#endif /* TCL_WIDE_INT_IS_LONG */
+#define IS_NUMERIC_TYPE(typePtr) \
+ (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
+
/*
* Declarations for local procedures to this file:
*/
-static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
- Trace *tracePtr, Command *cmdPtr,
- char *command, int numChars,
- int objc, Tcl_Obj *objv[]));
-static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- Tcl_Obj *copyPtr));
+static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
+ ByteCode *codePtr));
static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
+#ifndef TCL_WIDE_INT_IS_LONG
+static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
+ ExecEnv *eePtr, ClientData clientData));
+#endif /* TCL_WIDE_INT_IS_LONG */
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-#endif
-static void FreeCmdNameInternalRep _ANSI_ARGS_((
- Tcl_Obj *objPtr));
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
-#endif
+#endif /* TCL_COMPILE_DEBUG */
static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
int catchOnly, ByteCode* codePtr));
static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
Tcl_Interp *interp));
#ifdef TCL_COMPILE_DEBUG
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
-#endif
-static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
-#ifdef TCL_COMPILE_DEBUG
static char * StringForResultCode _ANSI_ARGS_((int result));
static void ValidatePcAndStackTop _ANSI_ARGS_((
ByteCode *codePtr, unsigned char *pc,
- int stackTop, int stackLowerBound,
- int stackUpperBound));
-#endif
+ int stackTop, int stackLowerBound));
+#endif /* TCL_COMPILE_DEBUG */
static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
* operand byte.
*/
-BuiltinFunc builtinFuncTable[] = {
+BuiltinFunc tclBuiltinFuncTable[] = {
#ifndef TCL_NO_MATH
{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
+#ifdef TCL_WIDE_INT_IS_LONG
+ {"wide", 1, {TCL_EITHER}, ExprIntFunc, 0},
+#else
+ {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
+#endif /* TCL_WIDE_INT_IS_LONG */
{0},
};
-
-/*
- * The structure below defines the command name Tcl object type by means of
- * procedures that can be invoked by generic object code. Objects of this
- * type cache the Command pointer that results from looking up command names
- * in the command hashtable. Such objects appear as the zeroth ("command
- * name") argument in a Tcl command.
- */
-
-Tcl_ObjType tclCmdNameType = {
- "cmdName", /* name */
- FreeCmdNameInternalRep, /* freeIntRepProc */
- DupCmdNameInternalRep, /* dupIntRepProc */
- (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
- SetCmdNameFromAny /* setFromAnyProc */
-};
\f
/*
*----------------------------------------------------------------------
* This procedure initializes the array of instruction names. If
* compiling with the TCL_COMPILE_STATS flag, it initializes the
* array that counts the executions of each instruction and it
- * creates the "evalstats" command. It also registers the command name
- * Tcl_ObjType. It also establishes the link between the Tcl
- * "tcl_traceExec" and C "tclTraceExec" variables.
+ * creates the "evalstats" command. It also establishes the link
+ * between the Tcl "tcl_traceExec" and C "tclTraceExec" variables.
*
*----------------------------------------------------------------------
*/
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
- Tcl_RegisterObjType(&tclCmdNameType);
+#ifdef TCL_COMPILE_DEBUG
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
-
+#endif
#ifdef TCL_COMPILE_STATS
- Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
- (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
}
\f
* environment is being created. */
{
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
+ Tcl_Obj **stackPtr;
+
+ stackPtr = (Tcl_Obj **)
+ ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
+
+ /*
+ * Use the bottom pointer to keep a reference count; the
+ * execution environment holds a reference.
+ */
+
+ stackPtr++;
+ eePtr->stackPtr = stackPtr;
+ stackPtr[-1] = (Tcl_Obj *) ((char *) 1);
- eePtr->stackPtr = (Tcl_Obj **)
- ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
eePtr->stackTop = -1;
- eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
+ eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);
+
+ eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
+ Tcl_IncrRefCount(eePtr->errorInfo);
+
+ eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
+ Tcl_IncrRefCount(eePtr->errorCode);
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
TclDeleteExecEnv(eePtr)
ExecEnv *eePtr; /* Execution environment to free. */
{
- ckfree((char *) eePtr->stackPtr);
+ if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
+ ckfree((char *) (eePtr->stackPtr-1));
+ } else {
+ panic("ERROR: freeing an execEnv whose stack is still in use.\n");
+ }
+ TclDecrRefCount(eePtr->errorInfo);
+ TclDecrRefCount(eePtr->errorCode);
ckfree((char *) eePtr);
}
\f
int currBytes = currElems * sizeof(Tcl_Obj *);
int newBytes = 2*currBytes;
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
+ Tcl_Obj **oldStackPtr = eePtr->stackPtr;
+
+ /*
+ * We keep the stack reference count as a (char *), as that
+ * works nicely as a portable pointer-sized counter.
+ */
+
+ char *refCount = (char *) oldStackPtr[-1];
/*
* Copy the existing stack items to the new stack space, free the old
- * storage if appropriate, and mark new space as malloc'ed.
+ * storage if appropriate, and record the refCount of the new stack
+ * held by the environment.
*/
- memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
+ newStackPtr++;
+ memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
(size_t) currBytes);
- ckfree((char *) eePtr->stackPtr);
+
+ if (refCount == (char *) 1) {
+ ckfree((VOID *) (oldStackPtr-1));
+ } else {
+ /*
+ * Remove the reference corresponding to the
+ * environment pointer.
+ */
+
+ oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
+ }
+
eePtr->stackPtr = newStackPtr;
- eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
+ eePtr->stackEnd = (newElems - 2); /* index of last usable item */
+ newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_ExprObj --
+ *
+ * Evaluate an expression in a Tcl_Obj.
+ *
+ * Results:
+ * A standard Tcl object result. If the result is other than TCL_OK,
+ * then the interpreter's result contains an error message. If the
+ * result is TCL_OK, then a pointer to the expression's result value
+ * object is stored in resultPtrPtr. In that case, the object's ref
+ * count is incremented to reflect the reference returned to the
+ * caller; the caller is then responsible for the resulting object
+ * and must, for example, decrement the ref count when it is finished
+ * with the object.
+ *
+ * Side effects:
+ * Any side effects caused by subcommands in the expression, if any.
+ * The interpreter result is not modified unless there is an error.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_ExprObj(interp, objPtr, resultPtrPtr)
+ Tcl_Interp *interp; /* Context in which to evaluate the
+ * expression. */
+ register Tcl_Obj *objPtr; /* Points to Tcl object containing
+ * expression to evaluate. */
+ Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
+ * result is stored if no errors occur. */
+{
+ Interp *iPtr = (Interp *) interp;
+ CompileEnv compEnv; /* Compilation environment structure
+ * allocated in frame. */
+ LiteralTable *localTablePtr = &(compEnv.localLitTable);
+ register ByteCode *codePtr = NULL;
+ /* Tcl Internal type of bytecode.
+ * Initialized to avoid compiler warning. */
+ AuxData *auxDataPtr;
+ LiteralEntry *entryPtr;
+ Tcl_Obj *saveObjPtr;
+ char *string;
+ int length, i, result;
+
+ /*
+ * First handle some common expressions specially.
+ */
+
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ if (length == 1) {
+ if (*string == '0') {
+ *resultPtrPtr = Tcl_NewLongObj(0);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ } else if (*string == '1') {
+ *resultPtrPtr = Tcl_NewLongObj(1);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ }
+ } else if ((length == 2) && (*string == '!')) {
+ if (*(string+1) == '0') {
+ *resultPtrPtr = Tcl_NewLongObj(1);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ } else if (*(string+1) == '1') {
+ *resultPtrPtr = Tcl_NewLongObj(0);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * Get the ByteCode from the object. If it exists, make sure it hasn't
+ * been invalidated by, e.g., someone redefining a command with a
+ * compile procedure (this might make the compiled code wrong). If
+ * necessary, convert the object to be a ByteCode object and compile it.
+ * Also, if the code was compiled in/for a different interpreter, we
+ * recompile it.
+ *
+ * Precompiled expressions, however, are immutable and therefore
+ * they are not recompiled, even if the epoch has changed.
+ *
+ */
+
+ if (objPtr->typePtr == &tclByteCodeType) {
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if (((Interp *) *codePtr->interpHandle != iPtr)
+ || (codePtr->compileEpoch != iPtr->compileEpoch)) {
+ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
+ if ((Interp *) *codePtr->interpHandle != iPtr) {
+ panic("Tcl_ExprObj: compiled expression jumped interps");
+ }
+ codePtr->compileEpoch = iPtr->compileEpoch;
+ } else {
+ (*tclByteCodeType.freeIntRepProc)(objPtr);
+ objPtr->typePtr = (Tcl_ObjType *) NULL;
+ }
+ }
+ }
+ if (objPtr->typePtr != &tclByteCodeType) {
+ TclInitCompileEnv(interp, &compEnv, string, length);
+ result = TclCompileExpr(interp, string, length, &compEnv);
+
+ /*
+ * Free the compilation environment's literal table bucket array if
+ * it was dynamically allocated.
+ */
+
+ if (localTablePtr->buckets != localTablePtr->staticBuckets) {
+ ckfree((char *) localTablePtr->buckets);
+ }
+
+ if (result != TCL_OK) {
+ /*
+ * Compilation errors. Free storage allocated for compilation.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyLocalLiteralTable(&compEnv);
+#endif /*TCL_COMPILE_DEBUG*/
+ entryPtr = compEnv.literalArrayPtr;
+ for (i = 0; i < compEnv.literalArrayNext; i++) {
+ TclReleaseLiteral(interp, entryPtr->objPtr);
+ entryPtr++;
+ }
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyGlobalLiteralTable(iPtr);
+#endif /*TCL_COMPILE_DEBUG*/
+
+ auxDataPtr = compEnv.auxDataArrayPtr;
+ for (i = 0; i < compEnv.auxDataArrayNext; i++) {
+ if (auxDataPtr->type->freeProc != NULL) {
+ auxDataPtr->type->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+ TclFreeCompileEnv(&compEnv);
+ return result;
+ }
+
+ /*
+ * Successful compilation. If the expression yielded no
+ * instructions, push an zero object as the expression's result.
+ */
+
+ if (compEnv.codeNext == compEnv.codeStart) {
+ TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
+ &compEnv);
+ }
+
+ /*
+ * Add a "done" instruction as the last instruction and change the
+ * object into a ByteCode object. Ownership of the literal objects
+ * and aux data items is given to the ByteCode object.
+ */
+
+ compEnv.numSrcBytes = iPtr->termOffset;
+ TclEmitOpcode(INST_DONE, &compEnv);
+ TclInitByteCodeObj(objPtr, &compEnv);
+ TclFreeCompileEnv(&compEnv);
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceCompile == 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+ }
+
+ /*
+ * Execute the expression after first saving the interpreter's result.
+ */
+
+ saveObjPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(saveObjPtr);
+ Tcl_ResetResult(interp);
+
+ /*
+ * Increment the code's ref count while it is being executed. If
+ * afterwards no references to it remain, free the code.
+ */
+
+ codePtr->refCount++;
+ result = TclExecuteByteCode(interp, codePtr);
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
+ }
+
+ /*
+ * If the expression evaluated successfully, store a pointer to its
+ * value object in resultPtrPtr then restore the old interpreter result.
+ * We increment the object's ref count to reflect the reference that we
+ * are returning to the caller. We also decrement the ref count of the
+ * interpreter's result object after calling Tcl_SetResult since we
+ * next store into that field directly.
+ */
+
+ if (result == TCL_OK) {
+ *resultPtrPtr = iPtr->objResultPtr;
+ Tcl_IncrRefCount(iPtr->objResultPtr);
+
+ Tcl_SetObjResult(interp, saveObjPtr);
+ }
+ TclDecrRefCount(saveObjPtr);
+ return result;
}
\f
/*
*----------------------------------------------------------------------
*
- * TclExecuteByteCode --
+ * TclCompEvalObj --
*
- * This procedure executes the instructions of a ByteCode structure.
- * It returns when a "done" instruction is executed or an error occurs.
+ * This procedure evaluates the script contained in a Tcl_Obj by
+ * first compiling it and then passing it to TclExecuteByteCode.
*
* Results:
* The return value is one of the return codes defined in tcl.h
*/
int
-TclExecuteByteCode(interp, codePtr)
- Tcl_Interp *interp; /* Token for command interpreter. */
- ByteCode *codePtr; /* The bytecode sequence to interpret. */
+TclCompEvalObj(interp, objPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj *objPtr;
{
- Interp *iPtr = (Interp *) interp;
- ExecEnv *eePtr = iPtr->execEnvPtr;
- /* Points to the execution environment. */
- register Tcl_Obj **stackPtr = eePtr->stackPtr;
- /* Cached evaluation stack base pointer. */
- register int stackTop = eePtr->stackTop;
- /* Cached top index of evaluation stack. */
- register unsigned char *pc = codePtr->codeStart;
- /* The current program counter. */
- int opnd; /* Current instruction's operand byte. */
- int pcAdjustment; /* Hold pc adjustment after instruction. */
- int initStackTop = stackTop;/* Stack top at start of execution. */
- ExceptionRange *rangePtr; /* Points to closest loop or catch exception
- * range enclosing the pc. Used by various
- * instructions and processCatch to
- * process break, continue, and errors. */
- int result = TCL_OK; /* Return code returned after execution. */
- int traceInstructions = (tclTraceExec == 3);
- Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
- char *bytes;
- int length;
- long i;
+ register Interp *iPtr = (Interp *) interp;
+ register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
+ int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
+ * at all were executed. */
+ char *script;
+ int numSrcBytes;
+ int result;
+ Namespace *namespacePtr;
+
/*
- * This procedure uses a stack to hold information about catch commands.
- * This information is the current operand stack top when starting to
- * execute the code for each catch command. It starts out with stack-
- * allocated space but uses dynamically-allocated storage if needed.
+ * Check that the interpreter is ready to execute scripts
*/
-#define STATIC_CATCH_STACK_SIZE 4
- int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
- int *catchStackPtr = catchStackStorage;
- int catchTop = -1;
+ if (TclInterpReady(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
-#ifdef TCL_COMPILE_DEBUG
- if (tclTraceExec >= 2) {
- PrintByteCodeInfo(codePtr);
- fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
- fflush(stdout);
+ if (iPtr->varFramePtr != NULL) {
+ namespacePtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ namespacePtr = iPtr->globalNsPtr;
}
-#endif
-
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.numExecutions++;
-#endif
- /*
- * Make sure the catch stack is large enough to hold the maximum number
- * of catch commands that could ever be executing at the same time. This
- * will be no more than the exception range array's depth.
+ /*
+ * If the object is not already of tclByteCodeType, compile it (and
+ * reset the compilation flags in the interpreter; this should be
+ * done after any compilation).
+ * Otherwise, check that it is "fresh" enough.
*/
- if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
- catchStackPtr = (int *)
- ckalloc(codePtr->maxExceptDepth * sizeof(int));
+ if (objPtr->typePtr != &tclByteCodeType) {
+ recompileObj:
+ iPtr->errorLine = 1;
+ result = tclByteCodeType.setFromAnyProc(interp, objPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ iPtr->evalFlags = 0;
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ } else {
+ /*
+ * Make sure the Bytecode hasn't been invalidated by, e.g., someone
+ * redefining a command with a compile procedure (this might make the
+ * compiled code wrong).
+ * The object needs to be recompiled if it was compiled in/for a
+ * different interpreter, or for a different namespace, or for the
+ * same namespace but with different name resolution rules.
+ * Precompiled objects, however, are immutable and therefore
+ * they are not recompiled, even if the epoch has changed.
+ *
+ * To be pedantically correct, we should also check that the
+ * originating procPtr is the same as the current context procPtr
+ * (assuming one exists at all - none for global level). This
+ * code is #def'ed out because [info body] was changed to never
+ * return a bytecode type object, which should obviate us from
+ * the extra checks here.
+ */
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if (((Interp *) *codePtr->interpHandle != iPtr)
+ || (codePtr->compileEpoch != iPtr->compileEpoch)
+#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
+ || (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
+ iPtr->varFramePtr->procPtr == codePtr->procPtr))
+#endif
+ || (codePtr->nsPtr != namespacePtr)
+ || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
+ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
+ if ((Interp *) *codePtr->interpHandle != iPtr) {
+ panic("Tcl_EvalObj: compiled script jumped interps");
+ }
+ codePtr->compileEpoch = iPtr->compileEpoch;
+ } else {
+ /*
+ * This byteCode is invalid: free it and recompile
+ */
+ tclByteCodeType.freeIntRepProc(objPtr);
+ goto recompileObj;
+ }
+ }
}
/*
- * Make sure the stack has enough room to execute this ByteCode.
+ * Execute the commands. If the code was compiled from an empty string,
+ * don't bother executing the code.
*/
- while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
- GrowEvaluationStack(eePtr);
- stackPtr = eePtr->stackPtr;
+ numSrcBytes = codePtr->numSrcBytes;
+ if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
+ /*
+ * Increment the code's ref count while it is being executed. If
+ * afterwards no references to it remain, free the code.
+ */
+
+ codePtr->refCount++;
+ iPtr->numLevels++;
+ result = TclExecuteByteCode(interp, codePtr);
+ iPtr->numLevels--;
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
+ } else {
+ result = TCL_OK;
}
/*
- * Loop executing instructions until a "done" instruction, a TCL_RETURN,
- * or some error.
+ * If no commands at all were executed, check for asynchronous
+ * handlers so that they at least get one change to execute.
+ * This is needed to handle event loops written in Tcl with
+ * empty bodies.
*/
- for (;;) {
-#ifdef TCL_COMPILE_DEBUG
- ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
- eePtr->stackEnd);
-#else /* not TCL_COMPILE_DEBUG */
- if (traceInstructions) {
- fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
- TclPrintInstruction(codePtr, pc);
- fflush(stdout);
- }
-#endif /* TCL_COMPILE_DEBUG */
+ if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
+ result = Tcl_AsyncInvoke(interp, result);
+
+
+ /*
+ * If an error occurred, record information about what was being
+ * executed when the error occurred.
+ */
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.instructionCount[*pc]++;
+ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
+ }
+ }
+
+ /*
+ * Set the interpreter's termOffset member to the offset of the
+ * character just after the last one executed. We approximate the offset
+ * of the last character executed by using the number of characters
+ * compiled.
+ */
+
+ iPtr->termOffset = numSrcBytes;
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclExecuteByteCode --
+ *
+ * This procedure executes the instructions of a ByteCode structure.
+ * It returns when a "done" instruction is executed or an error occurs.
+ *
+ * Results:
+ * The return value is one of the return codes defined in tcl.h
+ * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
+ * that either contains the result of executing the code or an
+ * error message.
+ *
+ * Side effects:
+ * Almost certainly, depending on the ByteCode's instructions.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TclExecuteByteCode(interp, codePtr)
+ Tcl_Interp *interp; /* Token for command interpreter. */
+ ByteCode *codePtr; /* The bytecode sequence to interpret. */
+{
+ Interp *iPtr = (Interp *) interp;
+ ExecEnv *eePtr = iPtr->execEnvPtr;
+ /* Points to the execution environment. */
+ register Tcl_Obj **stackPtr = eePtr->stackPtr;
+ /* Cached evaluation stack base pointer. */
+ register int stackTop = eePtr->stackTop;
+ /* Cached top index of evaluation stack. */
+ register unsigned char *pc = codePtr->codeStart;
+ /* The current program counter. */
+ int opnd; /* Current instruction's operand byte(s). */
+ int pcAdjustment; /* Hold pc adjustment after instruction. */
+ int initStackTop = stackTop;/* Stack top at start of execution. */
+ ExceptionRange *rangePtr; /* Points to closest loop or catch exception
+ * range enclosing the pc. Used by various
+ * instructions and processCatch to
+ * process break, continue, and errors. */
+ int result = TCL_OK; /* Return code returned after execution. */
+ int storeFlags;
+ Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
+ char *bytes;
+ int length;
+ long i = 0; /* Init. avoids compiler warning. */
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt w;
#endif
- switch (*pc) {
- case INST_DONE:
- /*
- * Pop the topmost object from the stack, set the interpreter's
- * object result to point to it, and return.
- */
+ register int cleanup;
+ Tcl_Obj *objResultPtr;
+ char *part1, *part2;
+ Var *varPtr, *arrayPtr;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+#ifdef TCL_COMPILE_DEBUG
+ int traceInstructions = (tclTraceExec == 3);
+ char cmdNameBuf[21];
+#endif
+
+ /*
+ * This procedure uses a stack to hold information about catch commands.
+ * This information is the current operand stack top when starting to
+ * execute the code for each catch command. It starts out with stack-
+ * allocated space but uses dynamically-allocated storage if needed.
+ */
+
+#define STATIC_CATCH_STACK_SIZE 4
+ int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
+ int *catchStackPtr = catchStackStorage;
+ int catchTop = -1;
+
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ PrintByteCodeInfo(codePtr);
+ fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
+ fflush(stdout);
+ }
+ opnd = 0; /* Init. avoids compiler warning. */
+#endif
+
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.numExecutions++;
+#endif
+
+ /*
+ * Make sure the catch stack is large enough to hold the maximum number
+ * of catch commands that could ever be executing at the same time. This
+ * will be no more than the exception range array's depth.
+ */
+
+ if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
+ catchStackPtr = (int *)
+ ckalloc(codePtr->maxExceptDepth * sizeof(int));
+ }
+
+ /*
+ * Make sure the stack has enough room to execute this ByteCode.
+ */
+
+ while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
+ GrowEvaluationStack(eePtr);
+ stackPtr = eePtr->stackPtr;
+ }
+
+ /*
+ * Loop executing instructions until a "done" instruction, a
+ * TCL_RETURN, or some error.
+ */
+
+ goto cleanup0;
+
+
+ /*
+ * Targets for standard instruction endings; unrolled
+ * for speed in the most frequent cases (instructions that
+ * consume up to two stack elements).
+ *
+ * This used to be a "for(;;)" loop, with each instruction doing
+ * its own cleanup.
+ */
+
+ cleanupV_pushObjResultPtr:
+ switch (cleanup) {
+ case 0:
+ stackPtr[++stackTop] = (objResultPtr);
+ goto cleanup0;
+ default:
+ cleanup -= 2;
+ while (cleanup--) {
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
+ }
+ case 2:
+ cleanup2_pushObjResultPtr:
valuePtr = POP_OBJECT();
- Tcl_SetObjResult(interp, valuePtr);
TclDecrRefCount(valuePtr);
- if (stackTop != initStackTop) {
- fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
- (unsigned int)(pc - codePtr->codeStart),
- (unsigned int) stackTop,
- (unsigned int) initStackTop);
- panic("TclExecuteByteCode execution failure: end stack top != start stack top");
- }
- TRACE_WITH_OBJ(("=> return code=%d, result=", result),
- iPtr->objResultPtr);
-#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- fprintf(stdout, "\n");
+ case 1:
+ cleanup1_pushObjResultPtr:
+ valuePtr = stackPtr[stackTop];
+ TclDecrRefCount(valuePtr);
+ }
+ stackPtr[stackTop] = objResultPtr;
+ goto cleanup0;
+
+ cleanupV:
+ switch (cleanup) {
+ default:
+ cleanup -= 2;
+ while (cleanup--) {
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
}
-#endif
- goto done;
-
- case INST_PUSH1:
+ case 2:
+ cleanup2:
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
+ case 1:
+ cleanup1:
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
+ case 0:
+ /*
+ * We really want to do nothing now, but this is needed
+ * for some compilers (SunPro CC)
+ */
+ break;
+ }
+
+ cleanup0:
+
#ifdef TCL_COMPILE_DEBUG
- valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
-#else
- PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
+ ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
+ if (traceInstructions) {
+ fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
+ TclPrintInstruction(codePtr, pc);
+ fflush(stdout);
+ }
#endif /* TCL_COMPILE_DEBUG */
- ADJUST_PC(2);
-
- case INST_PUSH4:
- valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
- ADJUST_PC(5);
-
- case INST_POP:
- valuePtr = POP_OBJECT();
- TRACE_WITH_OBJ(("=> discarding "), valuePtr);
- TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
- ADJUST_PC(1);
+
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.instructionCount[*pc]++;
+#endif
+ switch (*pc) {
+ case INST_DONE:
+ if (stackTop <= initStackTop) {
+ stackTop--;
+ goto abnormalReturn;
+ }
+
+ /*
+ * Set the interpreter's object result to point to the
+ * topmost object from the stack, and check for a possible
+ * [catch]. The stackTop's level and refCount will be handled
+ * by "processCatch" or "abnormalReturn".
+ */
- case INST_DUP:
- valuePtr = stackPtr[stackTop];
- PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
- TRACE_WITH_OBJ(("=> "), valuePtr);
- ADJUST_PC(1);
+ valuePtr = stackPtr[stackTop];
+ Tcl_SetObjResult(interp, valuePtr);
+#ifdef TCL_COMPILE_DEBUG
+ TRACE_WITH_OBJ(("=> return code=%d, result=", result),
+ iPtr->objResultPtr);
+ if (traceInstructions) {
+ fprintf(stdout, "\n");
+ }
+#endif
+ goto checkForCatch;
+
+ case INST_PUSH1:
+ objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
+ TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
+ NEXT_INST_F(2, 0, 1);
+
+ case INST_PUSH4:
+ objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
+ TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
+ NEXT_INST_F(5, 0, 1);
+
+ case INST_POP:
+ TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
+ NEXT_INST_F(1, 0, 0);
+
+ case INST_DUP:
+ objResultPtr = stackPtr[stackTop];
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
+ case INST_OVER:
+ opnd = TclGetUInt4AtPtr( pc+1 );
+ objResultPtr = stackPtr[ stackTop - opnd ];
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(5, 0, 1);
+
+ case INST_CONCAT1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ {
+ int totalLen = 0;
+
+ /*
+ * Concatenate strings (with no separators) from the top
+ * opnd items on the stack starting with the deepest item.
+ * First, determine how many characters are needed.
+ */
- case INST_CONCAT1:
- opnd = TclGetUInt1AtPtr(pc+1);
- {
- Tcl_Obj *concatObjPtr;
- int totalLen = 0;
+ for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
+ bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
+ if (bytes != NULL) {
+ totalLen += length;
+ }
+ }
- /*
- * Concatenate strings (with no separators) from the top
- * opnd items on the stack starting with the deepest item.
- * First, determine how many characters are needed.
- */
+ /*
+ * Initialize the new append string object by appending the
+ * strings of the opnd stack objects. Also pop the objects.
+ */
+ TclNewObj(objResultPtr);
+ if (totalLen > 0) {
+ char *p = (char *) ckalloc((unsigned) (totalLen + 1));
+ objResultPtr->bytes = p;
+ objResultPtr->length = totalLen;
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
- bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
+ valuePtr = stackPtr[i];
+ bytes = Tcl_GetStringFromObj(valuePtr, &length);
if (bytes != NULL) {
- totalLen += length;
- }
- }
-
- /*
- * Initialize the new append string object by appending the
- * strings of the opnd stack objects. Also pop the objects.
- */
-
- TclNewObj(concatObjPtr);
- if (totalLen > 0) {
- char *p = (char *) ckalloc((unsigned) (totalLen + 1));
- concatObjPtr->bytes = p;
- concatObjPtr->length = totalLen;
- for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
- valuePtr = stackPtr[i];
- bytes = Tcl_GetStringFromObj(valuePtr, &length);
- if (bytes != NULL) {
- memcpy((VOID *) p, (VOID *) bytes,
- (size_t) length);
- p += length;
- }
- TclDecrRefCount(valuePtr);
- }
- *p = '\0';
- } else {
- for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
- Tcl_DecrRefCount(stackPtr[i]);
+ memcpy((VOID *) p, (VOID *) bytes,
+ (size_t) length);
+ p += length;
}
}
- stackTop -= opnd;
+ *p = '\0';
+ }
- PUSH_OBJECT(concatObjPtr);
- TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
- ADJUST_PC(2);
- }
+ TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
+ NEXT_INST_V(2, opnd, 1);
+ }
- case INST_INVOKE_STK4:
- opnd = TclGetUInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doInvocation;
-
- case INST_INVOKE_STK1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
+ case INST_INVOKE_STK4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ goto doInvocation;
+
+ case INST_INVOKE_STK1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
- doInvocation:
- {
- int objc = opnd; /* The number of arguments. */
- Tcl_Obj **objv; /* The array of argument objects. */
- Command *cmdPtr; /* Points to command's Command struct. */
- int newPcOffset; /* New inst offset for break, continue. */
-#ifdef TCL_COMPILE_DEBUG
- int isUnknownCmd = 0;
- char cmdNameBuf[21];
-#endif /* TCL_COMPILE_DEBUG */
-
- /*
- * If the interpreter was deleted, return an error.
- */
-
- if (iPtr->flags & DELETED) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "attempt to call eval in deleted interpreter", -1);
- Tcl_SetErrorCode(interp, "CORE", "IDELETE",
- "attempt to call eval in deleted interpreter",
- (char *) NULL);
- result = TCL_ERROR;
- goto checkForCatch;
- }
-
- /*
- * Find the procedure to execute this command. If the
- * command is not found, handle it with the "unknown" proc.
- */
+ doInvocation:
+ {
+ int objc = opnd; /* The number of arguments. */
+ Tcl_Obj **objv; /* The array of argument objects. */
- objv = &(stackPtr[stackTop - (objc-1)]);
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
- if (cmdPtr == NULL) {
- cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
- (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
- if (cmdPtr == NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "invalid command name \"",
- Tcl_GetString(objv[0]), "\"",
- (char *) NULL);
- TRACE(("%u => unknown proc not found: ", objc));
- result = TCL_ERROR;
- goto checkForCatch;
- }
-#ifdef TCL_COMPILE_DEBUG
- isUnknownCmd = 1;
-#endif /*TCL_COMPILE_DEBUG*/
- stackTop++; /* need room for new inserted objv[0] */
- for (i = objc-1; i >= 0; i--) {
- objv[i+1] = objv[i];
- }
- objc++;
- objv[0] = Tcl_NewStringObj("unknown", -1);
- Tcl_IncrRefCount(objv[0]);
- }
-
- /*
- * Call any trace procedures.
- */
+ /*
+ * We keep the stack reference count as a (char *), as that
+ * works nicely as a portable pointer-sized counter.
+ */
+
+ char **preservedStackRefCountPtr;
+
+ /*
+ * Reference to memory block containing
+ * objv array (must be kept live throughout
+ * trace and command invokations.)
+ */
+
+ objv = &(stackPtr[stackTop - (objc-1)]);
- if (iPtr->tracePtr != NULL) {
- Trace *tracePtr, *nextTracePtr;
-
- for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
- tracePtr = nextTracePtr) {
- nextTracePtr = tracePtr->nextPtr;
- if (iPtr->numLevels <= tracePtr->level) {
- int numChars;
- char *cmd = GetSrcInfoForPc(pc, codePtr,
- &numChars);
- if (cmd != NULL) {
- DECACHE_STACK_INFO();
- CallTraceProcedure(interp, tracePtr, cmdPtr,
- cmd, numChars, objc, objv);
- CACHE_STACK_INFO();
- }
- }
- }
- }
-
- /*
- * Finally, invoke the command's Tcl_ObjCmdProc. First reset
- * the interpreter's string and object results to their
- * default empty values since they could have gotten changed
- * by earlier invocations.
- */
-
- Tcl_ResetResult(interp);
- if (tclTraceExec >= 2) {
#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
- TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
- } else {
- fprintf(stdout, "%d: (%u) invoking ",
- iPtr->numLevels,
- (unsigned int)(pc - codePtr->codeStart));
- }
- for (i = 0; i < objc; i++) {
- TclPrintObject(stdout, objv[i], 15);
- fprintf(stdout, " ");
- }
- fprintf(stdout, "\n");
- fflush(stdout);
-#else /* TCL_COMPILE_DEBUG */
- fprintf(stdout, "%d: (%u) invoking %s\n",
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ TRACE(("%u => call ", objc));
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
iPtr->numLevels,
- (unsigned int)(pc - codePtr->codeStart),
- Tcl_GetString(objv[0]));
-#endif /*TCL_COMPILE_DEBUG*/
+ (unsigned int)(pc - codePtr->codeStart));
}
-
- iPtr->cmdCount++;
- DECACHE_STACK_INFO();
- result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
- objc, objv);
- if (Tcl_AsyncReady()) {
- result = Tcl_AsyncInvoke(interp, result);
+ for (i = 0; i < objc; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
}
- CACHE_STACK_INFO();
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
- /*
- * If the interpreter has a non-empty string result, the
- * result object is either empty or stale because some
- * procedure set interp->result directly. If so, move the
- * string result to the result object, then reset the
- * string result.
- */
+ /*
+ * If trace procedures will be called, we need a
+ * command string to pass to TclEvalObjvInternal; note
+ * that a copy of the string will be made there to
+ * include the ending \0.
+ */
- if (*(iPtr->result) != 0) {
- (void) Tcl_GetObjResult(interp);
- }
-
- /*
- * Pop the objc top stack elements and decrement their ref
- * counts.
- */
+ bytes = NULL;
+ length = 0;
+ if (iPtr->tracePtr != NULL) {
+ Trace *tracePtr, *nextTracePtr;
+
+ for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
+ tracePtr = nextTracePtr) {
+ nextTracePtr = tracePtr->nextPtr;
+ if (tracePtr->level == 0 ||
+ iPtr->numLevels <= tracePtr->level) {
+ /*
+ * Traces will be called: get command string
+ */
- for (i = 0; i < objc; i++) {
- valuePtr = stackPtr[stackTop];
- TclDecrRefCount(valuePtr);
- stackTop--;
+ bytes = GetSrcInfoForPc(pc, codePtr, &length);
+ break;
+ }
}
+ } else {
+ Command *cmdPtr;
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
+ if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
+ bytes = GetSrcInfoForPc(pc, codePtr, &length);
+ }
+ }
- /*
- * Process the result of the Tcl_ObjCmdProc call.
- */
-
- switch (result) {
- case TCL_OK:
- /*
- * Push the call's object result and continue execution
- * with the next instruction.
- */
- PUSH_OBJECT(Tcl_GetObjResult(interp));
- TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
- objc, cmdNameBuf), Tcl_GetObjResult(interp));
- ADJUST_PC(pcAdjustment);
-
- case TCL_BREAK:
- case TCL_CONTINUE:
- /*
- * The invoked command requested a break or continue.
- * Find the closest enclosing loop or catch exception
- * range, if any. If a loop is found, terminate its
- * execution or skip to its next iteration. If the
- * closest is a catch exception range, jump to its
- * catchOffset. If no enclosing range is found, stop
- * execution and return the TCL_BREAK or TCL_CONTINUE.
- */
- rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
- codePtr);
- if (rangePtr == NULL) {
- TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
- objc, cmdNameBuf,
- StringForResultCode(result)));
- goto abnormalReturn; /* no catch exists to check */
- }
- newPcOffset = 0;
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- if (result == TCL_BREAK) {
- newPcOffset = rangePtr->breakOffset;
- } else if (rangePtr->continueOffset == -1) {
- TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
- objc, cmdNameBuf,
- StringForResultCode(result)));
- goto checkForCatch;
- } else {
- newPcOffset = rangePtr->continueOffset;
- }
- TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
- objc, cmdNameBuf,
- StringForResultCode(result),
- rangePtr->codeOffset, newPcOffset));
- break;
- case CATCH_EXCEPTION_RANGE:
- TRACE(("%u => ... after \"%.20s\", %s...\n",
- objc, cmdNameBuf,
- StringForResultCode(result)));
- goto processCatch; /* it will use rangePtr */
- default:
- panic("TclExecuteByteCode: bad ExceptionRange type\n");
- }
- result = TCL_OK;
- pc = (codePtr->codeStart + newPcOffset);
- continue; /* restart outer instruction loop at pc */
-
- case TCL_ERROR:
- /*
- * The invoked command returned an error. Look for an
- * enclosing catch exception range, if any.
- */
- TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
- objc, cmdNameBuf), Tcl_GetObjResult(interp));
+ /*
+ * A reference to part of the stack vector itself
+ * escapes our control: increase its refCount
+ * to stop it from being deallocated by a recursive
+ * call to ourselves. The extra variable is needed
+ * because all others are liable to change due to the
+ * trace procedures.
+ */
+
+ preservedStackRefCountPtr = (char **) (stackPtr-1);
+ ++*preservedStackRefCountPtr;
+
+ /*
+ * Finally, let TclEvalObjvInternal handle the command.
+ */
+
+ Tcl_ResetResult(interp);
+ DECACHE_STACK_INFO();
+ result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
+ CACHE_STACK_INFO();
+
+ /*
+ * If the old stack is going to be released, it is
+ * safe to do so now, since no references to objv are
+ * going to be used from now on.
+ */
+
+ --*preservedStackRefCountPtr;
+ if (*preservedStackRefCountPtr == (char *) 0) {
+ ckfree((VOID *) preservedStackRefCountPtr);
+ }
+
+ if (result == TCL_OK) {
+ /*
+ * Push the call's object result and continue execution
+ * with the next instruction.
+ */
+
+ TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
+ objc, cmdNameBuf), Tcl_GetObjResult(interp));
+
+ objResultPtr = Tcl_GetObjResult(interp);
+ NEXT_INST_V(pcAdjustment, opnd, 1);
+ } else {
+ cleanup = opnd;
+ goto processExceptionReturn;
+ }
+ }
+
+ case INST_EVAL_STK:
+ /*
+ * Note to maintainers: it is important that INST_EVAL_STK
+ * pop its argument from the stack before jumping to
+ * checkForCatch! DO NOT OPTIMISE!
+ */
+
+ objPtr = stackPtr[stackTop];
+ DECACHE_STACK_INFO();
+ result = TclCompEvalObj(interp, objPtr);
+ CACHE_STACK_INFO();
+ if (result == TCL_OK) {
+ /*
+ * Normal return; push the eval's object result.
+ */
+
+ objResultPtr = Tcl_GetObjResult(interp);
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
+ Tcl_GetObjResult(interp));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ cleanup = 1;
+ goto processExceptionReturn;
+ }
+
+ case INST_EXPR_STK:
+ objPtr = stackPtr[stackTop];
+ Tcl_ResetResult(interp);
+ DECACHE_STACK_INFO();
+ result = Tcl_ExprObj(interp, objPtr, &valuePtr);
+ CACHE_STACK_INFO();
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
+ O2S(objPtr)), Tcl_GetObjResult(interp));
+ goto checkForCatch;
+ }
+ objResultPtr = valuePtr;
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
+ NEXT_INST_F(1, 1, -1); /* already has right refct */
+
+ /*
+ * ---------------------------------------------------------
+ * Start of INST_LOAD instructions.
+ *
+ * WARNING: more 'goto' here than your doctor recommended!
+ * The different instructions set the value of some variables
+ * and then jump to somme common execution code.
+ */
+
+ case INST_LOAD_SCALAR1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ varPtr = &(varFramePtr->compiledLocals[opnd]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u => ", opnd));
+ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
+ && (varPtr->tracePtr == NULL)) {
+ /*
+ * No errors, no traces: just get the value.
+ */
+ objResultPtr = varPtr->value.objPtr;
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(2, 0, 1);
+ }
+ pcAdjustment = 2;
+ cleanup = 0;
+ arrayPtr = NULL;
+ part2 = NULL;
+ goto doCallPtrGetVar;
+
+ case INST_LOAD_SCALAR4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ varPtr = &(varFramePtr->compiledLocals[opnd]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ TRACE(("%u => ", opnd));
+ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
+ && (varPtr->tracePtr == NULL)) {
+ /*
+ * No errors, no traces: just get the value.
+ */
+ objResultPtr = varPtr->value.objPtr;
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(5, 0, 1);
+ }
+ pcAdjustment = 5;
+ cleanup = 0;
+ arrayPtr = NULL;
+ part2 = NULL;
+ goto doCallPtrGetVar;
+
+ case INST_LOAD_ARRAY_STK:
+ cleanup = 2;
+ part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */
+ objPtr = stackPtr[stackTop-1]; /* array name */
+ TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
+ goto doLoadStk;
+
+ case INST_LOAD_STK:
+ case INST_LOAD_SCALAR_STK:
+ cleanup = 1;
+ part2 = NULL;
+ objPtr = stackPtr[stackTop]; /* variable name */
+ TRACE(("\"%.30s\" => ", O2S(objPtr)));
+
+ doLoadStk:
+ part1 = TclGetString(objPtr);
+ varPtr = TclObjLookupVar(interp, objPtr, part2,
+ TCL_LEAVE_ERR_MSG, "read",
+ /*createPart1*/ 0,
+ /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
+ && (varPtr->tracePtr == NULL)
+ && ((arrayPtr == NULL)
+ || (arrayPtr->tracePtr == NULL))) {
+ /*
+ * No errors, no traces: just get the value.
+ */
+ objResultPtr = varPtr->value.objPtr;
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(1, cleanup, 1);
+ }
+ pcAdjustment = 1;
+ goto doCallPtrGetVar;
+
+ case INST_LOAD_ARRAY4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ goto doLoadArray;
+
+ case INST_LOAD_ARRAY1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+
+ doLoadArray:
+ part2 = TclGetString(stackPtr[stackTop]);
+ arrayPtr = &(varFramePtr->compiledLocals[opnd]);
+ part1 = arrayPtr->name;
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%u \"%.30s\" => ", opnd, part2));
+ varPtr = TclLookupArrayElement(interp, part1, part2,
+ TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
+ && (varPtr->tracePtr == NULL)
+ && ((arrayPtr == NULL)
+ || (arrayPtr->tracePtr == NULL))) {
+ /*
+ * No errors, no traces: just get the value.
+ */
+ objResultPtr = varPtr->value.objPtr;
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(pcAdjustment, 1, 1);
+ }
+ cleanup = 1;
+ goto doCallPtrGetVar;
+
+ doCallPtrGetVar:
+ /*
+ * There are either errors or the variable is traced:
+ * call TclPtrGetVar to process fully.
+ */
+
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1,
+ part2, TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+ if (objResultPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ /*
+ * End of INST_LOAD instructions.
+ * ---------------------------------------------------------
+ */
+
+ /*
+ * ---------------------------------------------------------
+ * Start of INST_STORE and related instructions.
+ *
+ * WARNING: more 'goto' here than your doctor recommended!
+ * The different instructions set the value of some variables
+ * and then jump to somme common execution code.
+ */
+
+ case INST_LAPPEND_STK:
+ valuePtr = stackPtr[stackTop]; /* value to append */
+ part2 = NULL;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
+ | TCL_LIST_ELEMENT | TCL_TRACE_READS);
+ goto doStoreStk;
+
+ case INST_LAPPEND_ARRAY_STK:
+ valuePtr = stackPtr[stackTop]; /* value to append */
+ part2 = TclGetString(stackPtr[stackTop - 1]);
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
+ | TCL_LIST_ELEMENT | TCL_TRACE_READS);
+ goto doStoreStk;
+
+ case INST_APPEND_STK:
+ valuePtr = stackPtr[stackTop]; /* value to append */
+ part2 = NULL;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+ goto doStoreStk;
+
+ case INST_APPEND_ARRAY_STK:
+ valuePtr = stackPtr[stackTop]; /* value to append */
+ part2 = TclGetString(stackPtr[stackTop - 1]);
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+ goto doStoreStk;
+
+ case INST_STORE_ARRAY_STK:
+ valuePtr = stackPtr[stackTop];
+ part2 = TclGetString(stackPtr[stackTop - 1]);
+ storeFlags = TCL_LEAVE_ERR_MSG;
+ goto doStoreStk;
+
+ case INST_STORE_STK:
+ case INST_STORE_SCALAR_STK:
+ valuePtr = stackPtr[stackTop];
+ part2 = NULL;
+ storeFlags = TCL_LEAVE_ERR_MSG;
+
+ doStoreStk:
+ objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
+ part1 = TclGetString(objPtr);
+#ifdef TCL_COMPILE_DEBUG
+ if (part2 == NULL) {
+ TRACE(("\"%.30s\" <- \"%.30s\" =>",
+ part1, O2S(valuePtr)));
+ } else {
+ TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
+ part1, part2, O2S(valuePtr)));
+ }
+#endif
+ varPtr = TclObjLookupVar(interp, objPtr, part2,
+ TCL_LEAVE_ERR_MSG, "set",
+ /*createPart1*/ 1,
+ /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ cleanup = ((part2 == NULL)? 2 : 3);
+ pcAdjustment = 1;
+ goto doCallPtrSetVar;
+
+ case INST_LAPPEND_ARRAY4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
+ | TCL_LIST_ELEMENT | TCL_TRACE_READS);
+ goto doStoreArray;
+
+ case INST_LAPPEND_ARRAY1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
+ | TCL_LIST_ELEMENT | TCL_TRACE_READS);
+ goto doStoreArray;
+
+ case INST_APPEND_ARRAY4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+ goto doStoreArray;
+
+ case INST_APPEND_ARRAY1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+ goto doStoreArray;
+
+ case INST_STORE_ARRAY4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ storeFlags = TCL_LEAVE_ERR_MSG;
+ goto doStoreArray;
+
+ case INST_STORE_ARRAY1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+ storeFlags = TCL_LEAVE_ERR_MSG;
+
+ doStoreArray:
+ valuePtr = stackPtr[stackTop];
+ part2 = TclGetString(stackPtr[stackTop - 1]);
+ arrayPtr = &(varFramePtr->compiledLocals[opnd]);
+ part1 = arrayPtr->name;
+ TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
+ opnd, part2, O2S(valuePtr)));
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ varPtr = TclLookupArrayElement(interp, part1, part2,
+ TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ cleanup = 2;
+ goto doCallPtrSetVar;
+
+ case INST_LAPPEND_SCALAR4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
+ | TCL_LIST_ELEMENT | TCL_TRACE_READS);
+ goto doStoreScalar;
+
+ case INST_LAPPEND_SCALAR1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
+ | TCL_LIST_ELEMENT | TCL_TRACE_READS);
+ goto doStoreScalar;
+
+ case INST_APPEND_SCALAR4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+ goto doStoreScalar;
+
+ case INST_APPEND_SCALAR1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+ storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
+ goto doStoreScalar;
+
+ case INST_STORE_SCALAR4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pcAdjustment = 5;
+ storeFlags = TCL_LEAVE_ERR_MSG;
+ goto doStoreScalar;
+
+ case INST_STORE_SCALAR1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+ storeFlags = TCL_LEAVE_ERR_MSG;
+
+ doStoreScalar:
+ valuePtr = stackPtr[stackTop];
+ varPtr = &(varFramePtr->compiledLocals[opnd]);
+ part1 = varPtr->name;
+ TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ cleanup = 1;
+ arrayPtr = NULL;
+ part2 = NULL;
+
+ doCallPtrSetVar:
+ if ((storeFlags == TCL_LEAVE_ERR_MSG)
+ && !((varPtr->flags & VAR_IN_HASHTABLE)
+ && (varPtr->hPtr == NULL))
+ && (varPtr->tracePtr == NULL)
+ && (TclIsVarScalar(varPtr)
+ || TclIsVarUndefined(varPtr))
+ && ((arrayPtr == NULL)
+ || (arrayPtr->tracePtr == NULL))) {
+ /*
+ * No traces, no errors, plain 'set': we can safely inline.
+ * The value *will* be set to what's requested, so that
+ * the stack top remains pointing to the same Tcl_Obj.
+ */
+ valuePtr = varPtr->value.objPtr;
+ objResultPtr = stackPtr[stackTop];
+ if (valuePtr != objResultPtr) {
+ if (valuePtr != NULL) {
+ TclDecrRefCount(valuePtr);
+ } else {
+ TclSetVarScalar(varPtr);
+ TclClearVarUndefined(varPtr);
+ }
+ varPtr->value.objPtr = objResultPtr;
+ Tcl_IncrRefCount(objResultPtr);
+ }
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+pcAdjustment) == INST_POP) {
+ NEXT_INST_V((pcAdjustment+1), cleanup, 0);
+ }
+#else
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+#endif
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+ } else {
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
+ part1, part2, valuePtr, storeFlags);
+ CACHE_STACK_INFO();
+ if (objResultPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ }
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+pcAdjustment) == INST_POP) {
+ NEXT_INST_V((pcAdjustment+1), cleanup, 0);
+ }
+#endif
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+
+ /*
+ * End of INST_STORE and related instructions.
+ * ---------------------------------------------------------
+ */
+
+ /*
+ * ---------------------------------------------------------
+ * Start of INST_INCR instructions.
+ *
+ * WARNING: more 'goto' here than your doctor recommended!
+ * The different instructions set the value of some variables
+ * and then jump to somme common execution code.
+ */
+
+ case INST_INCR_SCALAR1:
+ case INST_INCR_ARRAY1:
+ case INST_INCR_ARRAY_STK:
+ case INST_INCR_SCALAR_STK:
+ case INST_INCR_STK:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ valuePtr = stackPtr[stackTop];
+ if (valuePtr->typePtr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
+ opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
+ goto checkForCatch;
+ }
+ FORCE_LONG(valuePtr, i, w);
+ }
+ stackTop--;
+ TclDecrRefCount(valuePtr);
+ switch (*pc) {
+ case INST_INCR_SCALAR1:
+ pcAdjustment = 2;
+ goto doIncrScalar;
+ case INST_INCR_ARRAY1:
+ pcAdjustment = 2;
+ goto doIncrArray;
+ default:
+ pcAdjustment = 1;
+ goto doIncrStk;
+ }
+
+ case INST_INCR_ARRAY_STK_IMM:
+ case INST_INCR_SCALAR_STK_IMM:
+ case INST_INCR_STK_IMM:
+ i = TclGetInt1AtPtr(pc+1);
+ pcAdjustment = 2;
+
+ doIncrStk:
+ if ((*pc == INST_INCR_ARRAY_STK_IMM)
+ || (*pc == INST_INCR_ARRAY_STK)) {
+ part2 = TclGetString(stackPtr[stackTop]);
+ objPtr = stackPtr[stackTop - 1];
+ TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
+ O2S(objPtr), part2, i));
+ } else {
+ part2 = NULL;
+ objPtr = stackPtr[stackTop];
+ TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
+ }
+ part1 = TclGetString(objPtr);
+
+ varPtr = TclObjLookupVar(interp, objPtr, part2,
+ TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
+ if (varPtr == NULL) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (reading value of variable to increment)", -1);
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ cleanup = ((part2 == NULL)? 1 : 2);
+ goto doIncrVar;
+
+ case INST_INCR_ARRAY1_IMM:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ i = TclGetInt1AtPtr(pc+2);
+ pcAdjustment = 3;
+
+ doIncrArray:
+ part2 = TclGetString(stackPtr[stackTop]);
+ arrayPtr = &(varFramePtr->compiledLocals[opnd]);
+ part1 = arrayPtr->name;
+ while (TclIsVarLink(arrayPtr)) {
+ arrayPtr = arrayPtr->value.linkPtr;
+ }
+ TRACE(("%u \"%.30s\" (by %ld) => ",
+ opnd, part2, i));
+ varPtr = TclLookupArrayElement(interp, part1, part2,
+ TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
+ if (varPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ cleanup = 1;
+ goto doIncrVar;
+
+ case INST_INCR_SCALAR1_IMM:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ i = TclGetInt1AtPtr(pc+2);
+ pcAdjustment = 3;
+
+ doIncrScalar:
+ varPtr = &(varFramePtr->compiledLocals[opnd]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ arrayPtr = NULL;
+ part2 = NULL;
+ cleanup = 0;
+ TRACE(("%u %ld => ", opnd, i));
+
+
+ doIncrVar:
+ objPtr = varPtr->value.objPtr;
+ if (TclIsVarScalar(varPtr)
+ && !TclIsVarUndefined(varPtr)
+ && (varPtr->tracePtr == NULL)
+ && ((arrayPtr == NULL)
+ || (arrayPtr->tracePtr == NULL))
+ && (objPtr->typePtr == &tclIntType)) {
+ /*
+ * No errors, no traces, the variable already has an
+ * integer value: inline processing.
+ */
+
+ i += objPtr->internalRep.longValue;
+ if (Tcl_IsShared(objPtr)) {
+ objResultPtr = Tcl_NewLongObj(i);
+ TclDecrRefCount(objPtr);
+ Tcl_IncrRefCount(objResultPtr);
+ varPtr->value.objPtr = objResultPtr;
+ } else {
+ Tcl_SetLongObj(objPtr, i);
+ objResultPtr = objPtr;
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ } else {
+ DECACHE_STACK_INFO();
+ objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
+ part2, i, TCL_LEAVE_ERR_MSG);
+ CACHE_STACK_INFO();
+ if (objResultPtr == NULL) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ }
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+#ifndef TCL_COMPILE_DEBUG
+ if (*(pc+pcAdjustment) == INST_POP) {
+ NEXT_INST_V((pcAdjustment+1), cleanup, 0);
+ }
+#endif
+ NEXT_INST_V(pcAdjustment, cleanup, 1);
+
+ /*
+ * End of INST_INCR instructions.
+ * ---------------------------------------------------------
+ */
+
+
+ case INST_JUMP1:
+ opnd = TclGetInt1AtPtr(pc+1);
+ TRACE(("%d => new pc %u\n", opnd,
+ (unsigned int)(pc + opnd - codePtr->codeStart)));
+ NEXT_INST_F(opnd, 0, 0);
+
+ case INST_JUMP4:
+ opnd = TclGetInt4AtPtr(pc+1);
+ TRACE(("%d => new pc %u\n", opnd,
+ (unsigned int)(pc + opnd - codePtr->codeStart)));
+ NEXT_INST_F(opnd, 0, 0);
+
+ case INST_JUMP_FALSE4:
+ opnd = 5; /* TRUE */
+ pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
+ goto doJumpTrue;
+
+ case INST_JUMP_TRUE4:
+ opnd = TclGetInt4AtPtr(pc+1); /* TRUE */
+ pcAdjustment = 5; /* FALSE */
+ goto doJumpTrue;
+
+ case INST_JUMP_FALSE1:
+ opnd = 2; /* TRUE */
+ pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
+ goto doJumpTrue;
+
+ case INST_JUMP_TRUE1:
+ opnd = TclGetInt1AtPtr(pc+1); /* TRUE */
+ pcAdjustment = 2; /* FALSE */
+
+ doJumpTrue:
+ {
+ int b;
+
+ valuePtr = stackPtr[stackTop];
+ if (valuePtr->typePtr == &tclIntType) {
+ b = (valuePtr->internalRep.longValue != 0);
+ } else if (valuePtr->typePtr == &tclDoubleType) {
+ b = (valuePtr->internalRep.doubleValue != 0.0);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ b = (valuePtr->internalRep.wideValue != W0);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
goto checkForCatch;
+ }
+ }
+#ifndef TCL_COMPILE_DEBUG
+ NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
+#else
+ if (b) {
+ if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
+ TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr),
+ (unsigned int)(pc+opnd - codePtr->codeStart)));
+ } else {
+ TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr)));
+ }
+ NEXT_INST_F(opnd, 1, 0);
+ } else {
+ if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
+ TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
+ } else {
+ opnd = pcAdjustment;
+ TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr),
+ (unsigned int)(pc + opnd - codePtr->codeStart)));
+ }
+ NEXT_INST_F(pcAdjustment, 1, 0);
+ }
+#endif
+ }
+
+ case INST_LOR:
+ case INST_LAND:
+ {
+ /*
+ * Operands must be boolean or numeric. No int->double
+ * conversions are performed.
+ */
+
+ int i1, i2;
+ int iResult;
+ char *s;
+ Tcl_ObjType *t1Ptr, *t2Ptr;
+
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop - 1];;
+ t1Ptr = valuePtr->typePtr;
+ t2Ptr = value2Ptr->typePtr;
+
+ if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
+ i1 = (valuePtr->internalRep.longValue != 0);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (t1Ptr == &tclWideIntType) {
+ i1 = (valuePtr->internalRep.wideValue != W0);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else if (t1Ptr == &tclDoubleType) {
+ i1 = (valuePtr->internalRep.doubleValue != 0.0);
+ } else {
+ s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
+#ifdef TCL_WIDE_INT_IS_LONG
+ result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
+ valuePtr, &i);
+ i1 = (i != 0);
+#else /* !TCL_WIDE_INT_IS_LONG */
+ GET_WIDE_OR_INT(result, valuePtr, i, w);
+ if (valuePtr->typePtr == &tclIntType) {
+ i1 = (i != 0);
+ } else {
+ i1 = (w != W0);
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
+ valuePtr, &i1);
+ i1 = (i1 != 0);
+ }
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ (t1Ptr? t1Ptr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ }
+
+ if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
+ i2 = (value2Ptr->internalRep.longValue != 0);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (t2Ptr == &tclWideIntType) {
+ i2 = (value2Ptr->internalRep.wideValue != W0);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else if (t2Ptr == &tclDoubleType) {
+ i2 = (value2Ptr->internalRep.doubleValue != 0.0);
+ } else {
+ s = Tcl_GetStringFromObj(value2Ptr, &length);
+ if (TclLooksLikeInt(s, length)) {
+#ifdef TCL_WIDE_INT_IS_LONG
+ result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
+ value2Ptr, &i);
+ i2 = (i != 0);
+#else /* !TCL_WIDE_INT_IS_LONG */
+ GET_WIDE_OR_INT(result, value2Ptr, i, w);
+ if (value2Ptr->typePtr == &tclIntType) {
+ i2 = (i != 0);
+ } else {
+ i2 = (w != W0);
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
+ }
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
+ (t2Ptr? t2Ptr->name : "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
+ }
+ }
+
+ /*
+ * Reuse the valuePtr object already on stack if possible.
+ */
+
+ if (*pc == INST_LOR) {
+ iResult = (i1 || i2);
+ } else {
+ iResult = (i1 && i2);
+ }
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewLongObj(iResult);
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+ NEXT_INST_F(1, 2, 1);
+ } else { /* reuse the valuePtr object */
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+ Tcl_SetLongObj(valuePtr, iResult);
+ NEXT_INST_F(1, 1, 0);
+ }
+ }
+
+ /*
+ * ---------------------------------------------------------
+ * Start of INST_LIST and related instructions.
+ */
+
+ case INST_LIST:
+ /*
+ * Pop the opnd (objc) top stack elements into a new list obj
+ * and then decrement their ref counts.
+ */
+
+ opnd = TclGetUInt4AtPtr(pc+1);
+ objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
+ TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
+ NEXT_INST_V(5, opnd, 1);
+
+ case INST_LIST_LENGTH:
+ valuePtr = stackPtr[stackTop];
+
+ result = Tcl_ListObjLength(interp, valuePtr, &length);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
+ Tcl_GetObjResult(interp));
+ goto checkForCatch;
+ }
+ objResultPtr = Tcl_NewIntObj(length);
+ TRACE(("%.20s => %d\n", O2S(valuePtr), length));
+ NEXT_INST_F(1, 1, 1);
+
+ case INST_LIST_INDEX:
+ /*** lindex with objc == 3 ***/
+
+ /*
+ * Pop the two operands
+ */
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop- 1];
+
+ /*
+ * Extract the desired list element
+ */
+ objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
+ if (objResultPtr == NULL) {
+ TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
+ Tcl_GetObjResult(interp));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ /*
+ * Stash the list element on the stack
+ */
+ TRACE(("%.20s %.20s => %s\n",
+ O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
+
+ case INST_LIST_INDEX_MULTI:
+ {
+ /*
+ * 'lindex' with multiple index args:
+ *
+ * Determine the count of index args.
+ */
+
+ int numIdx;
+
+ opnd = TclGetUInt4AtPtr(pc+1);
+ numIdx = opnd-1;
+
+ /*
+ * Do the 'lindex' operation.
+ */
+ objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
+ numIdx, stackPtr + stackTop - numIdx + 1);
+
+ /*
+ * Check for errors
+ */
+ if (objResultPtr == NULL) {
+ TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ /*
+ * Set result
+ */
+ TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd, -1);
+ }
+
+ case INST_LSET_FLAT:
+ {
+ /*
+ * Lset with 3, 5, or more args. Get the number
+ * of index args.
+ */
+ int numIdx;
+
+ opnd = TclGetUInt4AtPtr( pc + 1 );
+ numIdx = opnd - 2;
+
+ /*
+ * Get the old value of variable, and remove the stack ref.
+ * This is safe because the variable still references the
+ * object; the ref count will never go zero here.
+ */
+ value2Ptr = POP_OBJECT();
+ TclDecrRefCount(value2Ptr); /* This one should be done here */
+
+ /*
+ * Get the new element value.
+ */
+ valuePtr = stackPtr[stackTop];
+
+ /*
+ * Compute the new variable value
+ */
+ objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
+ stackPtr + stackTop - numIdx, valuePtr);
+
+
+ /*
+ * Check for errors
+ */
+ if (objResultPtr == NULL) {
+ TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ /*
+ * Set result
+ */
+ TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
+ NEXT_INST_V(5, (numIdx+1), -1);
+ }
+
+ case INST_LSET_LIST:
+ /*
+ * 'lset' with 4 args.
+ *
+ * Get the old value of variable, and remove the stack ref.
+ * This is safe because the variable still references the
+ * object; the ref count will never go zero here.
+ */
+ objPtr = POP_OBJECT();
+ TclDecrRefCount(objPtr); /* This one should be done here */
+
+ /*
+ * Get the new element value, and the index list
+ */
+ valuePtr = stackPtr[stackTop];
+ value2Ptr = stackPtr[stackTop - 1];
+
+ /*
+ * Compute the new variable value
+ */
+ objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
+
+ /*
+ * Check for errors
+ */
+ if (objResultPtr == NULL) {
+ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
+ Tcl_GetObjResult(interp));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+
+ /*
+ * Set result
+ */
+ TRACE(("=> %s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, -1);
+
+ /*
+ * End of INST_LIST and related instructions.
+ * ---------------------------------------------------------
+ */
+
+ case INST_STR_EQ:
+ case INST_STR_NEQ:
+ {
+ /*
+ * String (in)equality check
+ */
+ int iResult;
+
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop - 1];
+
+ if (valuePtr == value2Ptr) {
+ /*
+ * On the off-chance that the objects are the same,
+ * we don't really have to think hard about equality.
+ */
+ iResult = (*pc == INST_STR_EQ);
+ } else {
+ char *s1, *s2;
+ int s1len, s2len;
+
+ s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
+ s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
+ if (s1len == s2len) {
+ /*
+ * We only need to check (in)equality when
+ * we have equal length strings.
+ */
+ if (*pc == INST_STR_NEQ) {
+ iResult = (strcmp(s1, s2) != 0);
+ } else {
+ /* INST_STR_EQ */
+ iResult = (strcmp(s1, s2) == 0);
+ }
+ } else {
+ iResult = (*pc == INST_STR_NEQ);
+ }
+ }
+
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump
+ * from here.
+ */
+
+ pc++;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ }
+#endif
+ objResultPtr = Tcl_NewIntObj(iResult);
+ NEXT_INST_F(0, 2, 1);
+ }
+
+ case INST_STR_CMP:
+ {
+ /*
+ * String compare
+ */
+ CONST char *s1, *s2;
+ int s1len, s2len, iResult;
+
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop - 1];
+
+ /*
+ * The comparison function should compare up to the
+ * minimum byte length only.
+ */
+ if (valuePtr == value2Ptr) {
+ /*
+ * In the pure equality case, set lengths too for
+ * the checks below (or we could goto beyond it).
+ */
+ iResult = s1len = s2len = 0;
+ } else if ((valuePtr->typePtr == &tclByteArrayType)
+ && (value2Ptr->typePtr == &tclByteArrayType)) {
+ s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
+ s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
+ iResult = memcmp(s1, s2,
+ (size_t) ((s1len < s2len) ? s1len : s2len));
+ } else if (((valuePtr->typePtr == &tclStringType)
+ && (value2Ptr->typePtr == &tclStringType))) {
+ /*
+ * Do a unicode-specific comparison if both of the args
+ * are of String type. In benchmark testing this proved
+ * the most efficient check between the unicode and
+ * string comparison operations.
+ */
+ Tcl_UniChar *uni1, *uni2;
+ uni1 = Tcl_GetUnicodeFromObj(valuePtr, &s1len);
+ uni2 = Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
+ iResult = TclUniCharNcmp(uni1, uni2,
+ (unsigned) ((s1len < s2len) ? s1len : s2len));
+ } else {
+ /*
+ * We can't do a simple memcmp in order to handle the
+ * special Tcl \xC0\x80 null encoding for utf-8.
+ */
+ s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
+ s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
+ iResult = TclpUtfNcmp2(s1, s2,
+ (size_t) ((s1len < s2len) ? s1len : s2len));
+ }
+
+ /*
+ * Make sure only -1,0,1 is returned
+ */
+ if (iResult == 0) {
+ iResult = s1len - s2len;
+ }
+ if (iResult < 0) {
+ iResult = -1;
+ } else if (iResult > 0) {
+ iResult = 1;
+ }
+
+ objResultPtr = Tcl_NewIntObj(iResult);
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+ NEXT_INST_F(1, 2, 1);
+ }
- case TCL_RETURN:
- /*
- * The invoked command requested that the current
- * procedure stop execution and return. First check
- * for an enclosing catch exception range, if any.
- */
- TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
- objc, cmdNameBuf));
- goto checkForCatch;
+ case INST_STR_LEN:
+ {
+ int length1;
+
+ valuePtr = stackPtr[stackTop];
- default:
- TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
- objc, cmdNameBuf, result),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
- }
- }
+ if (valuePtr->typePtr == &tclByteArrayType) {
+ (void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
+ } else {
+ length1 = Tcl_GetCharLength(valuePtr);
+ }
+ objResultPtr = Tcl_NewIntObj(length1);
+ TRACE(("%.20s => %d\n", O2S(valuePtr), length1));
+ NEXT_INST_F(1, 1, 1);
+ }
- case INST_EVAL_STK:
- objPtr = POP_OBJECT();
- DECACHE_STACK_INFO();
- result = Tcl_EvalObjEx(interp, objPtr, 0);
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
- /*
- * Normal return; push the eval's object result.
- */
- PUSH_OBJECT(Tcl_GetObjResult(interp));
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- TclDecrRefCount(objPtr);
- ADJUST_PC(1);
- } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
+ case INST_STR_INDEX:
+ {
+ /*
+ * String compare
+ */
+ int index;
+ bytes = NULL; /* lint */
+
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop - 1];
+
+ /*
+ * If we have a ByteArray object, avoid indexing in the
+ * Utf string since the byte array contains one byte per
+ * character. Otherwise, use the Unicode string rep to
+ * get the index'th char.
+ */
+
+ if (valuePtr->typePtr == &tclByteArrayType) {
+ bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
+ } else {
+ /*
+ * Get Unicode char length to calulate what 'end' means.
+ */
+ length = Tcl_GetCharLength(valuePtr);
+ }
+
+ result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
+ if (result != TCL_OK) {
+ goto checkForCatch;
+ }
+
+ if ((index >= 0) && (index < length)) {
+ if (valuePtr->typePtr == &tclByteArrayType) {
+ objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
+ (&bytes[index]), 1);
+ } else {
+ char buf[TCL_UTF_MAX];
+ Tcl_UniChar ch;
+
+ ch = Tcl_GetUniChar(valuePtr, index);
/*
- * Find the closest enclosing loop or catch exception range,
- * if any. If a loop is found, terminate its execution or
- * skip to its next iteration. If the closest is a catch
- * exception range, jump to its catchOffset. If no enclosing
- * range is found, stop execution and return that same
- * TCL_BREAK or TCL_CONTINUE.
+ * This could be:
+ * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
+ * but creating the object as a string seems to be
+ * faster in practical use.
*/
-
- int newPcOffset = 0; /* Pc offset computed during break,
- * continue, error processing. Init.
- * to avoid compiler warning. */
-
- rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
- codePtr);
- if (rangePtr == NULL) {
- TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
- O2S(objPtr), StringForResultCode(result)));
- Tcl_DecrRefCount(objPtr);
- goto abnormalReturn; /* no catch exists to check */
- }
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- if (result == TCL_BREAK) {
- newPcOffset = rangePtr->breakOffset;
- } else if (rangePtr->continueOffset == -1) {
- TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
- O2S(objPtr), StringForResultCode(result)));
- Tcl_DecrRefCount(objPtr);
- goto checkForCatch;
- } else {
- newPcOffset = rangePtr->continueOffset;
- }
- result = TCL_OK;
- TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
- O2S(objPtr), StringForResultCode(result),
- rangePtr->codeOffset, newPcOffset), valuePtr);
- break;
- case CATCH_EXCEPTION_RANGE:
- TRACE_WITH_OBJ(("\"%.30s\" => %s ",
- O2S(objPtr), StringForResultCode(result)),
- valuePtr);
- Tcl_DecrRefCount(objPtr);
- goto processCatch; /* it will use rangePtr */
- default:
- panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
- }
- Tcl_DecrRefCount(objPtr);
- pc = (codePtr->codeStart + newPcOffset);
- continue; /* restart outer instruction loop at pc */
- } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- goto checkForCatch;
+ length = Tcl_UniCharToUtf(ch, buf);
+ objResultPtr = Tcl_NewStringObj(buf, length);
}
+ } else {
+ TclNewObj(objResultPtr);
+ }
- case INST_EXPR_STK:
- objPtr = POP_OBJECT();
- Tcl_ResetResult(interp);
- DECACHE_STACK_INFO();
- result = Tcl_ExprObj(interp, objPtr, &valuePtr);
- CACHE_STACK_INFO();
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
- O2S(objPtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- goto checkForCatch;
- }
- stackPtr[++stackTop] = valuePtr; /* already has right refct */
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
- TclDecrRefCount(objPtr);
- ADJUST_PC(1);
+ TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
+ O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ }
- case INST_LOAD_SCALAR1:
-#ifdef TCL_COMPILE_DEBUG
- opnd = TclGetUInt1AtPtr(pc+1);
- DECACHE_STACK_INFO();
- valuePtr = TclGetIndexedScalar(interp, opnd,
- /*leaveErrorMsg*/ 1);
- CACHE_STACK_INFO();
- if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
- Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
-#else /* TCL_COMPILE_DEBUG */
- DECACHE_STACK_INFO();
- opnd = TclGetUInt1AtPtr(pc+1);
- valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
- CACHE_STACK_INFO();
- if (valuePtr == NULL) {
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(valuePtr);
-#endif /* TCL_COMPILE_DEBUG */
- ADJUST_PC(2);
+ case INST_STR_MATCH:
+ {
+ int nocase, match;
- case INST_LOAD_SCALAR4:
- opnd = TclGetUInt4AtPtr(pc+1);
- DECACHE_STACK_INFO();
- valuePtr = TclGetIndexedScalar(interp, opnd,
- /*leaveErrorMsg*/ 1);
- CACHE_STACK_INFO();
- if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
- Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
- ADJUST_PC(5);
+ nocase = TclGetInt1AtPtr(pc+1);
+ valuePtr = stackPtr[stackTop]; /* String */
+ value2Ptr = stackPtr[stackTop - 1]; /* Pattern */
- case INST_LOAD_SCALAR_STK:
- objPtr = POP_OBJECT(); /* scalar name */
- DECACHE_STACK_INFO();
- valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
- TclDecrRefCount(objPtr);
- ADJUST_PC(1);
-
- case INST_LOAD_ARRAY4:
- opnd = TclGetUInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doLoadArray;
-
- case INST_LOAD_ARRAY1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
-
- doLoadArray:
- {
- Tcl_Obj *elemPtr = POP_OBJECT();
-
- DECACHE_STACK_INFO();
- valuePtr = TclGetElementOfIndexedArray(interp, opnd,
- elemPtr, /*leaveErrorMsg*/ 1);
- CACHE_STACK_INFO();
- if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
- opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("%u \"%.30s\" => ",
- opnd, O2S(elemPtr)),valuePtr);
- TclDecrRefCount(elemPtr);
- }
- ADJUST_PC(pcAdjustment);
+ /*
+ * Check that at least one of the objects is Unicode before
+ * promoting both.
+ */
+ if ((valuePtr->typePtr == &tclStringType)
+ || (value2Ptr->typePtr == &tclStringType)) {
+ match = Tcl_UniCharCaseMatch(Tcl_GetUnicode(valuePtr),
+ Tcl_GetUnicode(value2Ptr), nocase);
+ } else {
+ match = Tcl_StringCaseMatch(TclGetString(valuePtr),
+ TclGetString(value2Ptr), nocase);
+ }
- case INST_LOAD_ARRAY_STK:
- {
- Tcl_Obj *elemPtr = POP_OBJECT();
-
- objPtr = POP_OBJECT(); /* array name */
- DECACHE_STACK_INFO();
- valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
- O2S(objPtr), O2S(elemPtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(elemPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
- O2S(objPtr), O2S(elemPtr)), valuePtr);
- TclDecrRefCount(objPtr);
- TclDecrRefCount(elemPtr);
- }
- ADJUST_PC(1);
+ /*
+ * Reuse value2Ptr object already on stack if possible.
+ * Adjustment is 2 due to the nocase byte
+ */
- case INST_LOAD_STK:
- objPtr = POP_OBJECT(); /* variable name */
- DECACHE_STACK_INFO();
- valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
- O2S(objPtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
- TclDecrRefCount(objPtr);
- ADJUST_PC(1);
-
- case INST_STORE_SCALAR4:
- opnd = TclGetUInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doStoreScalar;
-
- case INST_STORE_SCALAR1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
-
- doStoreScalar:
- valuePtr = POP_OBJECT();
- DECACHE_STACK_INFO();
- value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
- /*leaveErrorMsg*/ 1);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
- opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
- opnd, O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(valuePtr);
- ADJUST_PC(pcAdjustment);
+ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+ if (Tcl_IsShared(value2Ptr)) {
+ objResultPtr = Tcl_NewIntObj(match);
+ NEXT_INST_F(2, 2, 1);
+ } else { /* reuse the valuePtr object */
+ Tcl_SetIntObj(value2Ptr, match);
+ NEXT_INST_F(2, 1, 0);
+ }
+ }
- case INST_STORE_SCALAR_STK:
- valuePtr = POP_OBJECT();
- objPtr = POP_OBJECT(); /* scalar name */
- DECACHE_STACK_INFO();
- value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
- O2S(objPtr), O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
- O2S(objPtr), O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(objPtr);
- TclDecrRefCount(valuePtr);
- ADJUST_PC(1);
+ case INST_EQ:
+ case INST_NEQ:
+ case INST_LT:
+ case INST_GT:
+ case INST_LE:
+ case INST_GE:
+ {
+ /*
+ * Any type is allowed but the two operands must have the
+ * same type. We will compute value op value2.
+ */
- case INST_STORE_ARRAY4:
- opnd = TclGetUInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doStoreArray;
+ Tcl_ObjType *t1Ptr, *t2Ptr;
+ char *s1 = NULL; /* Init. avoids compiler warning. */
+ char *s2 = NULL; /* Init. avoids compiler warning. */
+ long i2 = 0; /* Init. avoids compiler warning. */
+ double d1 = 0.0; /* Init. avoids compiler warning. */
+ double d2 = 0.0; /* Init. avoids compiler warning. */
+ long iResult = 0; /* Init. avoids compiler warning. */
- case INST_STORE_ARRAY1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
-
- doStoreArray:
- {
- Tcl_Obj *elemPtr;
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop - 1];
- valuePtr = POP_OBJECT();
- elemPtr = POP_OBJECT();
- DECACHE_STACK_INFO();
- value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
- elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
- opnd, O2S(elemPtr), O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
- opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(elemPtr);
- TclDecrRefCount(valuePtr);
+ if (valuePtr == value2Ptr) {
+ /*
+ * Optimize the equal object case.
+ */
+ switch (*pc) {
+ case INST_EQ:
+ case INST_LE:
+ case INST_GE:
+ iResult = 1;
+ break;
+ case INST_NEQ:
+ case INST_LT:
+ case INST_GT:
+ iResult = 0;
+ break;
}
- ADJUST_PC(pcAdjustment);
+ goto foundResult;
+ }
- case INST_STORE_ARRAY_STK:
- {
- Tcl_Obj *elemPtr;
+ t1Ptr = valuePtr->typePtr;
+ t2Ptr = value2Ptr->typePtr;
- valuePtr = POP_OBJECT();
- elemPtr = POP_OBJECT();
- objPtr = POP_OBJECT(); /* array name */
- DECACHE_STACK_INFO();
- value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
- O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
+ /*
+ * We only want to coerce numeric validation if neither type
+ * is NULL. A NULL type means the arg is essentially an empty
+ * object ("", {} or [list]).
+ */
+ if (!( (!t1Ptr && !valuePtr->bytes)
+ || (valuePtr->bytes && !valuePtr->length)
+ || (!t2Ptr && !value2Ptr->bytes)
+ || (value2Ptr->bytes && !value2Ptr->length))) {
+ if (!IS_NUMERIC_TYPE(t1Ptr)) {
+ s1 = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s1, length)) {
+ GET_WIDE_OR_INT(iResult, valuePtr, i, w);
+ } else {
+ (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ valuePtr, &d1);
}
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
- O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
- value2Ptr);
- TclDecrRefCount(objPtr);
- TclDecrRefCount(elemPtr);
- TclDecrRefCount(valuePtr);
- }
- ADJUST_PC(1);
-
- case INST_STORE_STK:
- valuePtr = POP_OBJECT();
- objPtr = POP_OBJECT(); /* variable name */
- DECACHE_STACK_INFO();
- value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
- O2S(objPtr), O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
+ t1Ptr = valuePtr->typePtr;
}
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
- O2S(objPtr), O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(objPtr);
- TclDecrRefCount(valuePtr);
- ADJUST_PC(1);
-
- case INST_INCR_SCALAR1:
- opnd = TclGetUInt1AtPtr(pc+1);
- valuePtr = POP_OBJECT();
- if (valuePtr->typePtr != &tclIntType) {
- result = tclIntType.setFromAnyProc(interp, valuePtr);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
- opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
+ if (!IS_NUMERIC_TYPE(t2Ptr)) {
+ s2 = Tcl_GetStringFromObj(value2Ptr, &length);
+ if (TclLooksLikeInt(s2, length)) {
+ GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
+ } else {
+ (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ value2Ptr, &d2);
}
+ t2Ptr = value2Ptr->typePtr;
}
- i = valuePtr->internalRep.longValue;
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
+ }
+ if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
+ /*
+ * One operand is not numeric. Compare as strings. NOTE:
+ * strcmp is not correct for \x00 < \x01, but that is
+ * unlikely to occur here. We could use the TclUtfNCmp2
+ * to handle this.
+ */
+ int s1len, s2len;
+ s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
+ s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
+ switch (*pc) {
+ case INST_EQ:
+ if (s1len == s2len) {
+ iResult = (strcmp(s1, s2) == 0);
+ } else {
+ iResult = 0;
+ }
+ break;
+ case INST_NEQ:
+ if (s1len == s2len) {
+ iResult = (strcmp(s1, s2) != 0);
+ } else {
+ iResult = 1;
+ }
+ break;
+ case INST_LT:
+ iResult = (strcmp(s1, s2) < 0);
+ break;
+ case INST_GT:
+ iResult = (strcmp(s1, s2) > 0);
+ break;
+ case INST_LE:
+ iResult = (strcmp(s1, s2) <= 0);
+ break;
+ case INST_GE:
+ iResult = (strcmp(s1, s2) >= 0);
+ break;
}
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
- TclDecrRefCount(valuePtr);
- ADJUST_PC(2);
-
- case INST_INCR_SCALAR_STK:
- case INST_INCR_STK:
- valuePtr = POP_OBJECT();
- objPtr = POP_OBJECT(); /* scalar name */
- if (valuePtr->typePtr != &tclIntType) {
- result = tclIntType.setFromAnyProc(interp, valuePtr);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
- O2S(objPtr), O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
- }
+ } else if ((t1Ptr == &tclDoubleType)
+ || (t2Ptr == &tclDoubleType)) {
+ /*
+ * Compare as doubles.
+ */
+ if (t1Ptr == &tclDoubleType) {
+ d1 = valuePtr->internalRep.doubleValue;
+ GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
+ } else { /* t1Ptr is integer, t2Ptr is double */
+ GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
+ d2 = value2Ptr->internalRep.doubleValue;
}
- i = valuePtr->internalRep.longValue;
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
- O2S(objPtr), i), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
+ switch (*pc) {
+ case INST_EQ:
+ iResult = d1 == d2;
+ break;
+ case INST_NEQ:
+ iResult = d1 != d2;
+ break;
+ case INST_LT:
+ iResult = d1 < d2;
+ break;
+ case INST_GT:
+ iResult = d1 > d2;
+ break;
+ case INST_LE:
+ iResult = d1 <= d2;
+ break;
+ case INST_GE:
+ iResult = d1 >= d2;
+ break;
}
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
- value2Ptr);
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(valuePtr);
- ADJUST_PC(1);
-
- case INST_INCR_ARRAY1:
- {
- Tcl_Obj *elemPtr;
-
- opnd = TclGetUInt1AtPtr(pc+1);
- valuePtr = POP_OBJECT();
- elemPtr = POP_OBJECT();
- if (valuePtr->typePtr != &tclIntType) {
- result = tclIntType.setFromAnyProc(interp, valuePtr);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
- opnd, O2S(elemPtr), O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
- }
- }
- i = valuePtr->internalRep.longValue;
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
- elemPtr, i);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
- opnd, O2S(elemPtr), i),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
- opnd, O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if ((t1Ptr == &tclWideIntType)
+ || (t2Ptr == &tclWideIntType)) {
+ Tcl_WideInt w2;
+ /*
+ * Compare as wide ints (neither are doubles)
+ */
+ if (t1Ptr == &tclIntType) {
+ w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
+ w2 = value2Ptr->internalRep.wideValue;
+ } else if (t2Ptr == &tclIntType) {
+ w = valuePtr->internalRep.wideValue;
+ w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
+ } else {
+ w = valuePtr->internalRep.wideValue;
+ w2 = value2Ptr->internalRep.wideValue;
}
- ADJUST_PC(2);
-
- case INST_INCR_ARRAY_STK:
- {
- Tcl_Obj *elemPtr;
-
- valuePtr = POP_OBJECT();
- elemPtr = POP_OBJECT();
- objPtr = POP_OBJECT(); /* array name */
- if (valuePtr->typePtr != &tclIntType) {
- result = tclIntType.setFromAnyProc(interp, valuePtr);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
- O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
- }
- }
- i = valuePtr->internalRep.longValue;
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
- O2S(objPtr), O2S(elemPtr), i),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
- O2S(objPtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(elemPtr);
- Tcl_DecrRefCount(valuePtr);
+ switch (*pc) {
+ case INST_EQ:
+ iResult = w == w2;
+ break;
+ case INST_NEQ:
+ iResult = w != w2;
+ break;
+ case INST_LT:
+ iResult = w < w2;
+ break;
+ case INST_GT:
+ iResult = w > w2;
+ break;
+ case INST_LE:
+ iResult = w <= w2;
+ break;
+ case INST_GE:
+ iResult = w >= w2;
+ break;
}
- ADJUST_PC(1);
-
- case INST_INCR_SCALAR1_IMM:
- opnd = TclGetUInt1AtPtr(pc+1);
- i = TclGetInt1AtPtr(pc+2);
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
- Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- goto checkForCatch;
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ /*
+ * Compare as ints.
+ */
+ i = valuePtr->internalRep.longValue;
+ i2 = value2Ptr->internalRep.longValue;
+ switch (*pc) {
+ case INST_EQ:
+ iResult = i == i2;
+ break;
+ case INST_NEQ:
+ iResult = i != i2;
+ break;
+ case INST_LT:
+ iResult = i < i2;
+ break;
+ case INST_GT:
+ iResult = i > i2;
+ break;
+ case INST_LE:
+ iResult = i <= i2;
+ break;
+ case INST_GE:
+ iResult = i >= i2;
+ break;
}
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
- ADJUST_PC(3);
-
- case INST_INCR_SCALAR_STK_IMM:
- case INST_INCR_STK_IMM:
- objPtr = POP_OBJECT(); /* variable name */
- i = TclGetInt1AtPtr(pc+1);
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
- O2S(objPtr), i), Tcl_GetObjResult(interp));
- result = TCL_ERROR;
- Tcl_DecrRefCount(objPtr);
+ }
+
+ foundResult:
+ TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));
+
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump
+ * from here.
+ */
+
+ pc++;
+#ifndef TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_JUMP_FALSE1:
+ NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE1:
+ NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
+ case INST_JUMP_FALSE4:
+ NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
+ case INST_JUMP_TRUE4:
+ NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
+ }
+#endif
+ objResultPtr = Tcl_NewIntObj(iResult);
+ NEXT_INST_F(0, 2, 1);
+ }
+
+ case INST_MOD:
+ case INST_LSHIFT:
+ case INST_RSHIFT:
+ case INST_BITOR:
+ case INST_BITXOR:
+ case INST_BITAND:
+ {
+ /*
+ * Only integers are allowed. We compute value op value2.
+ */
+
+ long i2 = 0, rem, negative;
+ long iResult = 0; /* Init. avoids compiler warning. */
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt w2, wResult = W0;
+ int doWide = 0;
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop - 1];
+ if (valuePtr->typePtr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ w = valuePtr->internalRep.wideValue;
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else { /* try to convert to int */
+ REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
+ if (result != TCL_OK) {
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
+ O2S(valuePtr), O2S(value2Ptr),
+ (valuePtr->typePtr?
+ valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
- value2Ptr);
- TclDecrRefCount(objPtr);
- ADJUST_PC(2);
-
- case INST_INCR_ARRAY1_IMM:
- {
- Tcl_Obj *elemPtr;
-
- opnd = TclGetUInt1AtPtr(pc+1);
- i = TclGetInt1AtPtr(pc+2);
- elemPtr = POP_OBJECT();
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
- elemPtr, i);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
- opnd, O2S(elemPtr), i),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
- opnd, O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(elemPtr);
+ }
+ if (value2Ptr->typePtr == &tclIntType) {
+ i2 = value2Ptr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (value2Ptr->typePtr == &tclWideIntType) {
+ w2 = value2Ptr->internalRep.wideValue;
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
+ if (result != TCL_OK) {
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
+ O2S(valuePtr), O2S(value2Ptr),
+ (value2Ptr->typePtr?
+ value2Ptr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
}
- ADJUST_PC(3);
-
- case INST_INCR_ARRAY_STK_IMM:
- {
- Tcl_Obj *elemPtr;
-
- i = TclGetInt1AtPtr(pc+1);
- elemPtr = POP_OBJECT();
- objPtr = POP_OBJECT(); /* array name */
- DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
- TCL_LEAVE_ERR_MSG);
- CACHE_STACK_INFO();
- if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
- O2S(objPtr), O2S(elemPtr), i),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(elemPtr);
- result = TCL_ERROR;
- goto checkForCatch;
- }
- PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
- O2S(objPtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(objPtr);
- Tcl_DecrRefCount(elemPtr);
+ }
+
+ switch (*pc) {
+ case INST_MOD:
+ /*
+ * This code is tricky: C doesn't guarantee much about
+ * the quotient or remainder, but Tcl does. The
+ * remainder always has the same sign as the divisor and
+ * a smaller absolute value.
+ */
+#ifdef TCL_WIDE_INT_IS_LONG
+ if (i2 == 0) {
+ TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
+ goto divideByZero;
}
- ADJUST_PC(2);
-
- case INST_JUMP1:
-#ifdef TCL_COMPILE_DEBUG
- opnd = TclGetInt1AtPtr(pc+1);
- TRACE(("%d => new pc %u\n", opnd,
- (unsigned int)(pc + opnd - codePtr->codeStart)));
- pc += opnd;
-#else
- pc += TclGetInt1AtPtr(pc+1);
-#endif /* TCL_COMPILE_DEBUG */
- continue;
-
- case INST_JUMP4:
- opnd = TclGetInt4AtPtr(pc+1);
- TRACE(("%d => new pc %u\n", opnd,
- (unsigned int)(pc + opnd - codePtr->codeStart)));
- ADJUST_PC(opnd);
-
- case INST_JUMP_TRUE4:
- opnd = TclGetInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doJumpTrue;
-
- case INST_JUMP_TRUE1:
- opnd = TclGetInt1AtPtr(pc+1);
- pcAdjustment = 2;
-
- doJumpTrue:
- {
- int b;
-
- valuePtr = POP_OBJECT();
+#else /* !TCL_WIDE_INT_IS_LONG */
+ if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
if (valuePtr->typePtr == &tclIntType) {
- b = (valuePtr->internalRep.longValue != 0);
- } else if (valuePtr->typePtr == &tclDoubleType) {
- b = (valuePtr->internalRep.doubleValue != 0.0);
+ LLTRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
} else {
- result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
- }
- }
- if (b) {
- TRACE(("%d => %.20s true, new pc %u\n",
- opnd, O2S(valuePtr),
- (unsigned int)(pc+opnd - codePtr->codeStart)));
- TclDecrRefCount(valuePtr);
- ADJUST_PC(opnd);
- } else {
- TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
- TclDecrRefCount(valuePtr);
- ADJUST_PC(pcAdjustment);
+ LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
}
+ goto divideByZero;
}
-
- case INST_JUMP_FALSE4:
- opnd = TclGetInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doJumpFalse;
-
- case INST_JUMP_FALSE1:
- opnd = TclGetInt1AtPtr(pc+1);
- pcAdjustment = 2;
-
- doJumpFalse:
- {
- int b;
-
- valuePtr = POP_OBJECT();
+ if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
if (valuePtr->typePtr == &tclIntType) {
- b = (valuePtr->internalRep.longValue != 0);
- } else if (valuePtr->typePtr == &tclDoubleType) {
- b = (valuePtr->internalRep.doubleValue != 0.0);
- } else {
- result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
- }
- }
- if (b) {
- TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
- TclDecrRefCount(valuePtr);
- ADJUST_PC(pcAdjustment);
+ TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
} else {
- TRACE(("%d => %.20s false, new pc %u\n",
- opnd, O2S(valuePtr),
- (unsigned int)(pc + opnd - codePtr->codeStart)));
- TclDecrRefCount(valuePtr);
- ADJUST_PC(opnd);
+ LLTRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
}
+ goto divideByZero;
}
-
- case INST_LOR:
- case INST_LAND:
- {
+#endif /* TCL_WIDE_INT_IS_LONG */
+ negative = 0;
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (valuePtr->typePtr == &tclWideIntType
+ || value2Ptr->typePtr == &tclWideIntType) {
+ Tcl_WideInt wRemainder;
/*
- * Operands must be boolean or numeric. No int->double
- * conversions are performed.
+ * Promote to wide
*/
-
- int i1, i2;
- int iResult;
- char *s;
- Tcl_ObjType *t1Ptr, *t2Ptr;
-
- value2Ptr = POP_OBJECT();
- valuePtr = POP_OBJECT();
- t1Ptr = valuePtr->typePtr;
- t2Ptr = value2Ptr->typePtr;
-
- if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
- i1 = (valuePtr->internalRep.longValue != 0);
- } else if (t1Ptr == &tclDoubleType) {
- i1 = (valuePtr->internalRep.doubleValue != 0.0);
- } else {
- s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- i1 = (i != 0);
- } else {
- result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
- valuePtr, &i1);
- i1 = (i1 != 0);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
- O2S(valuePtr),
- (t1Ptr? t1Ptr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto checkForCatch;
- }
+ if (valuePtr->typePtr == &tclIntType) {
+ w = Tcl_LongAsWide(i);
+ } else if (value2Ptr->typePtr == &tclIntType) {
+ w2 = Tcl_LongAsWide(i2);
}
-
- if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
- i2 = (value2Ptr->internalRep.longValue != 0);
- } else if (t2Ptr == &tclDoubleType) {
- i2 = (value2Ptr->internalRep.doubleValue != 0.0);
- } else {
- s = Tcl_GetStringFromObj(value2Ptr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- value2Ptr, &i);
- i2 = (i != 0);
- } else {
- result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
- value2Ptr, &i2);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
- O2S(value2Ptr),
- (t2Ptr? t2Ptr->name : "null")));
- IllegalExprOperandType(interp, pc, value2Ptr);
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto checkForCatch;
- }
+ if (w2 < 0) {
+ w2 = -w2;
+ w = -w;
+ negative = 1;
}
-
- /*
- * Reuse the valuePtr object already on stack if possible.
- */
-
- if (*pc == INST_LOR) {
- iResult = (i1 || i2);
- } else {
- iResult = (i1 && i2);
+ wRemainder = w % w2;
+ if (wRemainder < 0) {
+ wRemainder += w2;
}
- if (Tcl_IsShared(valuePtr)) {
- PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%.20s %.20s => %d\n",
- O2S(valuePtr), O2S(value2Ptr), iResult));
- TclDecrRefCount(valuePtr);
- } else { /* reuse the valuePtr object */
- TRACE(("%.20s %.20s => %d\n",
- O2S(valuePtr), O2S(value2Ptr), iResult));
- Tcl_SetLongObj(valuePtr, iResult);
- ++stackTop; /* valuePtr now on stk top has right r.c. */
+ if (negative) {
+ wRemainder = -wRemainder;
}
- TclDecrRefCount(value2Ptr);
+ wResult = wRemainder;
+ doWide = 1;
+ break;
}
- ADJUST_PC(1);
-
- case INST_EQ:
- case INST_NEQ:
- case INST_LT:
- case INST_GT:
- case INST_LE:
- case INST_GE:
- {
- /*
- * Any type is allowed but the two operands must have the
- * same type. We will compute value op value2.
- */
-
- Tcl_ObjType *t1Ptr, *t2Ptr;
- char *s1 = NULL; /* Init. avoids compiler warning. */
- char *s2 = NULL; /* Init. avoids compiler warning. */
- long i2 = 0; /* Init. avoids compiler warning. */
- double d1 = 0.0; /* Init. avoids compiler warning. */
- double d2 = 0.0; /* Init. avoids compiler warning. */
- long iResult = 0; /* Init. avoids compiler warning. */
-
- value2Ptr = POP_OBJECT();
- valuePtr = POP_OBJECT();
- t1Ptr = valuePtr->typePtr;
- t2Ptr = value2Ptr->typePtr;
-
- /*
- * We only want to coerce numeric validation if
- * neither type is NULL. A NULL type means the arg is
- * essentially an empty object ("", {} or [list]).
- */
- if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL))
- || (valuePtr->bytes && (valuePtr->length == 0)))
- || (((t2Ptr == NULL) && (value2Ptr->bytes == NULL))
- || (value2Ptr->bytes && (value2Ptr->length == 0))))) {
- if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
- s1 = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s1, length)) {
- (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- } else {
- (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d1);
- }
- t1Ptr = valuePtr->typePtr;
- }
- if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
- s2 = Tcl_GetStringFromObj(value2Ptr, &length);
- if (TclLooksLikeInt(s2, length)) {
- (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- value2Ptr, &i2);
- } else {
- (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- value2Ptr, &d2);
- }
- t2Ptr = value2Ptr->typePtr;
- }
- }
- if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
- || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
- /*
- * One operand is not numeric. Compare as strings.
- */
- int cmpValue;
- s1 = Tcl_GetString(valuePtr);
- s2 = Tcl_GetString(value2Ptr);
- cmpValue = strcmp(s1, s2);
- switch (*pc) {
- case INST_EQ:
- iResult = (cmpValue == 0);
- break;
- case INST_NEQ:
- iResult = (cmpValue != 0);
- break;
- case INST_LT:
- iResult = (cmpValue < 0);
- break;
- case INST_GT:
- iResult = (cmpValue > 0);
- break;
- case INST_LE:
- iResult = (cmpValue <= 0);
- break;
- case INST_GE:
- iResult = (cmpValue >= 0);
- break;
- }
- } else if ((t1Ptr == &tclDoubleType)
- || (t2Ptr == &tclDoubleType)) {
- /*
- * Compare as doubles.
- */
- if (t1Ptr == &tclDoubleType) {
- d1 = valuePtr->internalRep.doubleValue;
- if (t2Ptr == &tclIntType) {
- d2 = value2Ptr->internalRep.longValue;
- } else {
- d2 = value2Ptr->internalRep.doubleValue;
- }
- } else { /* t1Ptr is int, t2Ptr is double */
- d1 = valuePtr->internalRep.longValue;
- d2 = value2Ptr->internalRep.doubleValue;
- }
- switch (*pc) {
- case INST_EQ:
- iResult = d1 == d2;
- break;
- case INST_NEQ:
- iResult = d1 != d2;
- break;
- case INST_LT:
- iResult = d1 < d2;
- break;
- case INST_GT:
- iResult = d1 > d2;
- break;
- case INST_LE:
- iResult = d1 <= d2;
- break;
- case INST_GE:
- iResult = d1 >= d2;
- break;
- }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ if (i2 < 0) {
+ i2 = -i2;
+ i = -i;
+ negative = 1;
+ }
+ rem = i % i2;
+ if (rem < 0) {
+ rem += i2;
+ }
+ if (negative) {
+ rem = -rem;
+ }
+ iResult = rem;
+ break;
+ case INST_LSHIFT:
+#ifndef TCL_WIDE_INT_IS_LONG
+ /*
+ * Shifts are never usefully 64-bits wide!
+ */
+ FORCE_LONG(value2Ptr, i2, w2);
+ if (valuePtr->typePtr == &tclWideIntType) {
+#ifdef TCL_COMPILE_DEBUG
+ w2 = Tcl_LongAsWide(i2);
+#endif /* TCL_COMPILE_DEBUG */
+ wResult = w << i2;
+ doWide = 1;
+ break;
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ iResult = i << i2;
+ break;
+ case INST_RSHIFT:
+ /*
+ * The following code is a bit tricky: it ensures that
+ * right shifts propagate the sign bit even on machines
+ * where ">>" won't do it by default.
+ */
+#ifndef TCL_WIDE_INT_IS_LONG
+ /*
+ * Shifts are never usefully 64-bits wide!
+ */
+ FORCE_LONG(value2Ptr, i2, w2);
+ if (valuePtr->typePtr == &tclWideIntType) {
+#ifdef TCL_COMPILE_DEBUG
+ w2 = Tcl_LongAsWide(i2);
+#endif /* TCL_COMPILE_DEBUG */
+ if (w < 0) {
+ wResult = ~((~w) >> i2);
} else {
- /*
- * Compare as ints.
- */
- i = valuePtr->internalRep.longValue;
- i2 = value2Ptr->internalRep.longValue;
- switch (*pc) {
- case INST_EQ:
- iResult = i == i2;
- break;
- case INST_NEQ:
- iResult = i != i2;
- break;
- case INST_LT:
- iResult = i < i2;
- break;
- case INST_GT:
- iResult = i > i2;
- break;
- case INST_LE:
- iResult = i <= i2;
- break;
- case INST_GE:
- iResult = i >= i2;
- break;
- }
+ wResult = w >> i2;
}
-
+ doWide = 1;
+ break;
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ if (i < 0) {
+ iResult = ~((~i) >> i2);
+ } else {
+ iResult = i >> i2;
+ }
+ break;
+ case INST_BITOR:
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (valuePtr->typePtr == &tclWideIntType
+ || value2Ptr->typePtr == &tclWideIntType) {
/*
- * Reuse the valuePtr object already on stack if possible.
+ * Promote to wide
*/
-
- if (Tcl_IsShared(valuePtr)) {
- PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%.20s %.20s => %ld\n",
- O2S(valuePtr), O2S(value2Ptr), iResult));
- TclDecrRefCount(valuePtr);
- } else { /* reuse the valuePtr object */
- TRACE(("%.20s %.20s => %ld\n",
- O2S(valuePtr), O2S(value2Ptr), iResult));
- Tcl_SetLongObj(valuePtr, iResult);
- ++stackTop; /* valuePtr now on stk top has right r.c. */
+ if (valuePtr->typePtr == &tclIntType) {
+ w = Tcl_LongAsWide(i);
+ } else if (value2Ptr->typePtr == &tclIntType) {
+ w2 = Tcl_LongAsWide(i2);
}
- TclDecrRefCount(value2Ptr);
+ wResult = w | w2;
+ doWide = 1;
+ break;
}
- ADJUST_PC(1);
-
- case INST_MOD:
- case INST_LSHIFT:
- case INST_RSHIFT:
- case INST_BITOR:
+#endif /* TCL_WIDE_INT_IS_LONG */
+ iResult = i | i2;
+ break;
case INST_BITXOR:
- case INST_BITAND:
- {
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (valuePtr->typePtr == &tclWideIntType
+ || value2Ptr->typePtr == &tclWideIntType) {
/*
- * Only integers are allowed. We compute value op value2.
+ * Promote to wide
*/
-
- long i2, rem, negative;
- long iResult = 0; /* Init. avoids compiler warning. */
-
- value2Ptr = POP_OBJECT();
- valuePtr = POP_OBJECT();
if (valuePtr->typePtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- } else { /* try to convert to int */
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- if (result != TCL_OK) {
- TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
- O2S(valuePtr), O2S(value2Ptr),
- (valuePtr->typePtr?
- valuePtr->typePtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto checkForCatch;
- }
+ w = Tcl_LongAsWide(i);
+ } else if (value2Ptr->typePtr == &tclIntType) {
+ w2 = Tcl_LongAsWide(i2);
}
- if (value2Ptr->typePtr == &tclIntType) {
- i2 = value2Ptr->internalRep.longValue;
- } else {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- value2Ptr, &i2);
- if (result != TCL_OK) {
- TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
- O2S(valuePtr), O2S(value2Ptr),
- (value2Ptr->typePtr?
- value2Ptr->typePtr->name : "null")));
- IllegalExprOperandType(interp, pc, value2Ptr);
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto checkForCatch;
- }
+ wResult = w ^ w2;
+ doWide = 1;
+ break;
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ iResult = i ^ i2;
+ break;
+ case INST_BITAND:
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (valuePtr->typePtr == &tclWideIntType
+ || value2Ptr->typePtr == &tclWideIntType) {
+ /*
+ * Promote to wide
+ */
+ if (valuePtr->typePtr == &tclIntType) {
+ w = Tcl_LongAsWide(i);
+ } else if (value2Ptr->typePtr == &tclIntType) {
+ w2 = Tcl_LongAsWide(i2);
}
+ wResult = w & w2;
+ doWide = 1;
+ break;
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ iResult = i & i2;
+ break;
+ }
- switch (*pc) {
- case INST_MOD:
- /*
- * This code is tricky: C doesn't guarantee much about
- * the quotient or remainder, but Tcl does. The
- * remainder always has the same sign as the divisor and
- * a smaller absolute value.
- */
- if (i2 == 0) {
- TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto divideByZero;
- }
- negative = 0;
- if (i2 < 0) {
- i2 = -i2;
- i = -i;
- negative = 1;
- }
- rem = i % i2;
- if (rem < 0) {
- rem += i2;
- }
- if (negative) {
- rem = -rem;
- }
- iResult = rem;
+ /*
+ * Reuse the valuePtr object already on stack if possible.
+ */
+
+ if (Tcl_IsShared(valuePtr)) {
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (doWide) {
+ objResultPtr = Tcl_NewWideIntObj(wResult);
+ LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
+ } else {
+#endif /* TCL_WIDE_INT_IS_LONG */
+ objResultPtr = Tcl_NewLongObj(iResult);
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
+#ifndef TCL_WIDE_INT_IS_LONG
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ NEXT_INST_F(1, 2, 1);
+ } else { /* reuse the valuePtr object */
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (doWide) {
+ LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
+ Tcl_SetWideIntObj(valuePtr, wResult);
+ } else {
+#endif /* TCL_WIDE_INT_IS_LONG */
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
+ Tcl_SetLongObj(valuePtr, iResult);
+#ifndef TCL_WIDE_INT_IS_LONG
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ NEXT_INST_F(1, 1, 0);
+ }
+ }
+
+ case INST_ADD:
+ case INST_SUB:
+ case INST_MULT:
+ case INST_DIV:
+ {
+ /*
+ * Operands must be numeric and ints get converted to floats
+ * if necessary. We compute value op value2.
+ */
+
+ Tcl_ObjType *t1Ptr, *t2Ptr;
+ long i2 = 0, quot, rem; /* Init. avoids compiler warning. */
+ double d1, d2;
+ long iResult = 0; /* Init. avoids compiler warning. */
+ double dResult = 0.0; /* Init. avoids compiler warning. */
+ int doDouble = 0; /* 1 if doing floating arithmetic */
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt w2, wquot, wrem;
+ Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
+ int doWide = 0; /* 1 if doing wide arithmetic. */
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+ value2Ptr = stackPtr[stackTop];
+ valuePtr = stackPtr[stackTop - 1];
+ t1Ptr = valuePtr->typePtr;
+ t2Ptr = value2Ptr->typePtr;
+
+ if (t1Ptr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (t1Ptr == &tclWideIntType) {
+ w = valuePtr->internalRep.wideValue;
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else if ((t1Ptr == &tclDoubleType)
+ && (valuePtr->bytes == NULL)) {
+ /*
+ * We can only use the internal rep directly if there is
+ * no string rep. Otherwise the string rep might actually
+ * look like an integer, which is preferred.
+ */
+
+ d1 = valuePtr->internalRep.doubleValue;
+ } else {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
+ GET_WIDE_OR_INT(result, valuePtr, i, w);
+ } else {
+ result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ valuePtr, &d1);
+ }
+ if (result != TCL_OK) {
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
+ s, O2S(valuePtr),
+ (valuePtr->typePtr?
+ valuePtr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ t1Ptr = valuePtr->typePtr;
+ }
+
+ if (t2Ptr == &tclIntType) {
+ i2 = value2Ptr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (t2Ptr == &tclWideIntType) {
+ w2 = value2Ptr->internalRep.wideValue;
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else if ((t2Ptr == &tclDoubleType)
+ && (value2Ptr->bytes == NULL)) {
+ /*
+ * We can only use the internal rep directly if there is
+ * no string rep. Otherwise the string rep might actually
+ * look like an integer, which is preferred.
+ */
+
+ d2 = value2Ptr->internalRep.doubleValue;
+ } else {
+ char *s = Tcl_GetStringFromObj(value2Ptr, &length);
+ if (TclLooksLikeInt(s, length)) {
+ GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
+ } else {
+ result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ value2Ptr, &d2);
+ }
+ if (result != TCL_OK) {
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
+ O2S(value2Ptr), s,
+ (value2Ptr->typePtr?
+ value2Ptr->typePtr->name : "null")));
+ IllegalExprOperandType(interp, pc, value2Ptr);
+ goto checkForCatch;
+ }
+ t2Ptr = value2Ptr->typePtr;
+ }
+
+ if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
+ /*
+ * Do double arithmetic.
+ */
+ doDouble = 1;
+ if (t1Ptr == &tclIntType) {
+ d1 = i; /* promote value 1 to double */
+ } else if (t2Ptr == &tclIntType) {
+ d2 = i2; /* promote value 2 to double */
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (t1Ptr == &tclWideIntType) {
+ d1 = Tcl_WideAsDouble(w);
+ } else if (t2Ptr == &tclWideIntType) {
+ d2 = Tcl_WideAsDouble(w2);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ }
+ switch (*pc) {
+ case INST_ADD:
+ dResult = d1 + d2;
break;
- case INST_LSHIFT:
- iResult = i << i2;
+ case INST_SUB:
+ dResult = d1 - d2;
break;
- case INST_RSHIFT:
- /*
- * The following code is a bit tricky: it ensures that
- * right shifts propagate the sign bit even on machines
- * where ">>" won't do it by default.
- */
- if (i < 0) {
- iResult = ~((~i) >> i2);
- } else {
- iResult = i >> i2;
+ case INST_MULT:
+ dResult = d1 * d2;
+ break;
+ case INST_DIV:
+ if (d2 == 0.0) {
+ TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
+ goto divideByZero;
}
+ dResult = d1 / d2;
break;
- case INST_BITOR:
- iResult = i | i2;
+ }
+
+ /*
+ * Check now for IEEE floating-point error.
+ */
+
+ if (IS_NAN(dResult) || IS_INF(dResult)) {
+ TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
+ O2S(valuePtr), O2S(value2Ptr)));
+ TclExprFloatError(interp, dResult);
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if ((t1Ptr == &tclWideIntType)
+ || (t2Ptr == &tclWideIntType)) {
+ /*
+ * Do wide integer arithmetic.
+ */
+ doWide = 1;
+ if (t1Ptr == &tclIntType) {
+ w = Tcl_LongAsWide(i);
+ } else if (t2Ptr == &tclIntType) {
+ w2 = Tcl_LongAsWide(i2);
+ }
+ switch (*pc) {
+ case INST_ADD:
+ wResult = w + w2;
break;
- case INST_BITXOR:
- iResult = i ^ i2;
+ case INST_SUB:
+ wResult = w - w2;
break;
- case INST_BITAND:
- iResult = i & i2;
+ case INST_MULT:
+ wResult = w * w2;
break;
- }
-
- /*
- * Reuse the valuePtr object already on stack if possible.
- */
-
- if (Tcl_IsShared(valuePtr)) {
- PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%ld %ld => %ld\n", i, i2, iResult));
- TclDecrRefCount(valuePtr);
- } else { /* reuse the valuePtr object */
- TRACE(("%ld %ld => %ld\n", i, i2, iResult));
- Tcl_SetLongObj(valuePtr, iResult);
- ++stackTop; /* valuePtr now on stk top has right r.c. */
- }
- TclDecrRefCount(value2Ptr);
- }
- ADJUST_PC(1);
-
- case INST_ADD:
- case INST_SUB:
- case INST_MULT:
- case INST_DIV:
- {
- /*
- * Operands must be numeric and ints get converted to floats
- * if necessary. We compute value op value2.
- */
-
- Tcl_ObjType *t1Ptr, *t2Ptr;
- long i2, quot, rem;
- double d1, d2;
- long iResult = 0; /* Init. avoids compiler warning. */
- double dResult = 0.0; /* Init. avoids compiler warning. */
- int doDouble = 0; /* 1 if doing floating arithmetic */
-
- value2Ptr = POP_OBJECT();
- valuePtr = POP_OBJECT();
- t1Ptr = valuePtr->typePtr;
- t2Ptr = value2Ptr->typePtr;
-
- if (t1Ptr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- } else if ((t1Ptr == &tclDoubleType)
- && (valuePtr->bytes == NULL)) {
+ case INST_DIV:
/*
- * We can only use the internal rep directly if there is
- * no string rep. Otherwise the string rep might actually
- * look like an integer, which is preferred.
+ * This code is tricky: C doesn't guarantee much
+ * about the quotient or remainder, but Tcl does.
+ * The remainder always has the same sign as the
+ * divisor and a smaller absolute value.
*/
-
- d1 = valuePtr->internalRep.doubleValue;
- } else {
- char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d1);
- }
- if (result != TCL_OK) {
- TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
- s, O2S(valuePtr),
- (valuePtr->typePtr?
- valuePtr->typePtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto checkForCatch;
+ if (w2 == W0) {
+ LLTRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
+ goto divideByZero;
}
- t1Ptr = valuePtr->typePtr;
- }
-
- if (t2Ptr == &tclIntType) {
- i2 = value2Ptr->internalRep.longValue;
- } else if ((t2Ptr == &tclDoubleType)
- && (value2Ptr->bytes == NULL)) {
- /*
- * We can only use the internal rep directly if there is
- * no string rep. Otherwise the string rep might actually
- * look like an integer, which is preferred.
- */
-
- d2 = value2Ptr->internalRep.doubleValue;
- } else {
- char *s = Tcl_GetStringFromObj(value2Ptr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- value2Ptr, &i2);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- value2Ptr, &d2);
+ if (w2 < 0) {
+ w2 = -w2;
+ w = -w;
}
- if (result != TCL_OK) {
- TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
- O2S(value2Ptr), s,
- (value2Ptr->typePtr?
- value2Ptr->typePtr->name : "null")));
- IllegalExprOperandType(interp, pc, value2Ptr);
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto checkForCatch;
+ wquot = w / w2;
+ wrem = w % w2;
+ if (wrem < W0) {
+ wquot -= 1;
}
- t2Ptr = value2Ptr->typePtr;
- }
-
- if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
+ wResult = wquot;
+ break;
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ /*
+ * Do integer arithmetic.
+ */
+ switch (*pc) {
+ case INST_ADD:
+ iResult = i + i2;
+ break;
+ case INST_SUB:
+ iResult = i - i2;
+ break;
+ case INST_MULT:
+ iResult = i * i2;
+ break;
+ case INST_DIV:
/*
- * Do double arithmetic.
+ * This code is tricky: C doesn't guarantee much
+ * about the quotient or remainder, but Tcl does.
+ * The remainder always has the same sign as the
+ * divisor and a smaller absolute value.
*/
- doDouble = 1;
- if (t1Ptr == &tclIntType) {
- d1 = i; /* promote value 1 to double */
- } else if (t2Ptr == &tclIntType) {
- d2 = i2; /* promote value 2 to double */
- }
- switch (*pc) {
- case INST_ADD:
- dResult = d1 + d2;
- break;
- case INST_SUB:
- dResult = d1 - d2;
- break;
- case INST_MULT:
- dResult = d1 * d2;
- break;
- case INST_DIV:
- if (d2 == 0.0) {
- TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto divideByZero;
- }
- dResult = d1 / d2;
- break;
+ if (i2 == 0) {
+ TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
+ goto divideByZero;
}
-
- /*
- * Check now for IEEE floating-point error.
- */
-
- if (IS_NAN(dResult) || IS_INF(dResult)) {
- TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
- O2S(valuePtr), O2S(value2Ptr)));
- TclExprFloatError(interp, dResult);
- result = TCL_ERROR;
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto checkForCatch;
+ if (i2 < 0) {
+ i2 = -i2;
+ i = -i;
}
- } else {
- /*
- * Do integer arithmetic.
- */
- switch (*pc) {
- case INST_ADD:
- iResult = i + i2;
- break;
- case INST_SUB:
- iResult = i - i2;
- break;
- case INST_MULT:
- iResult = i * i2;
- break;
- case INST_DIV:
- /*
- * This code is tricky: C doesn't guarantee much
- * about the quotient or remainder, but Tcl does.
- * The remainder always has the same sign as the
- * divisor and a smaller absolute value.
- */
- if (i2 == 0) {
- TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
- goto divideByZero;
- }
- if (i2 < 0) {
- i2 = -i2;
- i = -i;
- }
- quot = i / i2;
- rem = i % i2;
- if (rem < 0) {
- quot -= 1;
- }
- iResult = quot;
- break;
+ quot = i / i2;
+ rem = i % i2;
+ if (rem < 0) {
+ quot -= 1;
}
- }
+ iResult = quot;
+ break;
+ }
+ }
- /*
- * Reuse the valuePtr object already on stack if possible.
- */
+ /*
+ * Reuse the valuePtr object already on stack if possible.
+ */
- if (Tcl_IsShared(valuePtr)) {
- if (doDouble) {
- PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
- TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
- } else {
- PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%ld %ld => %ld\n", i, i2, iResult));
- }
- TclDecrRefCount(valuePtr);
- } else { /* reuse the valuePtr object */
- if (doDouble) { /* NB: stack top is off by 1 */
- TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
- Tcl_SetDoubleObj(valuePtr, dResult);
- } else {
- TRACE(("%ld %ld => %ld\n", i, i2, iResult));
- Tcl_SetLongObj(valuePtr, iResult);
- }
- ++stackTop; /* valuePtr now on stk top has right r.c. */
- }
- TclDecrRefCount(value2Ptr);
+ if (Tcl_IsShared(valuePtr)) {
+ if (doDouble) {
+ objResultPtr = Tcl_NewDoubleObj(dResult);
+ TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (doWide) {
+ objResultPtr = Tcl_NewWideIntObj(wResult);
+ LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ objResultPtr = Tcl_NewLongObj(iResult);
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
+ }
+ NEXT_INST_F(1, 2, 1);
+ } else { /* reuse the valuePtr object */
+ if (doDouble) { /* NB: stack top is off by 1 */
+ TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
+ Tcl_SetDoubleObj(valuePtr, dResult);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (doWide) {
+ LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
+ Tcl_SetWideIntObj(valuePtr, wResult);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
+ Tcl_SetLongObj(valuePtr, iResult);
}
- ADJUST_PC(1);
-
- case INST_UPLUS:
- {
- /*
- * Operand must be numeric.
- */
-
- double d;
- Tcl_ObjType *tPtr;
+ NEXT_INST_F(1, 1, 0);
+ }
+ }
+
+ case INST_UPLUS:
+ {
+ /*
+ * Operand must be numeric.
+ */
+
+ double d;
+ Tcl_ObjType *tPtr;
- valuePtr = stackPtr[stackTop];
- tPtr = valuePtr->typePtr;
- if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
- || (valuePtr->bytes != NULL))) {
- char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
- s, (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- goto checkForCatch;
- }
- tPtr = valuePtr->typePtr;
- }
+ valuePtr = stackPtr[stackTop];
+ tPtr = valuePtr->typePtr;
+ if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
+ || (valuePtr->bytes != NULL))) {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
+ GET_WIDE_OR_INT(result, valuePtr, i, w);
+ } else {
+ result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
+ }
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
+ s, (tPtr? tPtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ tPtr = valuePtr->typePtr;
+ }
- /*
- * Ensure that the operand's string rep is the same as the
- * formatted version of its internal rep. This makes sure
- * that "expr +000123" yields "83", not "000123". We
- * implement this by _discarding_ the string rep since we
- * know it will be regenerated, if needed later, by
- * formatting the internal rep's value.
- */
+ /*
+ * Ensure that the operand's string rep is the same as the
+ * formatted version of its internal rep. This makes sure
+ * that "expr +000123" yields "83", not "000123". We
+ * implement this by _discarding_ the string rep since we
+ * know it will be regenerated, if needed later, by
+ * formatting the internal rep's value.
+ */
- if (Tcl_IsShared(valuePtr)) {
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- objPtr = Tcl_NewLongObj(i);
- } else {
- d = valuePtr->internalRep.doubleValue;
- objPtr = Tcl_NewDoubleObj(d);
- }
- Tcl_IncrRefCount(objPtr);
- Tcl_DecrRefCount(valuePtr);
- valuePtr = objPtr;
- stackPtr[stackTop] = valuePtr;
+ if (Tcl_IsShared(valuePtr)) {
+ if (tPtr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+ objResultPtr = Tcl_NewLongObj(i);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (tPtr == &tclWideIntType) {
+ w = valuePtr->internalRep.wideValue;
+ objResultPtr = Tcl_NewWideIntObj(w);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ objResultPtr = Tcl_NewDoubleObj(d);
+ }
+ TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ Tcl_InvalidateStringRep(valuePtr);
+ TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
+ NEXT_INST_F(1, 0, 0);
+ }
+ }
+
+ case INST_UMINUS:
+ case INST_LNOT:
+ {
+ /*
+ * The operand must be numeric or a boolean string as
+ * accepted by Tcl_GetBooleanFromObj(). If the operand
+ * object is unshared modify it directly, otherwise
+ * create a copy to modify: this is "copy on write".
+ * Free any old string representation since it is now
+ * invalid.
+ */
+
+ double d;
+ int boolvar;
+ Tcl_ObjType *tPtr;
+
+ valuePtr = stackPtr[stackTop];
+ tPtr = valuePtr->typePtr;
+ if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
+ || (valuePtr->bytes != NULL))) {
+ if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
+ valuePtr->typePtr = &tclIntType;
+ } else {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
+ GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
- Tcl_InvalidateStringRep(valuePtr);
+ result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ valuePtr, &d);
+ }
+ if (result == TCL_ERROR && *pc == INST_LNOT) {
+ result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
+ valuePtr, &boolvar);
+ i = (long)boolvar; /* i is long, not int! */
+ }
+ if (result != TCL_OK) {
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
+ s, (tPtr? tPtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
}
- TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
}
- ADJUST_PC(1);
-
- case INST_UMINUS:
- case INST_LNOT:
- {
- /*
- * The operand must be numeric. If the operand object is
- * unshared modify it directly, otherwise create a copy to
- * modify: this is "copy on write". free any old string
- * representation since it is now invalid.
- */
-
- double d;
- Tcl_ObjType *tPtr;
-
- valuePtr = POP_OBJECT();
- tPtr = valuePtr->typePtr;
- if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
- || (valuePtr->bytes != NULL))) {
- if ((tPtr == &tclBooleanType)
- && (valuePtr->bytes == NULL)) {
- valuePtr->typePtr = &tclIntType;
- } else {
- char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d);
- }
- if (result != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
- s, (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
- }
- }
- tPtr = valuePtr->typePtr;
+ tPtr = valuePtr->typePtr;
+ }
+
+ if (Tcl_IsShared(valuePtr)) {
+ /*
+ * Create a new object.
+ */
+ if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
+ i = valuePtr->internalRep.longValue;
+ objResultPtr = Tcl_NewLongObj(
+ (*pc == INST_UMINUS)? -i : !i);
+ TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (tPtr == &tclWideIntType) {
+ w = valuePtr->internalRep.wideValue;
+ if (*pc == INST_UMINUS) {
+ objResultPtr = Tcl_NewWideIntObj(-w);
+ } else {
+ objResultPtr = Tcl_NewLongObj(w == W0);
}
-
- if (Tcl_IsShared(valuePtr)) {
- /*
- * Create a new object.
- */
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- objPtr = Tcl_NewLongObj(
- (*pc == INST_UMINUS)? -i : !i);
- TRACE_WITH_OBJ(("%ld => ", i), objPtr);
- } else {
- d = valuePtr->internalRep.doubleValue;
- if (*pc == INST_UMINUS) {
- objPtr = Tcl_NewDoubleObj(-d);
- } else {
- /*
- * Should be able to use "!d", but apparently
- * some compilers can't handle it.
- */
- objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
- }
- TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
- }
- PUSH_OBJECT(objPtr);
- TclDecrRefCount(valuePtr);
+ LLTRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ if (*pc == INST_UMINUS) {
+ objResultPtr = Tcl_NewDoubleObj(-d);
} else {
/*
- * valuePtr is unshared. Modify it directly.
+ * Should be able to use "!d", but apparently
+ * some compilers can't handle it.
*/
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- Tcl_SetLongObj(valuePtr,
- (*pc == INST_UMINUS)? -i : !i);
- TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
- } else {
- d = valuePtr->internalRep.doubleValue;
- if (*pc == INST_UMINUS) {
- Tcl_SetDoubleObj(valuePtr, -d);
- } else {
- /*
- * Should be able to use "!d", but apparently
- * some compilers can't handle it.
- */
- Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
- }
- TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
- }
- ++stackTop; /* valuePtr now on stk top has right r.c. */
+ objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
}
+ TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
}
- ADJUST_PC(1);
-
- case INST_BITNOT:
- {
- /*
- * The operand must be an integer. If the operand object is
- * unshared modify it directly, otherwise modify a copy.
- * Free any old string representation since it is now
- * invalid.
- */
-
- Tcl_ObjType *tPtr;
-
- valuePtr = POP_OBJECT();
- tPtr = valuePtr->typePtr;
- if (tPtr != &tclIntType) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- if (result != TCL_OK) { /* try to convert to double */
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
- O2S(valuePtr), (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, pc, valuePtr);
- Tcl_DecrRefCount(valuePtr);
- goto checkForCatch;
- }
- }
-
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ /*
+ * valuePtr is unshared. Modify it directly.
+ */
+ if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
- if (Tcl_IsShared(valuePtr)) {
- PUSH_OBJECT(Tcl_NewLongObj(~i));
- TRACE(("0x%lx => (%lu)\n", i, ~i));
- TclDecrRefCount(valuePtr);
+ Tcl_SetLongObj(valuePtr,
+ (*pc == INST_UMINUS)? -i : !i);
+ TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (tPtr == &tclWideIntType) {
+ w = valuePtr->internalRep.wideValue;
+ if (*pc == INST_UMINUS) {
+ Tcl_SetWideIntObj(valuePtr, -w);
+ } else {
+ Tcl_SetLongObj(valuePtr, w == W0);
+ }
+ LLTRACE_WITH_OBJ((LLD" => ", w), valuePtr);
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ if (*pc == INST_UMINUS) {
+ Tcl_SetDoubleObj(valuePtr, -d);
} else {
/*
- * valuePtr is unshared. Modify it directly.
+ * Should be able to use "!d", but apparently
+ * some compilers can't handle it.
*/
- Tcl_SetLongObj(valuePtr, ~i);
- ++stackTop; /* valuePtr now on stk top has right r.c. */
- TRACE(("0x%lx => (%lu)\n", i, ~i));
+ Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
}
+ TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
}
- ADJUST_PC(1);
-
- case INST_CALL_BUILTIN_FUNC1:
- opnd = TclGetUInt1AtPtr(pc+1);
- {
+ NEXT_INST_F(1, 0, 0);
+ }
+ }
+
+ case INST_BITNOT:
+ {
+ /*
+ * The operand must be an integer. If the operand object is
+ * unshared modify it directly, otherwise modify a copy.
+ * Free any old string representation since it is now
+ * invalid.
+ */
+
+ Tcl_ObjType *tPtr;
+
+ valuePtr = stackPtr[stackTop];
+ tPtr = valuePtr->typePtr;
+ if (!IS_INTEGER_TYPE(tPtr)) {
+ REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
+ if (result != TCL_OK) { /* try to convert to double */
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
+ O2S(valuePtr), (tPtr? tPtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
+ goto checkForCatch;
+ }
+ }
+
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (valuePtr->typePtr == &tclWideIntType) {
+ w = valuePtr->internalRep.wideValue;
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewWideIntObj(~w);
+ LLTRACE(("0x%llx => (%llu)\n", w, ~w));
+ NEXT_INST_F(1, 1, 1);
+ } else {
/*
- * Call one of the built-in Tcl math functions.
+ * valuePtr is unshared. Modify it directly.
*/
+ Tcl_SetWideIntObj(valuePtr, ~w);
+ LLTRACE(("0x%llx => (%llu)\n", w, ~w));
+ NEXT_INST_F(1, 0, 0);
+ }
+ } else {
+#endif /* TCL_WIDE_INT_IS_LONG */
+ i = valuePtr->internalRep.longValue;
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewLongObj(~i);
+ TRACE(("0x%lx => (%lu)\n", i, ~i));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ /*
+ * valuePtr is unshared. Modify it directly.
+ */
+ Tcl_SetLongObj(valuePtr, ~i);
+ TRACE(("0x%lx => (%lu)\n", i, ~i));
+ NEXT_INST_F(1, 0, 0);
+ }
+#ifndef TCL_WIDE_INT_IS_LONG
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ }
- BuiltinFunc *mathFuncPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ case INST_CALL_BUILTIN_FUNC1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ {
+ /*
+ * Call one of the built-in Tcl math functions.
+ */
- if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
- TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
- panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
- }
- mathFuncPtr = &(builtinFuncTable[opnd]);
- DECACHE_STACK_INFO();
- tsdPtr->mathInProgress++;
- result = (*mathFuncPtr->proc)(interp, eePtr,
- mathFuncPtr->clientData);
- tsdPtr->mathInProgress--;
- CACHE_STACK_INFO();
- if (result != TCL_OK) {
- goto checkForCatch;
- }
- TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
+ BuiltinFunc *mathFuncPtr;
+
+ if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
+ TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
+ panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
}
- ADJUST_PC(2);
+ mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
+ DECACHE_STACK_INFO();
+ result = (*mathFuncPtr->proc)(interp, eePtr,
+ mathFuncPtr->clientData);
+ CACHE_STACK_INFO();
+ if (result != TCL_OK) {
+ goto checkForCatch;
+ }
+ TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
+ }
+ NEXT_INST_F(2, 0, 0);
- case INST_CALL_FUNC1:
- opnd = TclGetUInt1AtPtr(pc+1);
- {
- /*
- * Call a non-builtin Tcl math function previously
- * registered by a call to Tcl_CreateMathFunc.
- */
+ case INST_CALL_FUNC1:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ {
+ /*
+ * Call a non-builtin Tcl math function previously
+ * registered by a call to Tcl_CreateMathFunc.
+ */
- int objc = opnd; /* Number of arguments. The function name
- * is the 0-th argument. */
- Tcl_Obj **objv; /* The array of arguments. The function
- * name is objv[0]. */
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
- DECACHE_STACK_INFO();
- tsdPtr->mathInProgress++;
- result = ExprCallMathFunc(interp, eePtr, objc, objv);
- tsdPtr->mathInProgress--;
- CACHE_STACK_INFO();
- if (result != TCL_OK) {
- goto checkForCatch;
- }
- TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
- ADJUST_PC(2);
+ int objc = opnd; /* Number of arguments. The function name
+ * is the 0-th argument. */
+ Tcl_Obj **objv; /* The array of arguments. The function
+ * name is objv[0]. */
+
+ objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
+ DECACHE_STACK_INFO();
+ result = ExprCallMathFunc(interp, eePtr, objc, objv);
+ CACHE_STACK_INFO();
+ if (result != TCL_OK) {
+ goto checkForCatch;
}
+ TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
+ }
+ NEXT_INST_F(2, 0, 0);
- case INST_TRY_CVT_TO_NUMERIC:
- {
- /*
- * Try to convert the topmost stack object to an int or
- * double object. This is done in order to support Tcl's
- * policy of interpreting operands if at all possible as
- * first integers, else floating-point numbers.
- */
+ case INST_TRY_CVT_TO_NUMERIC:
+ {
+ /*
+ * Try to convert the topmost stack object to an int or
+ * double object. This is done in order to support Tcl's
+ * policy of interpreting operands if at all possible as
+ * first integers, else floating-point numbers.
+ */
- double d;
- char *s;
- Tcl_ObjType *tPtr;
- int converted, shared;
-
- valuePtr = stackPtr[stackTop];
- tPtr = valuePtr->typePtr;
- converted = 0;
- if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
- || (valuePtr->bytes != NULL))) {
- if ((tPtr == &tclBooleanType)
- && (valuePtr->bytes == NULL)) {
- valuePtr->typePtr = &tclIntType;
- converted = 1;
- } else {
- s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s, length)) {
- result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
- valuePtr, &i);
- } else {
- result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
- valuePtr, &d);
- }
- if (result == TCL_OK) {
- converted = 1;
- }
- result = TCL_OK; /* reset the result variable */
- }
- tPtr = valuePtr->typePtr;
+ double d;
+ char *s;
+ Tcl_ObjType *tPtr;
+ int converted, needNew;
+
+ valuePtr = stackPtr[stackTop];
+ tPtr = valuePtr->typePtr;
+ converted = 0;
+ if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
+ || (valuePtr->bytes != NULL))) {
+ if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
+ valuePtr->typePtr = &tclIntType;
+ converted = 1;
+ } else {
+ s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
+ GET_WIDE_OR_INT(result, valuePtr, i, w);
+ } else {
+ result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
+ valuePtr, &d);
}
+ if (result == TCL_OK) {
+ converted = 1;
+ }
+ result = TCL_OK; /* reset the result variable */
+ }
+ tPtr = valuePtr->typePtr;
+ }
- /*
- * Ensure that the topmost stack object, if numeric, has a
- * string rep the same as the formatted version of its
- * internal rep. This is used, e.g., to make sure that "expr
- * {0001}" yields "1", not "0001". We implement this by
- * _discarding_ the string rep since we know it will be
- * regenerated, if needed later, by formatting the internal
- * rep's value. Also check if there has been an IEEE
- * floating point error.
- */
-
- if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) {
- shared = 0;
- if (Tcl_IsShared(valuePtr)) {
- shared = 1;
- if (valuePtr->bytes != NULL) {
- /*
- * We only need to make a copy of the object
- * when it already had a string rep
- */
- if (tPtr == &tclIntType) {
- i = valuePtr->internalRep.longValue;
- objPtr = Tcl_NewLongObj(i);
- } else {
- d = valuePtr->internalRep.doubleValue;
- objPtr = Tcl_NewDoubleObj(d);
- }
- Tcl_IncrRefCount(objPtr);
- TclDecrRefCount(valuePtr);
- valuePtr = objPtr;
- stackPtr[stackTop] = valuePtr;
- tPtr = valuePtr->typePtr;
- }
+ /*
+ * Ensure that the topmost stack object, if numeric, has a
+ * string rep the same as the formatted version of its
+ * internal rep. This is used, e.g., to make sure that "expr
+ * {0001}" yields "1", not "0001". We implement this by
+ * _discarding_ the string rep since we know it will be
+ * regenerated, if needed later, by formatting the internal
+ * rep's value. Also check if there has been an IEEE
+ * floating point error.
+ */
+
+ objResultPtr = valuePtr;
+ needNew = 0;
+ if (IS_NUMERIC_TYPE(tPtr)) {
+ if (Tcl_IsShared(valuePtr)) {
+ if (valuePtr->bytes != NULL) {
+ /*
+ * We only need to make a copy of the object
+ * when it already had a string rep
+ */
+ needNew = 1;
+ if (tPtr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+ objResultPtr = Tcl_NewLongObj(i);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (tPtr == &tclWideIntType) {
+ w = valuePtr->internalRep.wideValue;
+ objResultPtr = Tcl_NewWideIntObj(w);
+#endif /* TCL_WIDE_INT_IS_LONG */
} else {
- Tcl_InvalidateStringRep(valuePtr);
- }
-
- if (tPtr == &tclDoubleType) {
d = valuePtr->internalRep.doubleValue;
- if (IS_NAN(d) || IS_INF(d)) {
- TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
- O2S(valuePtr)));
- TclExprFloatError(interp, d);
- result = TCL_ERROR;
- goto checkForCatch;
- }
+ objResultPtr = Tcl_NewDoubleObj(d);
}
- shared = shared; /* lint, shared not used. */
- converted = converted; /* lint, converted not used. */
- TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
- (converted? "converted" : "not converted"),
- (shared? "shared" : "not shared")));
- } else {
- TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
+ tPtr = objResultPtr->typePtr;
+ }
+ } else {
+ Tcl_InvalidateStringRep(valuePtr);
+ }
+
+ if (tPtr == &tclDoubleType) {
+ d = objResultPtr->internalRep.doubleValue;
+ if (IS_NAN(d) || IS_INF(d)) {
+ TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
+ O2S(objResultPtr)));
+ TclExprFloatError(interp, d);
+ result = TCL_ERROR;
+ goto checkForCatch;
}
}
- ADJUST_PC(1);
+ converted = converted; /* lint, converted not used. */
+ TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
+ (converted? "converted" : "not converted"),
+ (needNew? "new Tcl_Obj" : "same Tcl_Obj")));
+ } else {
+ TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
+ }
+ if (needNew) {
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ NEXT_INST_F(1, 0, 0);
+ }
+ }
+
+ case INST_BREAK:
+ Tcl_ResetResult(interp);
+ result = TCL_BREAK;
+ cleanup = 0;
+ goto processExceptionReturn;
+
+ case INST_CONTINUE:
+ Tcl_ResetResult(interp);
+ result = TCL_CONTINUE;
+ cleanup = 0;
+ goto processExceptionReturn;
- case INST_BREAK:
+ case INST_FOREACH_START4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ {
/*
- * First reset the interpreter's result. Then find the closest
- * enclosing loop or catch exception range, if any. If a loop is
- * found, terminate its execution. If the closest is a catch
- * exception range, jump to its catchOffset. If no enclosing
- * range is found, stop execution and return TCL_BREAK.
+ * Initialize the temporary local var that holds the count
+ * of the number of iterations of the loop body to -1.
*/
- Tcl_ResetResult(interp);
- rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
- if (rangePtr == NULL) {
- TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
- result = TCL_BREAK;
- goto abnormalReturn; /* no catch exists to check */
- }
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- result = TCL_OK;
- TRACE(("=> range at %d, new pc %d\n",
- rangePtr->codeOffset, rangePtr->breakOffset));
- break;
- case CATCH_EXCEPTION_RANGE:
- result = TCL_BREAK;
- TRACE(("=> ...\n"));
- goto processCatch; /* it will use rangePtr */
- default:
- panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
+ ForeachInfo *infoPtr = (ForeachInfo *)
+ codePtr->auxDataArrayPtr[opnd].clientData;
+ int iterTmpIndex = infoPtr->loopCtTemp;
+ Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
+ Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
+ Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
+
+ if (oldValuePtr == NULL) {
+ iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
+ Tcl_IncrRefCount(iterVarPtr->value.objPtr);
+ } else {
+ Tcl_SetLongObj(oldValuePtr, -1);
}
- pc = (codePtr->codeStart + rangePtr->breakOffset);
- continue; /* restart outer instruction loop at pc */
-
- case INST_CONTINUE:
- /*
- * Find the closest enclosing loop or catch exception range,
- * if any. If a loop is found, skip to its next iteration.
- * If the closest is a catch exception range, jump to its
- * catchOffset. If no enclosing range is found, stop
- * execution and return TCL_CONTINUE.
+ TclSetVarScalar(iterVarPtr);
+ TclClearVarUndefined(iterVarPtr);
+ TRACE(("%u => loop iter count temp %d\n",
+ opnd, iterTmpIndex));
+ }
+
+#ifndef TCL_COMPILE_DEBUG
+ /*
+ * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
+ * immediately after INST_FOREACH_START4 - let us just fall
+ * through instead of jumping back to the top.
+ */
+
+ pc += 5;
+#else
+ NEXT_INST_F(5, 0, 0);
+#endif
+ case INST_FOREACH_STEP4:
+ opnd = TclGetUInt4AtPtr(pc+1);
+ {
+ /*
+ * "Step" a foreach loop (i.e., begin its next iteration) by
+ * assigning the next value list element to each loop var.
*/
- Tcl_ResetResult(interp);
- rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
- if (rangePtr == NULL) {
- TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
- result = TCL_CONTINUE;
- goto abnormalReturn;
- }
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- if (rangePtr->continueOffset == -1) {
- TRACE(("=> loop w/o continue, checking for catch\n"));
- goto checkForCatch;
- } else {
- result = TCL_OK;
- TRACE(("=> range at %d, new pc %d\n",
- rangePtr->codeOffset, rangePtr->continueOffset));
- }
- break;
- case CATCH_EXCEPTION_RANGE:
- result = TCL_CONTINUE;
- TRACE(("=> ...\n"));
- goto processCatch; /* it will use rangePtr */
- default:
- panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
- }
- pc = (codePtr->codeStart + rangePtr->continueOffset);
- continue; /* restart outer instruction loop at pc */
-
- case INST_FOREACH_START4:
- opnd = TclGetUInt4AtPtr(pc+1);
- {
- /*
- * Initialize the temporary local var that holds the count
- * of the number of iterations of the loop body to -1.
- */
+ ForeachInfo *infoPtr = (ForeachInfo *)
+ codePtr->auxDataArrayPtr[opnd].clientData;
+ ForeachVarList *varListPtr;
+ int numLists = infoPtr->numLists;
+ Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
+ Tcl_Obj *listPtr;
+ List *listRepPtr;
+ Var *iterVarPtr, *listVarPtr;
+ int iterNum, listTmpIndex, listLen, numVars;
+ int varIndex, valIndex, continueLoop, j;
+
+ /*
+ * Increment the temp holding the loop iteration number.
+ */
- ForeachInfo *infoPtr = (ForeachInfo *)
- codePtr->auxDataArrayPtr[opnd].clientData;
- int iterTmpIndex = infoPtr->loopCtTemp;
- Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
- Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
- Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
+ iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
+ valuePtr = iterVarPtr->value.objPtr;
+ iterNum = (valuePtr->internalRep.longValue + 1);
+ Tcl_SetLongObj(valuePtr, iterNum);
+
+ /*
+ * Check whether all value lists are exhausted and we should
+ * stop the loop.
+ */
- if (oldValuePtr == NULL) {
- iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
- Tcl_IncrRefCount(iterVarPtr->value.objPtr);
- } else {
- Tcl_SetLongObj(oldValuePtr, -1);
+ continueLoop = 0;
+ listTmpIndex = infoPtr->firstValueTemp;
+ for (i = 0; i < numLists; i++) {
+ varListPtr = infoPtr->varLists[i];
+ numVars = varListPtr->numVars;
+
+ listVarPtr = &(compiledLocals[listTmpIndex]);
+ listPtr = listVarPtr->value.objPtr;
+ result = Tcl_ListObjLength(interp, listPtr, &listLen);
+ if (result != TCL_OK) {
+ TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
+ opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
+ goto checkForCatch;
+ }
+ if (listLen > (iterNum * numVars)) {
+ continueLoop = 1;
}
- TclSetVarScalar(iterVarPtr);
- TclClearVarUndefined(iterVarPtr);
- TRACE(("%u => loop iter count temp %d\n",
- opnd, iterTmpIndex));
+ listTmpIndex++;
}
- ADJUST_PC(5);
-
- case INST_FOREACH_STEP4:
- opnd = TclGetUInt4AtPtr(pc+1);
- {
- /*
- * "Step" a foreach loop (i.e., begin its next iteration) by
- * assigning the next value list element to each loop var.
- */
-
- ForeachInfo *infoPtr = (ForeachInfo *)
- codePtr->auxDataArrayPtr[opnd].clientData;
- ForeachVarList *varListPtr;
- int numLists = infoPtr->numLists;
- Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
- Tcl_Obj *listPtr;
- List *listRepPtr;
- Var *iterVarPtr, *listVarPtr;
- int iterNum, listTmpIndex, listLen, numVars;
- int varIndex, valIndex, continueLoop, j;
-
- /*
- * Increment the temp holding the loop iteration number.
- */
- iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
- valuePtr = iterVarPtr->value.objPtr;
- iterNum = (valuePtr->internalRep.longValue + 1);
- Tcl_SetLongObj(valuePtr, iterNum);
+ /*
+ * If some var in some var list still has a remaining list
+ * element iterate one more time. Assign to var the next
+ * element from its value list. We already checked above
+ * that each list temp holds a valid list object.
+ */
- /*
- * Check whether all value lists are exhausted and we should
- * stop the loop.
- */
-
- continueLoop = 0;
+ if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
-
+
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
- result = Tcl_ListObjLength(interp, listPtr, &listLen);
- if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
- opnd, i, O2S(listPtr)),
- Tcl_GetObjResult(interp));
- goto checkForCatch;
- }
- if (listLen > (iterNum * numVars)) {
- continueLoop = 1;
- }
- listTmpIndex++;
- }
-
- /*
- * If some var in some var list still has a remaining list
- * element iterate one more time. Assign to var the next
- * element from its value list. We already checked above
- * that each list temp holds a valid list object.
- */
-
- if (continueLoop) {
- listTmpIndex = infoPtr->firstValueTemp;
- for (i = 0; i < numLists; i++) {
- varListPtr = infoPtr->varLists[i];
- numVars = varListPtr->numVars;
-
- listVarPtr = &(compiledLocals[listTmpIndex]);
- listPtr = listVarPtr->value.objPtr;
- listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
- listLen = listRepPtr->elemCount;
+ listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+ listLen = listRepPtr->elemCount;
- valIndex = (iterNum * numVars);
- for (j = 0; j < numVars; j++) {
- int setEmptyStr = 0;
- if (valIndex >= listLen) {
- setEmptyStr = 1;
- valuePtr = Tcl_NewObj();
- } else {
- valuePtr = listRepPtr->elements[valIndex];
- }
+ valIndex = (iterNum * numVars);
+ for (j = 0; j < numVars; j++) {
+ int setEmptyStr = 0;
+ if (valIndex >= listLen) {
+ setEmptyStr = 1;
+ TclNewObj(valuePtr);
+ } else {
+ valuePtr = listRepPtr->elements[valIndex];
+ }
- varIndex = varListPtr->varIndexes[j];
+ varIndex = varListPtr->varIndexes[j];
+ varPtr = &(varFramePtr->compiledLocals[varIndex]);
+ part1 = varPtr->name;
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
+ && (varPtr->tracePtr == NULL)
+ && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) {
+ value2Ptr = varPtr->value.objPtr;
+ if (valuePtr != value2Ptr) {
+ if (value2Ptr != NULL) {
+ TclDecrRefCount(value2Ptr);
+ } else {
+ TclSetVarScalar(varPtr);
+ TclClearVarUndefined(varPtr);
+ }
+ varPtr->value.objPtr = valuePtr;
+ Tcl_IncrRefCount(valuePtr);
+ }
+ } else {
DECACHE_STACK_INFO();
- value2Ptr = TclSetIndexedScalar(interp,
- varIndex, valuePtr, /*leaveErrorMsg*/ 1);
+ value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
- opnd, varIndex),
- Tcl_GetObjResult(interp));
+ opnd, varIndex),
+ Tcl_GetObjResult(interp));
if (setEmptyStr) {
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
}
result = TCL_ERROR;
goto checkForCatch;
}
- valIndex++;
}
- listTmpIndex++;
+ valIndex++;
}
+ listTmpIndex++;
}
-
- /*
- * Push 1 if at least one value list had a remaining element
- * and the loop should continue. Otherwise push 0.
- */
-
- PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
- TRACE(("%u => %d lists, iter %d, %s loop\n",
- opnd, numLists, iterNum,
- (continueLoop? "continue" : "exit")));
}
- ADJUST_PC(5);
+ TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
+ iterNum, (continueLoop? "continue" : "exit")));
- case INST_BEGIN_CATCH4:
- /*
- * Record start of the catch command with exception range index
- * equal to the operand. Push the current stack depth onto the
- * special catch stack.
+ /*
+ * Run-time peep-hole optimisation: the compiler ALWAYS follows
+ * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
+ * instruction and jump direct from here.
*/
- catchStackPtr[++catchTop] = stackTop;
- TRACE(("%u => catchTop=%d, stackTop=%d\n",
- TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
- ADJUST_PC(5);
- case INST_END_CATCH:
- catchTop--;
- result = TCL_OK;
- TRACE(("=> catchTop=%d\n", catchTop));
- ADJUST_PC(1);
+ pc += 5;
+ if (*pc == INST_JUMP_FALSE1) {
+ NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
+ } else {
+ NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
+ }
+ }
- case INST_PUSH_RESULT:
- PUSH_OBJECT(Tcl_GetObjResult(interp));
- TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
- ADJUST_PC(1);
+ case INST_BEGIN_CATCH4:
+ /*
+ * Record start of the catch command with exception range index
+ * equal to the operand. Push the current stack depth onto the
+ * special catch stack.
+ */
+ catchStackPtr[++catchTop] = stackTop;
+ TRACE(("%u => catchTop=%d, stackTop=%d\n",
+ TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
+ NEXT_INST_F(5, 0, 0);
+
+ case INST_END_CATCH:
+ catchTop--;
+ result = TCL_OK;
+ TRACE(("=> catchTop=%d\n", catchTop));
+ NEXT_INST_F(1, 0, 0);
+
+ case INST_PUSH_RESULT:
+ objResultPtr = Tcl_GetObjResult(interp);
+ TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
+ NEXT_INST_F(1, 0, 1);
- case INST_PUSH_RETURN_CODE:
- PUSH_OBJECT(Tcl_NewLongObj(result));
- TRACE(("=> %u\n", result));
- ADJUST_PC(1);
+ case INST_PUSH_RETURN_CODE:
+ objResultPtr = Tcl_NewLongObj(result);
+ TRACE(("=> %u\n", result));
+ NEXT_INST_F(1, 0, 1);
- default:
- panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
- } /* end of switch on opCode */
+ default:
+ panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
+ } /* end of switch on opCode */
- /*
- * Division by zero in an expression. Control only reaches this
- * point by "goto divideByZero".
- */
-
- divideByZero:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
- Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
- (char *) NULL);
- result = TCL_ERROR;
+ /*
+ * Division by zero in an expression. Control only reaches this
+ * point by "goto divideByZero".
+ */
- /*
- * Execution has generated an "exception" such as TCL_ERROR. If the
- * exception is an error, record information about what was being
- * executed when the error occurred. Find the closest enclosing
- * catch range, if any. If no enclosing catch range is found, stop
- * execution and return the "exception" code.
- */
+ divideByZero:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
+ Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto checkForCatch;
- checkForCatch:
- if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- bytes = GetSrcInfoForPc(pc, codePtr, &length);
- if (bytes != NULL) {
- Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
- }
- rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
+ /*
+ * An external evaluation (INST_INVOKE or INST_EVAL) returned
+ * something different from TCL_OK, or else INST_BREAK or
+ * INST_CONTINUE were called.
+ */
+
+ processExceptionReturn:
+#if TCL_COMPILE_DEBUG
+ switch (*pc) {
+ case INST_INVOKE_STK1:
+ case INST_INVOKE_STK4:
+ TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
+ break;
+ case INST_EVAL_STK:
+ /*
+ * Note that the object at stacktop has to be used
+ * before doing the cleanup.
+ */
+
+ TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop])));
+ break;
+ default:
+ TRACE(("=> "));
+ }
+#endif
+ if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
+ rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
-#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) {
- fprintf(stdout, " ... no enclosing catch, returning %s\n",
- StringForResultCode(result));
- }
-#endif
+ TRACE_APPEND(("no encl. loop or catch, returning %s\n",
+ StringForResultCode(result)));
goto abnormalReturn;
+ }
+ if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
+ TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
+ goto processCatch;
}
-
- /*
- * A catch exception range (rangePtr) was found to handle an
- * "exception". It was found either by checkForCatch just above or
- * by an instruction during break, continue, or error processing.
- * Jump to its catchOffset after unwinding the operand stack to
- * the depth it had when starting to execute the range's catch
- * command.
- */
-
- processCatch:
- while (stackTop > catchStackPtr[catchTop]) {
+ while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
+ if (result == TCL_BREAK) {
+ result = TCL_OK;
+ pc = (codePtr->codeStart + rangePtr->breakOffset);
+ TRACE_APPEND(("%s, range at %d, new pc %d\n",
+ StringForResultCode(result),
+ rangePtr->codeOffset, rangePtr->breakOffset));
+ NEXT_INST_F(0, 0, 0);
+ } else {
+ if (rangePtr->continueOffset == -1) {
+ TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
+ StringForResultCode(result)));
+ goto checkForCatch;
+ }
+ result = TCL_OK;
+ pc = (codePtr->codeStart + rangePtr->continueOffset);
+ TRACE_APPEND(("%s, range at %d, new pc %d\n",
+ StringForResultCode(result),
+ rangePtr->codeOffset, rangePtr->continueOffset));
+ NEXT_INST_F(0, 0, 0);
+ }
+#if TCL_COMPILE_DEBUG
+ } else if (traceInstructions) {
+ if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
+ objPtr = Tcl_GetObjResult(interp);
+ TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
+ result, O2S(objPtr)));
+ } else {
+ objPtr = Tcl_GetObjResult(interp);
+ TRACE_APPEND(("%s, result= \"%s\"\n",
+ StringForResultCode(result), O2S(objPtr)));
+ }
+#endif
+ }
+
+ /*
+ * Execution has generated an "exception" such as TCL_ERROR. If the
+ * exception is an error, record information about what was being
+ * executed when the error occurred. Find the closest enclosing
+ * catch range, if any. If no enclosing catch range is found, stop
+ * execution and return the "exception" code.
+ */
+
+ checkForCatch:
+ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ bytes = GetSrcInfoForPc(pc, codePtr, &length);
+ if (bytes != NULL) {
+ Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
+ }
+ if (catchTop == -1) {
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, " ... no enclosing catch, returning %s\n",
+ StringForResultCode(result));
+ }
+#endif
+ goto abnormalReturn;
+ }
+ rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
+ if (rangePtr == NULL) {
+ /*
+ * This is only possible when compiling a [catch] that sends its
+ * script to INST_EVAL. Cannot correct the compiler without
+ * breakingcompat with previous .tbc compiled scripts.
+ */
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
- fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
+ fprintf(stdout, " ... no enclosing catch, returning %s\n",
+ StringForResultCode(result));
+ }
+#endif
+ goto abnormalReturn;
+ }
+
+ /*
+ * A catch exception range (rangePtr) was found to handle an
+ * "exception". It was found either by checkForCatch just above or
+ * by an instruction during break, continue, or error processing.
+ * Jump to its catchOffset after unwinding the operand stack to
+ * the depth it had when starting to execute the range's catch
+ * command.
+ */
+
+ processCatch:
+ while (stackTop > catchStackPtr[catchTop]) {
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
+ }
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
(unsigned int)(rangePtr->catchOffset));
- }
+ }
#endif
- pc = (codePtr->codeStart + rangePtr->catchOffset);
- continue; /* restart the execution loop at pc */
- } /* end of infinite loop dispatching on instructions */
+ pc = (codePtr->codeStart + rangePtr->catchOffset);
+ NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
+
+ /*
+ * end of infinite loop dispatching on instructions.
+ */
/*
* Abnormal return code. Restore the stack to state it had when starting
- * to execute the ByteCode.
+ * to execute the ByteCode. Panic if the stack is below the initial level.
*/
- abnormalReturn:
+ abnormalReturn:
while (stackTop > initStackTop) {
valuePtr = POP_OBJECT();
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
}
-
+ if (stackTop < initStackTop) {
+ fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
+ (unsigned int)(pc - codePtr->codeStart),
+ (unsigned int) stackTop,
+ (unsigned int) initStackTop);
+ panic("TclExecuteByteCode execution failure: end stack top < start stack top");
+ }
+
/*
* Free the catch stack array if malloc'ed storage was used.
*/
- done:
if (catchStackPtr != catchStackStorage) {
ckfree((char *) catchStackPtr);
}
#ifdef TCL_COMPILE_DEBUG
static void
-ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
- stackUpperBound)
+ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
unsigned char *pc; /* Points to first byte of a bytecode
* stackLowerBound and stackUpperBound
* (inclusive). */
int stackLowerBound; /* Smallest legal value for stackTop. */
- int stackUpperBound; /* Greatest legal value for stackTop. */
{
+ int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
+ /* Greatest legal value for stackTop. */
unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
unsigned int codeStart = (unsigned int) codePtr->codeStart;
unsigned int codeEnd = (unsigned int)
if ((unsigned int) opCode > LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
(unsigned int) opCode, relativePc);
- panic("TclExecuteByteCode execution failure: bad opcode");
+ panic("TclExecuteByteCode execution failure: bad opcode");
}
if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
int numChars;
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
char *ellipsis = "";
- fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
- stackTop, relativePc);
+ fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
+ stackTop, relativePc, stackLowerBound, stackUpperBound);
if (cmd != NULL) {
if (numChars > 100) {
numChars = 100;
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
char *msg = "non-numeric string";
- if (opndPtr->typePtr != &tclDoubleType) {
+ char *s, *p;
+ int length;
+ int looksLikeInt = 0;
+
+ s = Tcl_GetStringFromObj(opndPtr, &length);
+ p = s;
+ /*
+ * strtod() isn't at all consistent about detecting Inf and
+ * NaN between platforms.
+ */
+ if (length == 3) {
+ if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
+ (s[2]=='n' || s[2]=='N')) {
+ msg = "non-numeric floating-point value";
+ goto makeErrorMessage;
+ }
+ if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
+ (s[2]=='f' || s[2]=='F')) {
+ msg = "infinite floating-point value";
+ goto makeErrorMessage;
+ }
+ }
+
+ /*
+ * We cannot use TclLooksLikeInt here because it passes strings
+ * like "10;" [Bug 587140]. We'll accept as "looking like ints"
+ * for the present purposes any string that looks formally like
+ * a (decimal|octal|hex) integer.
+ */
+
+ while (length && isspace(UCHAR(*p))) {
+ length--;
+ p++;
+ }
+ if (length && ((*p == '+') || (*p == '-'))) {
+ length--;
+ p++;
+ }
+ if (length) {
+ if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
+ p += 2;
+ length -= 2;
+ looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
+ if (looksLikeInt) {
+ length--;
+ p++;
+ while (length && isxdigit(UCHAR(*p))) {
+ length--;
+ p++;
+ }
+ }
+ } else {
+ looksLikeInt = (length && isdigit(UCHAR(*p)));
+ if (looksLikeInt) {
+ length--;
+ p++;
+ while (length && isdigit(UCHAR(*p))) {
+ length--;
+ p++;
+ }
+ }
+ }
+ while (length && isspace(UCHAR(*p))) {
+ length--;
+ p++;
+ }
+ looksLikeInt = !length;
+ }
+ if (looksLikeInt) {
+ /*
+ * If something that looks like an integer could not be
+ * converted, then it *must* be a bad octal or too large
+ * to represent [Bug 542588].
+ */
+
+ if (TclCheckBadOctal(NULL, s)) {
+ msg = "invalid octal number";
+ } else {
+ msg = "integer value too large to represent";
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+ "integer value too large to represent", (char *) NULL);
+ }
+ } else {
/*
- * See if the operand can be interpreted as a double in order to
- * improve the error message.
+ * See if the operand can be interpreted as a double in
+ * order to improve the error message.
*/
- char *s = Tcl_GetString(opndPtr);
double d;
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
- /*
- * Make sure that what appears to be a double
- * (ie 08) isn't really a bad octal
- */
- if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
- msg = "invalid octal number";
- } else {
- msg = "floating-point value";
- }
+ msg = "floating-point value";
}
}
+ makeErrorMessage:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
/*
*----------------------------------------------------------------------
*
- * CallTraceProcedure --
- *
- * Invokes a trace procedure registered with an interpreter. These
- * procedures trace command execution. Currently this trace procedure
- * is called with the address of the string-based Tcl_CmdProc for the
- * command, not the Tcl_ObjCmdProc.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Those side effects made by the trace procedure.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
- Tcl_Interp *interp; /* The current interpreter. */
- register Trace *tracePtr; /* Describes the trace procedure to call. */
- Command *cmdPtr; /* Points to command's Command struct. */
- char *command; /* Points to the first character of the
- * command's source before substitutions. */
- int numChars; /* The number of characters in the
- * command's source. */
- register int objc; /* Number of arguments for the command. */
- Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */
-{
- Interp *iPtr = (Interp *) interp;
- register char **argv;
- register int i;
- int length;
- char *p;
-
- /*
- * Get the string rep from the objv argument objects and place their
- * pointers in argv. First make sure argv is large enough to hold the
- * objc args plus 1 extra word for the zero end-of-argv word.
- */
-
- argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
- for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetStringFromObj(objv[i], &length);
- }
- argv[objc] = 0;
-
- /*
- * Copy the command characters into a new string.
- */
-
- p = (char *) ckalloc((unsigned) (numChars + 1));
- memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
- p[numChars] = '\0';
-
- /*
- * Call the trace procedure then free allocated storage.
- */
-
- (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
- p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
-
- ckfree((char *) argv);
- ckfree((char *) p);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
* GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
int numRanges = codePtr->numExceptRanges;
register ExceptionRange *rangePtr;
int pcOffset = (pc - codePtr->codeStart);
- register int i, level;
+ register int start;
if (numRanges == 0) {
return NULL;
}
- rangeArrayPtr = codePtr->exceptArrayPtr;
- for (level = codePtr->maxExceptDepth; level >= 0; level--) {
- for (i = 0; i < numRanges; i++) {
- rangePtr = &(rangeArrayPtr[i]);
- if (rangePtr->nestingLevel == level) {
- int start = rangePtr->codeOffset;
- int end = (start + rangePtr->numCodeBytes);
- if ((start <= pcOffset) && (pcOffset < end)) {
- if ((!catchOnly)
- || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
- return rangePtr;
- }
- }
+ /*
+ * This exploits peculiarities of our compiler: nested ranges
+ * are always *after* their containing ranges, so that by scanning
+ * backwards we are sure that the first matching range is indeed
+ * the deepest.
+ */
+
+ rangeArrayPtr = codePtr->exceptArrayPtr;
+ rangePtr = rangeArrayPtr + numRanges;
+ while (--rangePtr >= rangeArrayPtr) {
+ start = rangePtr->codeOffset;
+ if ((start <= pcOffset) &&
+ (pcOffset < (start + rangePtr->numCodeBytes))) {
+ if ((!catchOnly)
+ || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
+ return rangePtr;
}
}
}
{
unsigned char opCode = *pc;
- return instructionTable[opCode].name;
+ return tclInstructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */
\f
* TCL_OK if it was int or double, TCL_ERROR otherwise
*
* Side effects:
- * objPtr is ensured to be either tclIntType of tclDoubleType.
+ * objPtr is ensured to be of tclIntType, tclWideIntType or
+ * tclDoubleType.
*
*----------------------------------------------------------------------
*/
* function. */
Tcl_Obj *objPtr; /* Points to the object to type check. */
{
- if ((objPtr->typePtr == &tclIntType) ||
- (objPtr->typePtr == &tclDoubleType)) {
+ if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
return TCL_OK;
} else {
int length, result = TCL_OK;
char *s = Tcl_GetStringFromObj(objPtr, &length);
if (TclLooksLikeInt(s, length)) {
+#ifdef TCL_WIDE_INT_IS_LONG
long i;
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i);
+#else /* !TCL_WIDE_INT_IS_LONG */
+ Tcl_WideInt w;
+ result = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, objPtr, &w);
+#endif /* TCL_WIDE_INT_IS_LONG */
} else {
double d;
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
result = TCL_ERROR;
goto done;
}
-
- if (valuePtr->typePtr == &tclIntType) {
- d = (double) valuePtr->internalRep.longValue;
- } else {
- d = valuePtr->internalRep.doubleValue;
- }
+
+ GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
errno = 0;
dResult = (*func)(d);
*/
done:
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
goto done;
}
- if (valuePtr->typePtr == &tclIntType) {
- d1 = (double) valuePtr->internalRep.longValue;
- } else {
- d1 = valuePtr->internalRep.doubleValue;
- }
-
- if (value2Ptr->typePtr == &tclIntType) {
- d2 = (double) value2Ptr->internalRep.longValue;
- } else {
- d2 = value2Ptr->internalRep.doubleValue;
- }
+ GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
+ GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);
errno = 0;
dResult = (*func)(d1, d2);
*/
done:
- Tcl_DecrRefCount(valuePtr);
- Tcl_DecrRefCount(value2Ptr);
+ TclDecrRefCount(valuePtr);
+ TclDecrRefCount(value2Ptr);
DECACHE_STACK_INFO();
return result;
}
iResult = i;
}
PUSH_OBJECT(Tcl_NewLongObj(iResult));
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ Tcl_WideInt wResult, w = valuePtr->internalRep.wideValue;
+ if (w < W0) {
+ wResult = -w;
+ if (wResult < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "integer value too large to represent", -1);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+ "integer value too large to represent", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ } else {
+ wResult = w;
+ }
+ PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
+#endif /* TCL_WIDE_INT_IS_LONG */
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
*/
done:
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
+ DECACHE_STACK_INFO();
+ return result;
+}
+
+static int
+ExprDoubleFunc(interp, eePtr, clientData)
+ Tcl_Interp *interp; /* The interpreter in which to execute the
+ * function. */
+ ExecEnv *eePtr; /* Points to the environment for executing
+ * the function. */
+ ClientData clientData; /* Ignored. */
+{
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
+ register int stackTop; /* Cached top index of evaluation stack. */
+ register Tcl_Obj *valuePtr;
+ double dResult;
+ int result;
+
+ /*
+ * Set stackPtr and stackTop from eePtr.
+ */
+
+ result = TCL_OK;
+ CACHE_STACK_INFO();
+
+ /*
+ * Pop the argument from the evaluation stack.
+ */
+
+ valuePtr = POP_OBJECT();
+
+ if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
+
+ /*
+ * Push a Tcl object with the result.
+ */
+
+ PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
+
+ /*
+ * Reflect the change to stackTop back in eePtr.
+ */
+
+ done:
+ TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
-ExprDoubleFunc(interp, eePtr, clientData)
+ExprIntFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
- double dResult;
+ long iResult;
+ double d;
int result;
/*
*/
valuePtr = POP_OBJECT();
-
+
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
-
+
if (valuePtr->typePtr == &tclIntType) {
- dResult = (double) valuePtr->internalRep.longValue;
+ iResult = valuePtr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ iResult = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
+#endif /* TCL_WIDE_INT_IS_LONG */
} else {
- dResult = valuePtr->internalRep.doubleValue;
+ d = valuePtr->internalRep.doubleValue;
+ if (d < 0.0) {
+ if (d < (double) (long) LONG_MIN) {
+ tooLarge:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "integer value too large to represent", -1);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
+ "integer value too large to represent", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ } else {
+ if (d > (double) LONG_MAX) {
+ goto tooLarge;
+ }
+ }
+ if (IS_NAN(d) || IS_INF(d)) {
+ TclExprFloatError(interp, d);
+ result = TCL_ERROR;
+ goto done;
+ }
+ iResult = (long) d;
}
/*
* Push a Tcl object with the result.
*/
-
- PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
+
+ PUSH_OBJECT(Tcl_NewLongObj(iResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
+#ifndef TCL_WIDE_INT_IS_LONG
static int
-ExprIntFunc(interp, eePtr, clientData)
+ExprWideFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
- long iResult;
+ Tcl_WideInt wResult;
double d;
int result;
goto done;
}
- if (valuePtr->typePtr == &tclIntType) {
- iResult = valuePtr->internalRep.longValue;
+ if (valuePtr->typePtr == &tclWideIntType) {
+ wResult = valuePtr->internalRep.wideValue;
+ } else if (valuePtr->typePtr == &tclIntType) {
+ wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
- if (d < (double) (long) LONG_MIN) {
+ if (d < Tcl_WideAsDouble(LLONG_MIN)) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
goto done;
}
} else {
- if (d > (double) LONG_MAX) {
+ if (d > Tcl_WideAsDouble(LLONG_MAX)) {
goto tooLarge;
}
}
result = TCL_ERROR;
goto done;
}
- iResult = (long) d;
+ wResult = Tcl_DoubleAsWide(d);
}
/*
* Push a Tcl object with the result.
*/
- PUSH_OBJECT(Tcl_NewLongObj(iResult));
+ PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
+#endif /* TCL_WIDE_INT_IS_LONG */
static int
ExprRandFunc(interp, eePtr, clientData)
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
double dResult;
- int tmp;
+ long tmp; /* Algorithm assumes at least 32 bits.
+ * Only long guarantees that. See below. */
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
iPtr->flags |= RAND_SEED_INITIALIZED;
- iPtr->randSeed = TclpGetClicks();
+
+ /*
+ * Take into consideration the thread this interp is running in order
+ * to insure different seeds in different threads (bug #416643)
+ */
+
+ iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
+
+ /*
+ * Make sure 1 <= randSeed <= (2^31) - 2. See below.
+ */
+
+ iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
+ iPtr->randSeed ^= 123459876;
+ }
}
/*
* Generate the random number using the linear congruential
* generator defined by the following recurrence:
* seed = ( IA * seed ) mod IM
- * where IA is 16807 and IM is (2^31) - 1. In order to avoid
- * potential problems with integer overflow, the code uses
- * additional constants IQ and IR such that
+ * where IA is 16807 and IM is (2^31) - 1. The recurrence maps
+ * a seed in the range [1, IM - 1] to a new seed in that same range.
+ * The recurrence maps IM to 0, and maps 0 back to 0, so those two
+ * values must not be allowed as initial values of seed.
+ *
+ * In order to avoid potential problems with integer overflow, the
+ * recurrence is implemented in terms of additional constants
+ * IQ and IR such that
* IM = IA*IQ + IR
- * For details on how this algorithm works, refer to the following
+ * None of the operations in the implementation overflows a 32-bit
+ * signed integer, and the C type long is guaranteed to be at least
+ * 32 bits wide.
+ *
+ * For more details on how this algorithm works, refer to the following
* papers:
*
* S.K. Park & K.W. Miller, "Random number generators: good ones
#define RAND_IR 2836
#define RAND_MASK 123459876
- if (iPtr->randSeed == 0) {
- /*
- * Don't allow a 0 seed, since it breaks the generator. Shift
- * it to some other value.
- */
-
- iPtr->randSeed = 123459876;
- }
tmp = iPtr->randSeed/RAND_IQ;
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
if (iPtr->randSeed < 0) {
}
/*
- * On 64-bit architectures we need to mask off the upper bits to
- * ensure we only have a 32-bit range. The constant has the
- * bizarre form below in order to make sure that it doesn't
- * get sign-extended (the rules for sign extension are very
- * concat, particularly on 64-bit machines).
+ * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
+ * dividing by RAND_IM yields a double in the range (0, 1).
*/
- iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
dResult = iPtr->randSeed * (1.0/RAND_IM);
/*
if (valuePtr->typePtr == &tclIntType) {
iResult = valuePtr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ PUSH_OBJECT(Tcl_NewWideIntObj(valuePtr->internalRep.wideValue));
+ goto done;
+#endif /* TCL_WIDE_INT_IS_LONG */
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
*/
done:
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
+#endif /* TCL_WIDE_INT_IS_LONG */
} else {
/*
* At this point, the only other possible type is double
"can't use floating-point value as argument to srand",
(char *) NULL);
badValue:
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return TCL_ERROR;
}
/*
- * Reset the seed.
+ * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
+ * See comments in ExprRandFunc() for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = i;
+ iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
+ iPtr->randSeed ^= 123459876;
+ }
/*
* To avoid duplicating the random number generation code we simply
* function will always succeed.
*/
- Tcl_DecrRefCount(valuePtr);
+ TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
ExprRandFunc(interp, eePtr, clientData);
long i;
double d;
int j, k, result;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_ResetResult(interp);
* Look up the MathFunc record for the function.
*/
- funcName = Tcl_GetString(objv[0]);
+ funcName = TclGetString(objv[0]);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
+ args[k].type = TCL_WIDE_INT;
+ args[k].wideValue = Tcl_LongAsWide(i);
+#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
args[k].type = TCL_INT;
args[k].intValue = i;
}
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (valuePtr->typePtr == &tclWideIntType) {
+ Tcl_WideInt w = valuePtr->internalRep.wideValue;
+ if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
+ args[k].type = TCL_DOUBLE;
+ args[k].wideValue = (Tcl_WideInt) Tcl_WideAsDouble(w);
+ } else if (mathFuncPtr->argTypes[k] == TCL_INT) {
+ args[k].type = TCL_INT;
+ args[k].wideValue = Tcl_WideAsLong(w);
+ } else {
+ args[k].type = TCL_WIDE_INT;
+ args[k].wideValue = w;
+ }
+#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
d = valuePtr->internalRep.doubleValue;
if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = (long) d;
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
+ args[k].type = TCL_WIDE_INT;
+ args[k].wideValue = Tcl_DoubleAsWide(d);
+#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = d;
* Invoke the function and copy its result back into valuePtr.
*/
- tsdPtr->mathInProgress++;
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
&funcResult);
- tsdPtr->mathInProgress--;
if (result != TCL_OK) {
goto done;
}
/*
* Pop the objc top stack elements and decrement their ref counts.
*/
-
- i = (stackTop - (objc-1));
- while (i <= stackTop) {
- valuePtr = stackPtr[i];
- Tcl_DecrRefCount(valuePtr);
- i++;
+
+ k = (stackTop - (objc-1));
+ while (stackTop >= k) {
+ valuePtr = POP_OBJECT();
+ TclDecrRefCount(valuePtr);
}
- stackTop -= objc;
/*
* Push the call's object result.
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (funcResult.type == TCL_WIDE_INT) {
+ PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
+#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
d = funcResult.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
}
}
\f
-/*
- *----------------------------------------------------------------------
- *
- * TclMathInProgress --
- *
- * This procedure is called to find out if Tcl is doing math
- * in this thread.
- *
- * Results:
- * 0 or 1.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclMathInProgress()
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- return tsdPtr->mathInProgress;
-}
-\f
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
*/
static int
-EvalStatsCmd(unused, interp, argc, argv)
+EvalStatsCmd(unused, interp, objc, objv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
- int argc; /* The number of arguments. */
- char **argv; /* The argument strings. */
+ int objc; /* The number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
fprintf(stdout, " Mean code/source %.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
- fprintf(stdout, "\nCurrent ByteCodes %ld\n",
+ fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n",
numCurrentByteCodes);
fprintf(stdout, " Source bytes %.6g\n",
statsPtr->currentSrcBytes);
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
/*
+ * Tcl_IsShared statistics check
+ *
+ * This gives the refcount of each obj as Tcl_IsShared was called
+ * for it. Shared objects must be duplicated before they can be
+ * modified.
+ */
+
+ numSharedMultX = 0;
+ fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
+ fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n",
+ tclObjsShared[1]);
+ for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
+ fprintf(stdout, " refcount ==%d %ld\n",
+ i, tclObjsShared[i]);
+ numSharedMultX += tclObjsShared[i];
+ }
+ fprintf(stdout, " refcount >=%d %ld\n",
+ i, tclObjsShared[0]);
+ numSharedMultX += tclObjsShared[0];
+ fprintf(stdout, " Total shared objects %d\n",
+ numSharedMultX);
+
+ /*
* Literal table statistics.
*/
(tclObjsAlloced - tclObjsFreed));
fprintf(stdout, "Total literal objects %ld\n",
statsPtr->numLiteralsCreated);
-
+
fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
- fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n");
+ fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
fprintf(stdout, " Up to ms Percentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i]) {
fprintf(stdout, "%20s %8ld %6.1f%%\n",
- instructionTable[i].name,
+ tclInstructionTable[i].name,
statsPtr->instructionCount[i],
(statsPtr->instructionCount[i]*100.0) / numInstructions);
}
fprintf(stdout, "\nInstructions NEVER executed:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i] == 0) {
- fprintf(stdout, "%20s\n",
- instructionTable[i].name);
+ fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
}
}
}
#endif /* TCL_COMPILE_STATS */
\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetCommandFromObj --
- *
- * Returns the command specified by the name in a Tcl_Obj.
- *
- * Results:
- * Returns a token for the command if it is found. Otherwise, if it
- * can't be found or there is an error, returns NULL.
- *
- * Side effects:
- * May update the internal representation for the object, caching
- * the command reference so that the next time this procedure is
- * called with the same object, the command can be found quickly.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Command
-Tcl_GetCommandFromObj(interp, objPtr)
- Tcl_Interp *interp; /* The interpreter in which to resolve the
- * command and to report errors. */
- register Tcl_Obj *objPtr; /* The object containing the command's
- * name. If the name starts with "::", will
- * be looked up in global namespace. Else,
- * looked up first in the current namespace
- * if contextNsPtr is NULL, then in global
- * namespace. */
-{
- Interp *iPtr = (Interp *) interp;
- register ResolvedCmdName *resPtr;
- register Command *cmdPtr;
- Namespace *currNsPtr;
- int result;
-
- /*
- * Get the internal representation, converting to a command type if
- * needed. The internal representation is a ResolvedCmdName that points
- * to the actual command.
- */
-
- if (objPtr->typePtr != &tclCmdNameType) {
- result = tclCmdNameType.setFromAnyProc(interp, objPtr);
- if (result != TCL_OK) {
- return (Tcl_Command) NULL;
- }
- }
- resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
-
- /*
- * Get the current namespace.
- */
-
- if (iPtr->varFramePtr != NULL) {
- currNsPtr = iPtr->varFramePtr->nsPtr;
- } else {
- currNsPtr = iPtr->globalNsPtr;
- }
-
- /*
- * Check the context namespace and the namespace epoch of the resolved
- * symbol to make sure that it is fresh. If not, then force another
- * conversion to the command type, to discard the old rep and create a
- * new one. Note that we verify that the namespace id of the context
- * namespace is the same as the one we cached; this insures that the
- * namespace wasn't deleted and a new one created at the same address
- * with the same command epoch.
- */
-
- cmdPtr = NULL;
- if ((resPtr != NULL)
- && (resPtr->refNsPtr == currNsPtr)
- && (resPtr->refNsId == currNsPtr->nsId)
- && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
- cmdPtr = resPtr->cmdPtr;
- if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
- cmdPtr = NULL;
- }
- }
-
- if (cmdPtr == NULL) {
- result = tclCmdNameType.setFromAnyProc(interp, objPtr);
- if (result != TCL_OK) {
- return (Tcl_Command) NULL;
- }
- resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
- if (resPtr != NULL) {
- cmdPtr = resPtr->cmdPtr;
- }
- }
- return (Tcl_Command) cmdPtr;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclSetCmdNameObj --
- *
- * Modify an object to be an CmdName object that refers to the argument
- * Command structure.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object's old internal rep is freed. It's string rep is not
- * changed. The refcount in the Command structure is incremented to
- * keep it from being freed if the command is later deleted until
- * TclExecuteByteCode has a chance to recognize that it was deleted.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclSetCmdNameObj(interp, objPtr, cmdPtr)
- Tcl_Interp *interp; /* Points to interpreter containing command
- * that should be cached in objPtr. */
- register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
- * a CmdName object. */
- Command *cmdPtr; /* Points to Command structure that the
- * CmdName object should refer to. */
-{
- Interp *iPtr = (Interp *) interp;
- register ResolvedCmdName *resPtr;
- Tcl_ObjType *oldTypePtr = objPtr->typePtr;
- register Namespace *currNsPtr;
-
- if (oldTypePtr == &tclCmdNameType) {
- return;
- }
-
- /*
- * Get the current namespace.
- */
-
- if (iPtr->varFramePtr != NULL) {
- currNsPtr = iPtr->varFramePtr->nsPtr;
- } else {
- currNsPtr = iPtr->globalNsPtr;
- }
-
- cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
-
- if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
- oldTypePtr->freeIntRepProc(objPtr);
- }
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * FreeCmdNameInternalRep --
- *
- * Frees the resources associated with a cmdName object's internal
- * representation.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Decrements the ref count of any cached ResolvedCmdName structure
- * pointed to by the cmdName's internal representation. If this is
- * the last use of the ResolvedCmdName, it is freed. This in turn
- * decrements the ref count of the Command structure pointed to by
- * the ResolvedSymbol, which may free the Command structure.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FreeCmdNameInternalRep(objPtr)
- register Tcl_Obj *objPtr; /* CmdName object with internal
- * representation to free. */
-{
- register ResolvedCmdName *resPtr =
- (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
-
- if (resPtr != NULL) {
- /*
- * Decrement the reference count of the ResolvedCmdName structure.
- * If there are no more uses, free the ResolvedCmdName structure.
- */
-
- resPtr->refCount--;
- if (resPtr->refCount == 0) {
- /*
- * Now free the cached command, unless it is still in its
- * hash table or if there are other references to it
- * from other cmdName objects.
- */
-
- Command *cmdPtr = resPtr->cmdPtr;
- TclCleanupCommand(cmdPtr);
- ckfree((char *) resPtr);
- }
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * DupCmdNameInternalRep --
- *
- * Initialize the internal representation of an cmdName Tcl_Obj to a
- * copy of the internal representation of an existing cmdName object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * "copyPtr"s internal rep is set to point to the ResolvedCmdName
- * structure corresponding to "srcPtr"s internal rep. Increments the
- * ref count of the ResolvedCmdName structure pointed to by the
- * cmdName's internal representation.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupCmdNameInternalRep(srcPtr, copyPtr)
- Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
-{
- register ResolvedCmdName *resPtr =
- (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
-
- copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
- copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
- if (resPtr != NULL) {
- resPtr->refCount++;
- }
- copyPtr->typePtr = &tclCmdNameType;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * SetCmdNameFromAny --
- *
- * Generate an cmdName internal form for the Tcl object "objPtr".
- *
- * Results:
- * The return value is a standard Tcl result. The conversion always
- * succeeds and TCL_OK is returned.
- *
- * Side effects:
- * A pointer to a ResolvedCmdName structure that holds a cached pointer
- * to the command with a name that matches objPtr's string rep is
- * stored as objPtr's internal representation. This ResolvedCmdName
- * pointer will be NULL if no matching command was found. The ref count
- * of the cached Command's structure (if any) is also incremented.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetCmdNameFromAny(interp, objPtr)
- Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- register Tcl_Obj *objPtr; /* The object to convert. */
-{
- Interp *iPtr = (Interp *) interp;
- char *name;
- Tcl_Command cmd;
- register Command *cmdPtr;
- Namespace *currNsPtr;
- register ResolvedCmdName *resPtr;
-
- /*
- * Get "objPtr"s string representation. Make it up-to-date if necessary.
- */
-
- name = objPtr->bytes;
- if (name == NULL) {
- name = Tcl_GetString(objPtr);
- }
-
- /*
- * Find the Command structure, if any, that describes the command called
- * "name". Build a ResolvedCmdName that holds a cached pointer to this
- * Command, and bump the reference count in the referenced Command
- * structure. A Command structure will not be deleted as long as it is
- * referenced from a CmdName object.
- */
-
- cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
- /*flags*/ 0);
- cmdPtr = (Command *) cmd;
- if (cmdPtr != NULL) {
- /*
- * Get the current namespace.
- */
-
- if (iPtr->varFramePtr != NULL) {
- currNsPtr = iPtr->varFramePtr->nsPtr;
- } else {
- currNsPtr = iPtr->globalNsPtr;
- }
-
- cmdPtr->refCount++;
- resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
- resPtr->cmdPtr = cmdPtr;
- resPtr->refNsPtr = currNsPtr;
- resPtr->refNsId = currNsPtr->nsId;
- resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
- } else {
- resPtr = NULL; /* no command named "name" was found */
- }
-
- /*
- * Free the old internalRep before setting the new one. We do this as
- * late as possible to allow the conversion code, in particular
- * GetStringFromObj, to use that old internalRep. If no Command
- * structure was found, leave NULL as the cached value.
- */
-
- if ((objPtr->typePtr != NULL)
- && (objPtr->typePtr->freeIntRepProc != NULL)) {
- objPtr->typePtr->freeIntRepProc(objPtr);
- }
-
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
- return TCL_OK;
-}
-\f
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
return buf;
}
#endif /* TCL_COMPILE_DEBUG */
-
+++ /dev/null
-/*
- * tclExpr.c --
- *
- * This file contains the code to evaluate expressions for
- * Tcl.
- *
- * This implementation of floating-point support was modelled
- * after an initial implementation by Bill Carpenter.
- *
- * Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclExpr.c 1.92 96/09/06 13:22:44
- */
-
-#include "tclInt.h"
-#ifdef NO_FLOAT_H
-# include "../compat/float.h"
-#else
-# include <float.h>
-#endif
-#ifndef TCL_NO_MATH
-#include <math.h>
-#endif
-
-/*
- * The stuff below is a bit of a hack so that this file can be used
- * in environments that include no UNIX, i.e. no errno. Just define
- * errno here.
- */
-
-#ifndef TCL_GENERIC_ONLY
-#include "tclPort.h"
-#else
-#define NO_ERRNO_H
-#endif
-
-#ifdef NO_ERRNO_H
-int errno;
-#define EDOM 33
-#define ERANGE 34
-#endif
-
-/*
- * The data structure below is used to describe an expression value,
- * which can be either an integer (the usual case), a double-precision
- * floating-point value, or a string. A given number has only one
- * value at a time.
- */
-
-#define STATIC_STRING_SPACE 150
-
-typedef struct {
- long intValue; /* Integer value, if any. */
- double doubleValue; /* Floating-point value, if any. */
- ParseValue pv; /* Used to hold a string value, if any. */
- char staticSpace[STATIC_STRING_SPACE];
- /* Storage for small strings; large ones
- * are malloc-ed. */
- int type; /* Type of value: TYPE_INT, TYPE_DOUBLE,
- * or TYPE_STRING. */
-} Value;
-
-/*
- * Valid values for type:
- */
-
-#define TYPE_INT 0
-#define TYPE_DOUBLE 1
-#define TYPE_STRING 2
-
-/*
- * The data structure below describes the state of parsing an expression.
- * It's passed among the routines in this module.
- */
-
-typedef struct {
- char *originalExpr; /* The entire expression, as originally
- * passed to Tcl_ExprString et al. */
- char *expr; /* Position to the next character to be
- * scanned from the expression string. */
- int token; /* Type of the last token to be parsed from
- * expr. See below for definitions.
- * Corresponds to the characters just
- * before expr. */
-} ExprInfo;
-
-/*
- * The token types are defined below. In addition, there is a table
- * associating a precedence with each operator. The order of types
- * is important. Consult the code before changing it.
- */
-
-#define VALUE 0
-#define OPEN_PAREN 1
-#define CLOSE_PAREN 2
-#define COMMA 3
-#define END 4
-#define UNKNOWN 5
-
-/*
- * Binary operators:
- */
-
-#define MULT 8
-#define DIVIDE 9
-#define MOD 10
-#define PLUS 11
-#define MINUS 12
-#define LEFT_SHIFT 13
-#define RIGHT_SHIFT 14
-#define LESS 15
-#define GREATER 16
-#define LEQ 17
-#define GEQ 18
-#define EQUAL 19
-#define NEQ 20
-#define BIT_AND 21
-#define BIT_XOR 22
-#define BIT_OR 23
-#define AND 24
-#define OR 25
-#define QUESTY 26
-#define COLON 27
-
-/*
- * Unary operators:
- */
-
-#define UNARY_MINUS 28
-#define UNARY_PLUS 29
-#define NOT 30
-#define BIT_NOT 31
-
-/*
- * Precedence table. The values for non-operator token types are ignored.
- */
-
-static int precTable[] = {
- 0, 0, 0, 0, 0, 0, 0, 0,
- 12, 12, 12, /* MULT, DIVIDE, MOD */
- 11, 11, /* PLUS, MINUS */
- 10, 10, /* LEFT_SHIFT, RIGHT_SHIFT */
- 9, 9, 9, 9, /* LESS, GREATER, LEQ, GEQ */
- 8, 8, /* EQUAL, NEQ */
- 7, /* BIT_AND */
- 6, /* BIT_XOR */
- 5, /* BIT_OR */
- 4, /* AND */
- 3, /* OR */
- 2, /* QUESTY */
- 1, /* COLON */
- 13, 13, 13, 13 /* UNARY_MINUS, UNARY_PLUS, NOT,
- * BIT_NOT */
-};
-
-/*
- * Mapping from operator numbers to strings; used for error messages.
- */
-
-static char *operatorStrings[] = {
- "VALUE", "(", ")", ",", "END", "UNKNOWN", "6", "7",
- "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=",
- ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":",
- "-", "+", "!", "~"
-};
-
-/*
- * The following slight modification to DBL_MAX is needed because of
- * a compiler bug on Sprite (4/15/93).
- */
-
-#ifdef sprite
-#undef DBL_MAX
-#define DBL_MAX 1.797693134862316e+307
-#endif
-
-/*
- * Macros for testing floating-point values for certain special
- * cases. Test for not-a-number by comparing a value against
- * itself; test for infinity by comparing against the largest
- * floating-point value.
- */
-
-#define IS_NAN(v) ((v) != (v))
-#ifdef DBL_MAX
-# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
-#else
-# define IS_INF(v) 0
-#endif
-
-/*
- * The following global variable is use to signal matherr that Tcl
- * is responsible for the arithmetic, so errors can be handled in a
- * fashion appropriate for Tcl. Zero means no Tcl math is in
- * progress; non-zero means Tcl is doing math.
- */
-
-int tcl_MathInProgress = 0;
-
-/*
- * The variable below serves no useful purpose except to generate
- * a reference to matherr, so that the Tcl version of matherr is
- * linked in rather than the system version. Without this reference
- * the need for matherr won't be discovered during linking until after
- * libtcl.a has been processed, so Tcl's version won't be used.
- */
-
-#ifdef NEED_MATHERR
-extern int matherr();
-int (*tclMatherrPtr)() = matherr;
-#endif
-
-/*
- * Declarations for local procedures to this file:
- */
-
-static int ExprAbsFunc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-static int ExprDoubleFunc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-static int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int prec, Value *valuePtr));
-static int ExprIntFunc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-static int ExprLex _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, Value *valuePtr));
-static int ExprLooksLikeInt _ANSI_ARGS_((char *p));
-static void ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp,
- Value *valuePtr));
-static int ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, Value *valuePtr));
-static int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, Value *valuePtr));
-static int ExprRoundFunc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-static int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, Value *valuePtr));
-static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr));
-
-/*
- * Built-in math functions:
- */
-
-typedef struct {
- char *name; /* Name of function. */
- int numArgs; /* Number of arguments for function. */
- Tcl_ValueType argTypes[MAX_MATH_ARGS];
- /* Acceptable types for each argument. */
- Tcl_MathProc *proc; /* Procedure that implements this function. */
- ClientData clientData; /* Additional argument to pass to the function
- * when invoking it. */
-} BuiltinFunc;
-
-static BuiltinFunc funcTable[] = {
-#ifndef TCL_NO_MATH
- {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
- {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
- {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
- {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
- {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
- {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
- {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
- {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
- {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
- {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
- {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
- {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
- {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
- {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
- {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
- {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
- {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
- {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
- {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
-#endif
- {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
- {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
- {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
- {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
-
- {0},
-};
-\f
-/*
- *--------------------------------------------------------------
- *
- * ExprParseString --
- *
- * Given a string (such as one coming from command or variable
- * substitution), make a Value based on the string. The value
- * will be a floating-point or integer, if possible, or else it
- * will just be a copy of the string.
- *
- * Results:
- * TCL_OK is returned under normal circumstances, and TCL_ERROR
- * is returned if a floating-point overflow or underflow occurred
- * while reading in a number. The value at *valuePtr is modified
- * to hold a number, if possible.
- *
- * Side effects:
- * None.
- *
- *--------------------------------------------------------------
- */
-
-static int
-ExprParseString(interp, string, valuePtr)
- Tcl_Interp *interp; /* Where to store error message. */
- char *string; /* String to turn into value. */
- Value *valuePtr; /* Where to store value information.
- * Caller must have initialized pv field. */
-{
- char *term, *p, *start;
-
- if (*string != 0) {
- if (ExprLooksLikeInt(string)) {
- valuePtr->type = TYPE_INT;
- errno = 0;
-
- /*
- * Note: use strtoul instead of strtol for integer conversions
- * to allow full-size unsigned numbers, but don't depend on
- * strtoul to handle sign characters; it won't in some
- * implementations.
- */
-
- for (p = string; isspace(UCHAR(*p)); p++) {
- /* Empty loop body. */
- }
- if (*p == '-') {
- start = p+1;
- valuePtr->intValue = -((int)strtoul(start, &term, 0));
- } else if (*p == '+') {
- start = p+1;
- valuePtr->intValue = strtoul(start, &term, 0);
- } else {
- start = p;
- valuePtr->intValue = strtoul(start, &term, 0);
- }
- if (*term == 0) {
- if (errno == ERANGE) {
- /*
- * This procedure is sometimes called with string in
- * interp->result, so we have to clear the result before
- * logging an error message.
- */
-
- Tcl_ResetResult(interp);
- interp->result = "integer value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- interp->result, (char *) NULL);
- return TCL_ERROR;
- } else {
- return TCL_OK;
- }
- }
- } else {
- errno = 0;
- valuePtr->doubleValue = strtod(string, &term);
- if ((term != string) && (*term == 0)) {
- if (errno != 0) {
- Tcl_ResetResult(interp);
- TclExprFloatError(interp, valuePtr->doubleValue);
- return TCL_ERROR;
- }
- valuePtr->type = TYPE_DOUBLE;
- return TCL_OK;
- }
- }
- }
-
- /*
- * Not a valid number. Save a string value (but don't do anything
- * if it's already the value).
- */
-
- valuePtr->type = TYPE_STRING;
- if (string != valuePtr->pv.buffer) {
- int length, shortfall;
-
- length = strlen(string);
- valuePtr->pv.next = valuePtr->pv.buffer;
- shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer);
- if (shortfall > 0) {
- (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
- }
- strcpy(valuePtr->pv.buffer, string);
- }
- return TCL_OK;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * ExprLex --
- *
- * Lexical analyzer for expression parser: parses a single value,
- * operator, or other syntactic element from an expression string.
- *
- * Results:
- * TCL_OK is returned unless an error occurred while doing lexical
- * analysis or executing an embedded command. In that case a
- * standard Tcl error is returned, using interp->result to hold
- * an error message. In the event of a successful return, the token
- * and field in infoPtr is updated to refer to the next symbol in
- * the expression string, and the expr field is advanced past that
- * token; if the token is a value, then the value is stored at
- * valuePtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ExprLex(interp, infoPtr, valuePtr)
- Tcl_Interp *interp; /* Interpreter to use for error
- * reporting. */
- register ExprInfo *infoPtr; /* Describes the state of the parse. */
- register Value *valuePtr; /* Where to store value, if that is
- * what's parsed from string. Caller
- * must have initialized pv field
- * correctly. */
-{
- register char *p;
- char *var, *term;
- int result;
-
- p = infoPtr->expr;
- while (isspace(UCHAR(*p))) {
- p++;
- }
- if (*p == 0) {
- infoPtr->token = END;
- infoPtr->expr = p;
- return TCL_OK;
- }
-
- /*
- * First try to parse the token as an integer or floating-point number.
- * Don't want to check for a number if the first character is "+"
- * or "-". If we do, we might treat a binary operator as unary by
- * mistake, which will eventually cause a syntax error.
- */
-
- if ((*p != '+') && (*p != '-')) {
- if (ExprLooksLikeInt(p)) {
- errno = 0;
- valuePtr->intValue = strtoul(p, &term, 0);
- if (errno == ERANGE) {
- interp->result = "integer value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- interp->result, (char *) NULL);
- return TCL_ERROR;
- }
- infoPtr->token = VALUE;
- infoPtr->expr = term;
- valuePtr->type = TYPE_INT;
- return TCL_OK;
- } else {
- errno = 0;
- valuePtr->doubleValue = strtod(p, &term);
- if (term != p) {
- if (errno != 0) {
- TclExprFloatError(interp, valuePtr->doubleValue);
- return TCL_ERROR;
- }
- infoPtr->token = VALUE;
- infoPtr->expr = term;
- valuePtr->type = TYPE_DOUBLE;
- return TCL_OK;
- }
- }
- }
-
- infoPtr->expr = p+1;
- switch (*p) {
- case '$':
-
- /*
- * Variable. Fetch its value, then see if it makes sense
- * as an integer or floating-point number.
- */
-
- infoPtr->token = VALUE;
- var = Tcl_ParseVar(interp, p, &infoPtr->expr);
- if (var == NULL) {
- return TCL_ERROR;
- }
- Tcl_ResetResult(interp);
- if (((Interp *) interp)->noEval) {
- valuePtr->type = TYPE_INT;
- valuePtr->intValue = 0;
- return TCL_OK;
- }
- return ExprParseString(interp, var, valuePtr);
-
- case '[':
- infoPtr->token = VALUE;
- ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM;
- result = Tcl_Eval(interp, p+1);
- infoPtr->expr = ((Interp *) interp)->termPtr;
- if (result != TCL_OK) {
- return result;
- }
- infoPtr->expr++;
- if (((Interp *) interp)->noEval) {
- valuePtr->type = TYPE_INT;
- valuePtr->intValue = 0;
- Tcl_ResetResult(interp);
- return TCL_OK;
- }
- result = ExprParseString(interp, interp->result, valuePtr);
- if (result != TCL_OK) {
- return result;
- }
- Tcl_ResetResult(interp);
- return TCL_OK;
-
- case '"':
- infoPtr->token = VALUE;
- result = TclParseQuotes(interp, infoPtr->expr, '"', 0,
- &infoPtr->expr, &valuePtr->pv);
- if (result != TCL_OK) {
- return result;
- }
- Tcl_ResetResult(interp);
- return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
-
- case '{':
- infoPtr->token = VALUE;
- result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr,
- &valuePtr->pv);
- if (result != TCL_OK) {
- return result;
- }
- Tcl_ResetResult(interp);
- return ExprParseString(interp, valuePtr->pv.buffer, valuePtr);
-
- case '(':
- infoPtr->token = OPEN_PAREN;
- return TCL_OK;
-
- case ')':
- infoPtr->token = CLOSE_PAREN;
- return TCL_OK;
-
- case ',':
- infoPtr->token = COMMA;
- return TCL_OK;
-
- case '*':
- infoPtr->token = MULT;
- return TCL_OK;
-
- case '/':
- infoPtr->token = DIVIDE;
- return TCL_OK;
-
- case '%':
- infoPtr->token = MOD;
- return TCL_OK;
-
- case '+':
- infoPtr->token = PLUS;
- return TCL_OK;
-
- case '-':
- infoPtr->token = MINUS;
- return TCL_OK;
-
- case '?':
- infoPtr->token = QUESTY;
- return TCL_OK;
-
- case ':':
- infoPtr->token = COLON;
- return TCL_OK;
-
- case '<':
- switch (p[1]) {
- case '<':
- infoPtr->expr = p+2;
- infoPtr->token = LEFT_SHIFT;
- break;
- case '=':
- infoPtr->expr = p+2;
- infoPtr->token = LEQ;
- break;
- default:
- infoPtr->token = LESS;
- break;
- }
- return TCL_OK;
-
- case '>':
- switch (p[1]) {
- case '>':
- infoPtr->expr = p+2;
- infoPtr->token = RIGHT_SHIFT;
- break;
- case '=':
- infoPtr->expr = p+2;
- infoPtr->token = GEQ;
- break;
- default:
- infoPtr->token = GREATER;
- break;
- }
- return TCL_OK;
-
- case '=':
- if (p[1] == '=') {
- infoPtr->expr = p+2;
- infoPtr->token = EQUAL;
- } else {
- infoPtr->token = UNKNOWN;
- }
- return TCL_OK;
-
- case '!':
- if (p[1] == '=') {
- infoPtr->expr = p+2;
- infoPtr->token = NEQ;
- } else {
- infoPtr->token = NOT;
- }
- return TCL_OK;
-
- case '&':
- if (p[1] == '&') {
- infoPtr->expr = p+2;
- infoPtr->token = AND;
- } else {
- infoPtr->token = BIT_AND;
- }
- return TCL_OK;
-
- case '^':
- infoPtr->token = BIT_XOR;
- return TCL_OK;
-
- case '|':
- if (p[1] == '|') {
- infoPtr->expr = p+2;
- infoPtr->token = OR;
- } else {
- infoPtr->token = BIT_OR;
- }
- return TCL_OK;
-
- case '~':
- infoPtr->token = BIT_NOT;
- return TCL_OK;
-
- default:
- if (isalpha(UCHAR(*p))) {
- infoPtr->expr = p;
- return ExprMathFunc(interp, infoPtr, valuePtr);
- }
- infoPtr->expr = p+1;
- infoPtr->token = UNKNOWN;
- return TCL_OK;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * ExprGetValue --
- *
- * Parse a "value" from the remainder of the expression in infoPtr.
- *
- * Results:
- * Normally TCL_OK is returned. The value of the expression is
- * returned in *valuePtr. If an error occurred, then interp->result
- * contains an error message and TCL_ERROR is returned.
- * InfoPtr->token will be left pointing to the token AFTER the
- * expression, and infoPtr->expr will point to the character just
- * after the terminating token.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ExprGetValue(interp, infoPtr, prec, valuePtr)
- Tcl_Interp *interp; /* Interpreter to use for error
- * reporting. */
- register ExprInfo *infoPtr; /* Describes the state of the parse
- * just before the value (i.e. ExprLex
- * will be called to get first token
- * of value). */
- int prec; /* Treat any un-parenthesized operator
- * with precedence <= this as the end
- * of the expression. */
- Value *valuePtr; /* Where to store the value of the
- * expression. Caller must have
- * initialized pv field. */
-{
- Interp *iPtr = (Interp *) interp;
- Value value2; /* Second operand for current
- * operator. */
- int operator; /* Current operator (either unary
- * or binary). */
- int badType; /* Type of offending argument; used
- * for error messages. */
- int gotOp; /* Non-zero means already lexed the
- * operator (while picking up value
- * for unary operator). Don't lex
- * again. */
- int result;
-
- /*
- * There are two phases to this procedure. First, pick off an initial
- * value. Then, parse (binary operator, value) pairs until done.
- */
-
- gotOp = 0;
- value2.pv.buffer = value2.pv.next = value2.staticSpace;
- value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1;
- value2.pv.expandProc = TclExpandParseValue;
- value2.pv.clientData = (ClientData) NULL;
- result = ExprLex(interp, infoPtr, valuePtr);
- if (result != TCL_OK) {
- goto done;
- }
- if (infoPtr->token == OPEN_PAREN) {
-
- /*
- * Parenthesized sub-expression.
- */
-
- result = ExprGetValue(interp, infoPtr, -1, valuePtr);
- if (result != TCL_OK) {
- goto done;
- }
- if (infoPtr->token != CLOSE_PAREN) {
- Tcl_AppendResult(interp, "unmatched parentheses in expression \"",
- infoPtr->originalExpr, "\"", (char *) NULL);
- result = TCL_ERROR;
- goto done;
- }
- } else {
- if (infoPtr->token == MINUS) {
- infoPtr->token = UNARY_MINUS;
- }
- if (infoPtr->token == PLUS) {
- infoPtr->token = UNARY_PLUS;
- }
- if (infoPtr->token >= UNARY_MINUS) {
-
- /*
- * Process unary operators.
- */
-
- operator = infoPtr->token;
- result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token],
- valuePtr);
- if (result != TCL_OK) {
- goto done;
- }
- if (!iPtr->noEval) {
- switch (operator) {
- case UNARY_MINUS:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue = -valuePtr->intValue;
- } else if (valuePtr->type == TYPE_DOUBLE){
- valuePtr->doubleValue = -valuePtr->doubleValue;
- } else {
- badType = valuePtr->type;
- goto illegalType;
- }
- break;
- case UNARY_PLUS:
- if ((valuePtr->type != TYPE_INT)
- && (valuePtr->type != TYPE_DOUBLE)) {
- badType = valuePtr->type;
- goto illegalType;
- }
- break;
- case NOT:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue = !valuePtr->intValue;
- } else if (valuePtr->type == TYPE_DOUBLE) {
- /*
- * Theoretically, should be able to use
- * "!valuePtr->intValue", but apparently some
- * compilers can't handle it.
- */
- if (valuePtr->doubleValue == 0.0) {
- valuePtr->intValue = 1;
- } else {
- valuePtr->intValue = 0;
- }
- valuePtr->type = TYPE_INT;
- } else {
- badType = valuePtr->type;
- goto illegalType;
- }
- break;
- case BIT_NOT:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue = ~valuePtr->intValue;
- } else {
- badType = valuePtr->type;
- goto illegalType;
- }
- break;
- }
- }
- gotOp = 1;
- } else if (infoPtr->token != VALUE) {
- goto syntaxError;
- }
- }
-
- /*
- * Got the first operand. Now fetch (operator, operand) pairs.
- */
-
- if (!gotOp) {
- result = ExprLex(interp, infoPtr, &value2);
- if (result != TCL_OK) {
- goto done;
- }
- }
- while (1) {
- operator = infoPtr->token;
- value2.pv.next = value2.pv.buffer;
- if ((operator < MULT) || (operator >= UNARY_MINUS)) {
- if ((operator == END) || (operator == CLOSE_PAREN)
- || (operator == COMMA)) {
- result = TCL_OK;
- goto done;
- } else {
- goto syntaxError;
- }
- }
- if (precTable[operator] <= prec) {
- result = TCL_OK;
- goto done;
- }
-
- /*
- * If we're doing an AND or OR and the first operand already
- * determines the result, don't execute anything in the
- * second operand: just parse. Same style for ?: pairs.
- */
-
- if ((operator == AND) || (operator == OR) || (operator == QUESTY)) {
- if (valuePtr->type == TYPE_DOUBLE) {
- valuePtr->intValue = valuePtr->doubleValue != 0;
- valuePtr->type = TYPE_INT;
- } else if (valuePtr->type == TYPE_STRING) {
- if (!iPtr->noEval) {
- badType = TYPE_STRING;
- goto illegalType;
- }
-
- /*
- * Must set valuePtr->intValue to avoid referencing
- * uninitialized memory in the "if" below; the actual
- * value doesn't matter, since it will be ignored.
- */
-
- valuePtr->intValue = 0;
- }
- if (((operator == AND) && !valuePtr->intValue)
- || ((operator == OR) && valuePtr->intValue)) {
- iPtr->noEval++;
- result = ExprGetValue(interp, infoPtr, precTable[operator],
- &value2);
- iPtr->noEval--;
- if (result != TCL_OK) {
- goto done;
- }
- if (operator == OR) {
- valuePtr->intValue = 1;
- }
- continue;
- } else if (operator == QUESTY) {
- /*
- * Special note: ?: operators must associate right to
- * left. To make this happen, use a precedence one lower
- * than QUESTY when calling ExprGetValue recursively.
- */
-
- if (valuePtr->intValue != 0) {
- valuePtr->pv.next = valuePtr->pv.buffer;
- result = ExprGetValue(interp, infoPtr,
- precTable[QUESTY] - 1, valuePtr);
- if (result != TCL_OK) {
- goto done;
- }
- if (infoPtr->token != COLON) {
- goto syntaxError;
- }
- value2.pv.next = value2.pv.buffer;
- iPtr->noEval++;
- result = ExprGetValue(interp, infoPtr,
- precTable[QUESTY] - 1, &value2);
- iPtr->noEval--;
- } else {
- iPtr->noEval++;
- result = ExprGetValue(interp, infoPtr,
- precTable[QUESTY] - 1, &value2);
- iPtr->noEval--;
- if (result != TCL_OK) {
- goto done;
- }
- if (infoPtr->token != COLON) {
- goto syntaxError;
- }
- valuePtr->pv.next = valuePtr->pv.buffer;
- result = ExprGetValue(interp, infoPtr,
- precTable[QUESTY] - 1, valuePtr);
- if (result != TCL_OK) {
- goto done;
- }
- }
- continue;
- } else {
- result = ExprGetValue(interp, infoPtr, precTable[operator],
- &value2);
- }
- } else {
- result = ExprGetValue(interp, infoPtr, precTable[operator],
- &value2);
- }
- if (result != TCL_OK) {
- goto done;
- }
- if ((infoPtr->token < MULT) && (infoPtr->token != VALUE)
- && (infoPtr->token != END) && (infoPtr->token != COMMA)
- && (infoPtr->token != CLOSE_PAREN)) {
- goto syntaxError;
- }
-
- if (iPtr->noEval) {
- continue;
- }
-
- /*
- * At this point we've got two values and an operator. Check
- * to make sure that the particular data types are appropriate
- * for the particular operator, and perform type conversion
- * if necessary.
- */
-
- switch (operator) {
-
- /*
- * For the operators below, no strings are allowed and
- * ints get converted to floats if necessary.
- */
-
- case MULT: case DIVIDE: case PLUS: case MINUS:
- if ((valuePtr->type == TYPE_STRING)
- || (value2.type == TYPE_STRING)) {
- badType = TYPE_STRING;
- goto illegalType;
- }
- if (valuePtr->type == TYPE_DOUBLE) {
- if (value2.type == TYPE_INT) {
- value2.doubleValue = value2.intValue;
- value2.type = TYPE_DOUBLE;
- }
- } else if (value2.type == TYPE_DOUBLE) {
- if (valuePtr->type == TYPE_INT) {
- valuePtr->doubleValue = valuePtr->intValue;
- valuePtr->type = TYPE_DOUBLE;
- }
- }
- break;
-
- /*
- * For the operators below, only integers are allowed.
- */
-
- case MOD: case LEFT_SHIFT: case RIGHT_SHIFT:
- case BIT_AND: case BIT_XOR: case BIT_OR:
- if (valuePtr->type != TYPE_INT) {
- badType = valuePtr->type;
- goto illegalType;
- } else if (value2.type != TYPE_INT) {
- badType = value2.type;
- goto illegalType;
- }
- break;
-
- /*
- * For the operators below, any type is allowed but the
- * two operands must have the same type. Convert integers
- * to floats and either to strings, if necessary.
- */
-
- case LESS: case GREATER: case LEQ: case GEQ:
- case EQUAL: case NEQ:
- if (valuePtr->type == TYPE_STRING) {
- if (value2.type != TYPE_STRING) {
- ExprMakeString(interp, &value2);
- }
- } else if (value2.type == TYPE_STRING) {
- if (valuePtr->type != TYPE_STRING) {
- ExprMakeString(interp, valuePtr);
- }
- } else if (valuePtr->type == TYPE_DOUBLE) {
- if (value2.type == TYPE_INT) {
- value2.doubleValue = value2.intValue;
- value2.type = TYPE_DOUBLE;
- }
- } else if (value2.type == TYPE_DOUBLE) {
- if (valuePtr->type == TYPE_INT) {
- valuePtr->doubleValue = valuePtr->intValue;
- valuePtr->type = TYPE_DOUBLE;
- }
- }
- break;
-
- /*
- * For the operators below, no strings are allowed, but
- * no int->double conversions are performed.
- */
-
- case AND: case OR:
- if (valuePtr->type == TYPE_STRING) {
- badType = valuePtr->type;
- goto illegalType;
- }
- if (value2.type == TYPE_STRING) {
- badType = value2.type;
- goto illegalType;
- }
- break;
-
- /*
- * For the operators below, type and conversions are
- * irrelevant: they're handled elsewhere.
- */
-
- case QUESTY: case COLON:
- break;
-
- /*
- * Any other operator is an error.
- */
-
- default:
- interp->result = "unknown operator in expression";
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * Carry out the function of the specified operator.
- */
-
- switch (operator) {
- case MULT:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue = valuePtr->intValue * value2.intValue;
- } else {
- valuePtr->doubleValue *= value2.doubleValue;
- }
- break;
- case DIVIDE:
- case MOD:
- if (valuePtr->type == TYPE_INT) {
- long divisor, quot, rem;
- int negative;
-
- if (value2.intValue == 0) {
- divideByZero:
- interp->result = "divide by zero";
- Tcl_SetErrorCode(interp, "ARITH", "DIVZERO",
- interp->result, (char *) NULL);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * The code below is tricky because C doesn't guarantee
- * much about the properties of the quotient or
- * remainder, but Tcl does: the remainder always has
- * the same sign as the divisor and a smaller absolute
- * value.
- */
-
- divisor = value2.intValue;
- negative = 0;
- if (divisor < 0) {
- divisor = -divisor;
- valuePtr->intValue = -valuePtr->intValue;
- negative = 1;
- }
- quot = valuePtr->intValue / divisor;
- rem = valuePtr->intValue % divisor;
- if (rem < 0) {
- rem += divisor;
- quot -= 1;
- }
- if (negative) {
- rem = -rem;
- }
- valuePtr->intValue = (operator == DIVIDE) ? quot : rem;
- } else {
- if (value2.doubleValue == 0.0) {
- goto divideByZero;
- }
- valuePtr->doubleValue /= value2.doubleValue;
- }
- break;
- case PLUS:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue = valuePtr->intValue + value2.intValue;
- } else {
- valuePtr->doubleValue += value2.doubleValue;
- }
- break;
- case MINUS:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue = valuePtr->intValue - value2.intValue;
- } else {
- valuePtr->doubleValue -= value2.doubleValue;
- }
- break;
- case LEFT_SHIFT:
- valuePtr->intValue <<= value2.intValue;
- break;
- case RIGHT_SHIFT:
- /*
- * The following code is a bit tricky: it ensures that
- * right shifts propagate the sign bit even on machines
- * where ">>" won't do it by default.
- */
-
- if (valuePtr->intValue < 0) {
- valuePtr->intValue =
- ~((~valuePtr->intValue) >> value2.intValue);
- } else {
- valuePtr->intValue >>= value2.intValue;
- }
- break;
- case LESS:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue =
- valuePtr->intValue < value2.intValue;
- } else if (valuePtr->type == TYPE_DOUBLE) {
- valuePtr->intValue =
- valuePtr->doubleValue < value2.doubleValue;
- } else {
- valuePtr->intValue =
- strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0;
- }
- valuePtr->type = TYPE_INT;
- break;
- case GREATER:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue =
- valuePtr->intValue > value2.intValue;
- } else if (valuePtr->type == TYPE_DOUBLE) {
- valuePtr->intValue =
- valuePtr->doubleValue > value2.doubleValue;
- } else {
- valuePtr->intValue =
- strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0;
- }
- valuePtr->type = TYPE_INT;
- break;
- case LEQ:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue =
- valuePtr->intValue <= value2.intValue;
- } else if (valuePtr->type == TYPE_DOUBLE) {
- valuePtr->intValue =
- valuePtr->doubleValue <= value2.doubleValue;
- } else {
- valuePtr->intValue =
- strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0;
- }
- valuePtr->type = TYPE_INT;
- break;
- case GEQ:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue =
- valuePtr->intValue >= value2.intValue;
- } else if (valuePtr->type == TYPE_DOUBLE) {
- valuePtr->intValue =
- valuePtr->doubleValue >= value2.doubleValue;
- } else {
- valuePtr->intValue =
- strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0;
- }
- valuePtr->type = TYPE_INT;
- break;
- case EQUAL:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue =
- valuePtr->intValue == value2.intValue;
- } else if (valuePtr->type == TYPE_DOUBLE) {
- valuePtr->intValue =
- valuePtr->doubleValue == value2.doubleValue;
- } else {
- valuePtr->intValue =
- strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0;
- }
- valuePtr->type = TYPE_INT;
- break;
- case NEQ:
- if (valuePtr->type == TYPE_INT) {
- valuePtr->intValue =
- valuePtr->intValue != value2.intValue;
- } else if (valuePtr->type == TYPE_DOUBLE) {
- valuePtr->intValue =
- valuePtr->doubleValue != value2.doubleValue;
- } else {
- valuePtr->intValue =
- strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0;
- }
- valuePtr->type = TYPE_INT;
- break;
- case BIT_AND:
- valuePtr->intValue &= value2.intValue;
- break;
- case BIT_XOR:
- valuePtr->intValue ^= value2.intValue;
- break;
- case BIT_OR:
- valuePtr->intValue |= value2.intValue;
- break;
-
- /*
- * For AND and OR, we know that the first value has already
- * been converted to an integer. Thus we need only consider
- * the possibility of int vs. double for the second value.
- */
-
- case AND:
- if (value2.type == TYPE_DOUBLE) {
- value2.intValue = value2.doubleValue != 0;
- value2.type = TYPE_INT;
- }
- valuePtr->intValue = valuePtr->intValue && value2.intValue;
- break;
- case OR:
- if (value2.type == TYPE_DOUBLE) {
- value2.intValue = value2.doubleValue != 0;
- value2.type = TYPE_INT;
- }
- valuePtr->intValue = valuePtr->intValue || value2.intValue;
- break;
-
- case COLON:
- interp->result = "can't have : operator without ? first";
- result = TCL_ERROR;
- goto done;
- }
- }
-
- done:
- if (value2.pv.buffer != value2.staticSpace) {
- ckfree(value2.pv.buffer);
- }
- return result;
-
- syntaxError:
- Tcl_AppendResult(interp, "syntax error in expression \"",
- infoPtr->originalExpr, "\"", (char *) NULL);
- result = TCL_ERROR;
- goto done;
-
- illegalType:
- Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ?
- "floating-point value" : "non-numeric string",
- " as operand of \"", operatorStrings[operator], "\"",
- (char *) NULL);
- result = TCL_ERROR;
- goto done;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * ExprMakeString --
- *
- * Convert a value from int or double representation to
- * a string.
- *
- * Results:
- * The information at *valuePtr gets converted to string
- * format, if it wasn't that way already.
- *
- * Side effects:
- * None.
- *
- *--------------------------------------------------------------
- */
-
-static void
-ExprMakeString(interp, valuePtr)
- Tcl_Interp *interp; /* Interpreter to use for precision
- * information. */
- register Value *valuePtr; /* Value to be converted. */
-{
- int shortfall;
-
- shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer);
- if (shortfall > 0) {
- (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall);
- }
- if (valuePtr->type == TYPE_INT) {
- sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue);
- } else if (valuePtr->type == TYPE_DOUBLE) {
- Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer);
- }
- valuePtr->type = TYPE_STRING;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * ExprTopLevel --
- *
- * This procedure provides top-level functionality shared by
- * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc.
- *
- * Results:
- * The result is a standard Tcl return value. If an error
- * occurs then an error message is left in interp->result.
- * The value of the expression is returned in *valuePtr, in
- * whatever form it ends up in (could be string or integer
- * or double). Caller may need to convert result. Caller
- * is also responsible for freeing string memory in *valuePtr,
- * if any was allocated.
- *
- * Side effects:
- * None.
- *
- *--------------------------------------------------------------
- */
-
-static int
-ExprTopLevel(interp, string, valuePtr)
- Tcl_Interp *interp; /* Context in which to evaluate the
- * expression. */
- char *string; /* Expression to evaluate. */
- Value *valuePtr; /* Where to store result. Should
- * not be initialized by caller. */
-{
- ExprInfo info;
- int result;
-
- /*
- * Create the math functions the first time an expression is
- * evaluated.
- */
-
- if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) {
- BuiltinFunc *funcPtr;
-
- ((Interp *) interp)->flags |= EXPR_INITIALIZED;
- for (funcPtr = funcTable; funcPtr->name != NULL;
- funcPtr++) {
- Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs,
- funcPtr->argTypes, funcPtr->proc, funcPtr->clientData);
- }
- }
-
- info.originalExpr = string;
- info.expr = string;
- valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace;
- valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1;
- valuePtr->pv.expandProc = TclExpandParseValue;
- valuePtr->pv.clientData = (ClientData) NULL;
-
- result = ExprGetValue(interp, &info, -1, valuePtr);
- if (result != TCL_OK) {
- return result;
- }
- if (info.token != END) {
- Tcl_AppendResult(interp, "syntax error in expression \"",
- string, "\"", (char *) NULL);
- return TCL_ERROR;
- }
- if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue)
- || IS_INF(valuePtr->doubleValue))) {
- /*
- * IEEE floating-point error.
- */
-
- TclExprFloatError(interp, valuePtr->doubleValue);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
- *
- * Procedures to evaluate an expression and return its value
- * in a particular form.
- *
- * Results:
- * Each of the procedures below returns a standard Tcl result.
- * If an error occurs then an error message is left in
- * interp->result. Otherwise the value of the expression,
- * in the appropriate form, is stored at *resultPtr. If
- * the expression had a result that was incompatible with the
- * desired form then an error is returned.
- *
- * Side effects:
- * None.
- *
- *--------------------------------------------------------------
- */
-
-int
-Tcl_ExprLong(interp, string, ptr)
- Tcl_Interp *interp; /* Context in which to evaluate the
- * expression. */
- char *string; /* Expression to evaluate. */
- long *ptr; /* Where to store result. */
-{
- Value value;
- int result;
-
- result = ExprTopLevel(interp, string, &value);
- if (result == TCL_OK) {
- if (value.type == TYPE_INT) {
- *ptr = value.intValue;
- } else if (value.type == TYPE_DOUBLE) {
- *ptr = (long) value.doubleValue;
- } else {
- interp->result = "expression didn't have numeric value";
- result = TCL_ERROR;
- }
- }
- if (value.pv.buffer != value.staticSpace) {
- ckfree(value.pv.buffer);
- }
- return result;
-}
-
-int
-Tcl_ExprDouble(interp, string, ptr)
- Tcl_Interp *interp; /* Context in which to evaluate the
- * expression. */
- char *string; /* Expression to evaluate. */
- double *ptr; /* Where to store result. */
-{
- Value value;
- int result;
-
- result = ExprTopLevel(interp, string, &value);
- if (result == TCL_OK) {
- if (value.type == TYPE_INT) {
- *ptr = value.intValue;
- } else if (value.type == TYPE_DOUBLE) {
- *ptr = value.doubleValue;
- } else {
- interp->result = "expression didn't have numeric value";
- result = TCL_ERROR;
- }
- }
- if (value.pv.buffer != value.staticSpace) {
- ckfree(value.pv.buffer);
- }
- return result;
-}
-
-int
-Tcl_ExprBoolean(interp, string, ptr)
- Tcl_Interp *interp; /* Context in which to evaluate the
- * expression. */
- char *string; /* Expression to evaluate. */
- int *ptr; /* Where to store 0/1 result. */
-{
- Value value;
- int result;
-
- result = ExprTopLevel(interp, string, &value);
- if (result == TCL_OK) {
- if (value.type == TYPE_INT) {
- *ptr = value.intValue != 0;
- } else if (value.type == TYPE_DOUBLE) {
- *ptr = value.doubleValue != 0.0;
- } else {
- result = Tcl_GetBoolean(interp, value.pv.buffer, ptr);
- }
- }
- if (value.pv.buffer != value.staticSpace) {
- ckfree(value.pv.buffer);
- }
- return result;
-}
-\f
-/*
- *--------------------------------------------------------------
- *
- * Tcl_ExprString --
- *
- * Evaluate an expression and return its value in string form.
- *
- * Results:
- * A standard Tcl result. If the result is TCL_OK, then the
- * interpreter's result is set to the string value of the
- * expression. If the result is TCL_OK, then interp->result
- * contains an error message.
- *
- * Side effects:
- * None.
- *
- *--------------------------------------------------------------
- */
-
-int
-Tcl_ExprString(interp, string)
- Tcl_Interp *interp; /* Context in which to evaluate the
- * expression. */
- char *string; /* Expression to evaluate. */
-{
- Value value;
- int result;
-
- result = ExprTopLevel(interp, string, &value);
- if (result == TCL_OK) {
- if (value.type == TYPE_INT) {
- sprintf(interp->result, "%ld", value.intValue);
- } else if (value.type == TYPE_DOUBLE) {
- Tcl_PrintDouble(interp, value.doubleValue, interp->result);
- } else {
- if (value.pv.buffer != value.staticSpace) {
- interp->result = value.pv.buffer;
- interp->freeProc = TCL_DYNAMIC;
- value.pv.buffer = value.staticSpace;
- } else {
- Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE);
- }
- }
- }
- if (value.pv.buffer != value.staticSpace) {
- ckfree(value.pv.buffer);
- }
- return result;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateMathFunc --
- *
- * Creates a new math function for expressions in a given
- * interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The function defined by "name" is created; if such a function
- * already existed then its definition is overriden.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
- Tcl_Interp *interp; /* Interpreter in which function is
- * to be available. */
- char *name; /* Name of function (e.g. "sin"). */
- int numArgs; /* Nnumber of arguments required by
- * function. */
- Tcl_ValueType *argTypes; /* Array of types acceptable for
- * each argument. */
- Tcl_MathProc *proc; /* Procedure that implements the
- * math function. */
- ClientData clientData; /* Additional value to pass to the
- * function. */
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hPtr;
- MathFunc *mathFuncPtr;
- int new, i;
-
- hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
- if (new) {
- Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
- }
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
- if (numArgs > MAX_MATH_ARGS) {
- numArgs = MAX_MATH_ARGS;
- }
- mathFuncPtr->numArgs = numArgs;
- for (i = 0; i < numArgs; i++) {
- mathFuncPtr->argTypes[i] = argTypes[i];
- }
- mathFuncPtr->proc = proc;
- mathFuncPtr->clientData = clientData;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * ExprMathFunc --
- *
- * This procedure is invoked to parse a math function from an
- * expression string, carry out the function, and return the
- * value computed.
- *
- * Results:
- * TCL_OK is returned if all went well and the function's value
- * was computed successfully. If an error occurred, TCL_ERROR
- * is returned and an error message is left in interp->result.
- * After a successful return infoPtr has been updated to refer
- * to the character just after the function call, the token is
- * set to VALUE, and the value is stored in valuePtr.
- *
- * Side effects:
- * Embedded commands could have arbitrary side-effects.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ExprMathFunc(interp, infoPtr, valuePtr)
- Tcl_Interp *interp; /* Interpreter to use for error
- * reporting. */
- register ExprInfo *infoPtr; /* Describes the state of the parse.
- * infoPtr->expr must point to the
- * first character of the function's
- * name. */
- register Value *valuePtr; /* Where to store value, if that is
- * what's parsed from string. Caller
- * must have initialized pv field
- * correctly. */
-{
- Interp *iPtr = (Interp *) interp;
- MathFunc *mathFuncPtr; /* Info about math function. */
- Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
- Tcl_Value funcResult; /* Result of function call. */
- Tcl_HashEntry *hPtr;
- char *p, *funcName, savedChar;
- int i, result;
-
- /*
- * Find the end of the math function's name and lookup the MathFunc
- * record for the function.
- */
-
- p = funcName = infoPtr->expr;
- while (isalnum(UCHAR(*p)) || (*p == '_')) {
- p++;
- }
- infoPtr->expr = p;
- result = ExprLex(interp, infoPtr, valuePtr);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
- if (infoPtr->token != OPEN_PAREN) {
- goto syntaxError;
- }
- savedChar = *p;
- *p = 0;
- hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
- if (hPtr == NULL) {
- Tcl_AppendResult(interp, "unknown math function \"", funcName,
- "\"", (char *) NULL);
- *p = savedChar;
- return TCL_ERROR;
- }
- *p = savedChar;
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
-
- /*
- * Scan off the arguments for the function, if there are any.
- */
-
- if (mathFuncPtr->numArgs == 0) {
- result = ExprLex(interp, infoPtr, valuePtr);
- if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) {
- goto syntaxError;
- }
- } else {
- for (i = 0; ; i++) {
- valuePtr->pv.next = valuePtr->pv.buffer;
- result = ExprGetValue(interp, infoPtr, -1, valuePtr);
- if (result != TCL_OK) {
- return result;
- }
- if (valuePtr->type == TYPE_STRING) {
- interp->result =
- "argument to math function didn't have numeric value";
- return TCL_ERROR;
- }
-
- /*
- * Copy the value to the argument record, converting it if
- * necessary.
- */
-
- if (valuePtr->type == TYPE_INT) {
- if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) {
- args[i].type = TCL_DOUBLE;
- args[i].doubleValue = valuePtr->intValue;
- } else {
- args[i].type = TCL_INT;
- args[i].intValue = valuePtr->intValue;
- }
- } else {
- if (mathFuncPtr->argTypes[i] == TCL_INT) {
- args[i].type = TCL_INT;
- args[i].intValue = (long) valuePtr->doubleValue;
- } else {
- args[i].type = TCL_DOUBLE;
- args[i].doubleValue = valuePtr->doubleValue;
- }
- }
-
- /*
- * Check for a comma separator between arguments or a close-paren
- * to end the argument list.
- */
-
- if (i == (mathFuncPtr->numArgs-1)) {
- if (infoPtr->token == CLOSE_PAREN) {
- break;
- }
- if (infoPtr->token == COMMA) {
- interp->result = "too many arguments for math function";
- return TCL_ERROR;
- } else {
- goto syntaxError;
- }
- }
- if (infoPtr->token != COMMA) {
- if (infoPtr->token == CLOSE_PAREN) {
- interp->result = "too few arguments for math function";
- return TCL_ERROR;
- } else {
- goto syntaxError;
- }
- }
- }
- }
- if (iPtr->noEval) {
- valuePtr->type = TYPE_INT;
- valuePtr->intValue = 0;
- infoPtr->token = VALUE;
- return TCL_OK;
- }
-
- /*
- * Invoke the function and copy its result back into valuePtr.
- */
-
- tcl_MathInProgress++;
- result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
- &funcResult);
- tcl_MathInProgress--;
- if (result != TCL_OK) {
- return result;
- }
- if (funcResult.type == TCL_INT) {
- valuePtr->type = TYPE_INT;
- valuePtr->intValue = funcResult.intValue;
- } else {
- valuePtr->type = TYPE_DOUBLE;
- valuePtr->doubleValue = funcResult.doubleValue;
- }
- infoPtr->token = VALUE;
- return TCL_OK;
-
- syntaxError:
- Tcl_AppendResult(interp, "syntax error in expression \"",
- infoPtr->originalExpr, "\"", (char *) NULL);
- return TCL_ERROR;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclExprFloatError --
- *
- * This procedure is called when an error occurs during a
- * floating-point operation. It reads errno and sets
- * interp->result accordingly.
- *
- * Results:
- * Interp->result is set to hold an error message.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclExprFloatError(interp, value)
- Tcl_Interp *interp; /* Where to store error message. */
- double value; /* Value returned after error; used to
- * distinguish underflows from overflows. */
-{
- char buf[20];
-
- if ((errno == EDOM) || (value != value)) {
- interp->result = "domain error: argument not in valid range";
- Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result,
- (char *) NULL);
- } else if ((errno == ERANGE) || IS_INF(value)) {
- if (value == 0.0) {
- interp->result = "floating-point value too small to represent";
- Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result,
- (char *) NULL);
- } else {
- interp->result = "floating-point value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result,
- (char *) NULL);
- }
- } else {
- sprintf(buf, "%d", errno);
- Tcl_AppendResult(interp, "unknown floating-point error, ",
- "errno = ", buf, (char *) NULL);
- Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result,
- (char *) NULL);
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Math Functions --
- *
- * This page contains the procedures that implement all of the
- * built-in math functions for expressions.
- *
- * Results:
- * Each procedure returns TCL_OK if it succeeds and places result
- * information at *resultPtr. If it fails it returns TCL_ERROR
- * and leaves an error message in interp->result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ExprUnaryFunc(clientData, interp, args, resultPtr)
- ClientData clientData; /* Contains address of procedure that
- * takes one double argument and
- * returns a double result. */
- Tcl_Interp *interp;
- Tcl_Value *args;
- Tcl_Value *resultPtr;
-{
- double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData;
-
- errno = 0;
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = (*func)(args[0].doubleValue);
- if (errno != 0) {
- TclExprFloatError(interp, resultPtr->doubleValue);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-static int
-ExprBinaryFunc(clientData, interp, args, resultPtr)
- ClientData clientData; /* Contains address of procedure that
- * takes two double arguments and
- * returns a double result. */
- Tcl_Interp *interp;
- Tcl_Value *args;
- Tcl_Value *resultPtr;
-{
- double (*func) _ANSI_ARGS_((double, double))
- = (double (*)_ANSI_ARGS_((double, double))) clientData;
-
- errno = 0;
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue);
- if (errno != 0) {
- TclExprFloatError(interp, resultPtr->doubleValue);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
- /* ARGSUSED */
-static int
-ExprAbsFunc(clientData, interp, args, resultPtr)
- ClientData clientData;
- Tcl_Interp *interp;
- Tcl_Value *args;
- Tcl_Value *resultPtr;
-{
- resultPtr->type = TCL_DOUBLE;
- if (args[0].type == TCL_DOUBLE) {
- resultPtr->type = TCL_DOUBLE;
- if (args[0].doubleValue < 0) {
- resultPtr->doubleValue = -args[0].doubleValue;
- } else {
- resultPtr->doubleValue = args[0].doubleValue;
- }
- } else {
- resultPtr->type = TCL_INT;
- if (args[0].intValue < 0) {
- resultPtr->intValue = -args[0].intValue;
- if (resultPtr->intValue < 0) {
- interp->result = "integer value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result,
- (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- resultPtr->intValue = args[0].intValue;
- }
- }
- return TCL_OK;
-}
-
- /* ARGSUSED */
-static int
-ExprDoubleFunc(clientData, interp, args, resultPtr)
- ClientData clientData;
- Tcl_Interp *interp;
- Tcl_Value *args;
- Tcl_Value *resultPtr;
-{
- resultPtr->type = TCL_DOUBLE;
- if (args[0].type == TCL_DOUBLE) {
- resultPtr->doubleValue = args[0].doubleValue;
- } else {
- resultPtr->doubleValue = args[0].intValue;
- }
- return TCL_OK;
-}
-
- /* ARGSUSED */
-static int
-ExprIntFunc(clientData, interp, args, resultPtr)
- ClientData clientData;
- Tcl_Interp *interp;
- Tcl_Value *args;
- Tcl_Value *resultPtr;
-{
- resultPtr->type = TCL_INT;
- if (args[0].type == TCL_INT) {
- resultPtr->intValue = args[0].intValue;
- } else {
- if (args[0].doubleValue < 0) {
- if (args[0].doubleValue < (double) (long) LONG_MIN) {
- tooLarge:
- interp->result = "integer value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- interp->result, (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- if (args[0].doubleValue > (double) LONG_MAX) {
- goto tooLarge;
- }
- }
- resultPtr->intValue = (long) args[0].doubleValue;
- }
- return TCL_OK;
-}
-
- /* ARGSUSED */
-static int
-ExprRoundFunc(clientData, interp, args, resultPtr)
- ClientData clientData;
- Tcl_Interp *interp;
- Tcl_Value *args;
- Tcl_Value *resultPtr;
-{
- resultPtr->type = TCL_INT;
- if (args[0].type == TCL_INT) {
- resultPtr->intValue = args[0].intValue;
- } else {
- if (args[0].doubleValue < 0) {
- if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) {
- tooLarge:
- interp->result = "integer value too large to represent";
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- interp->result, (char *) NULL);
- return TCL_ERROR;
- }
- resultPtr->intValue = (long) (args[0].doubleValue - 0.5);
- } else {
- if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) {
- goto tooLarge;
- }
- resultPtr->intValue = (long) (args[0].doubleValue + 0.5);
- }
- }
- return TCL_OK;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * ExprLooksLikeInt --
- *
- * This procedure decides whether the leading characters of a
- * string look like an integer or something else (such as a
- * floating-point number or string).
- *
- * Results:
- * The return value is 1 if the leading characters of p look
- * like a valid Tcl integer. If they look like a floating-point
- * number (e.g. "e01" or "2.4"), or if they don't look like a
- * number at all, then 0 is returned.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ExprLooksLikeInt(p)
- char *p; /* Pointer to string. */
-{
- while (isspace(UCHAR(*p))) {
- p++;
- }
- if ((*p == '+') || (*p == '-')) {
- p++;
- }
- if (!isdigit(UCHAR(*p))) {
- return 0;
- }
- p++;
- while (isdigit(UCHAR(*p))) {
- p++;
- }
- if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
- return 1;
- }
- return 0;
-}
*/
static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
- char *source, char *dest, int copyFlag,
- int force));
-static char * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
- char *path, Tcl_DString *bufferPtr));
+ Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
+ int copyFlag, int force));
+static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr));
static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, int copyFlag));
+ int objc, Tcl_Obj *CONST objv[], int copyFlag));
static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, int *forcePtr));
+ int objc, Tcl_Obj *CONST objv[], int *forcePtr));
\f
/*
*---------------------------------------------------------------------------
*/
int
-TclFileRenameCmd(interp, argc, argv)
+TclFileRenameCmd(interp, objc, objv)
Tcl_Interp *interp; /* Interp for error reporting. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- return FileCopyRename(interp, argc, argv, 0);
+ return FileCopyRename(interp, objc, objv, 0);
}
\f
/*
*/
int
-TclFileCopyCmd(interp, argc, argv)
+TclFileCopyCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- return FileCopyRename(interp, argc, argv, 1);
+ return FileCopyRename(interp, objc, objv, 1);
}
\f
/*
*/
static int
-FileCopyRename(interp, argc, argv, copyFlag)
+FileCopyRename(interp, objc, objv, copyFlag)
Tcl_Interp *interp; /* Used for error reporting. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
int copyFlag; /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
int i, result, force;
- struct stat statBuf;
- Tcl_DString targetBuffer;
- char *target;
+ Tcl_StatBuf statBuf;
+ Tcl_Obj *target;
- i = FileForceOption(interp, argc - 2, argv + 2, &force);
+ i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
- if ((argc - i) < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " ?options? source ?source ...? target\"",
+ if ((objc - i) < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
+ " ?options? source ?source ...? target\"",
(char *) NULL);
return TCL_ERROR;
}
* directory.
*/
- target = Tcl_TranslateFileName(interp, argv[argc - 1], &targetBuffer);
- if (target == NULL) {
+ target = objv[objc - 1];
+ if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
result = TCL_OK;
/*
- * Call TclStat() so that if target is a symlink that points to a
+ * Call Tcl_FSStat() so that if target is a symlink that points to a
* directory we will put the sources in that directory instead of
* overwriting the symlink.
*/
- if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
- if ((argc - i) > 2) {
+ if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
+ if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
Tcl_AppendResult(interp, "error ",
((copyFlag) ? "copying" : "renaming"), ": target \"",
- argv[argc - 1], "\" is not a directory", (char *) NULL);
+ Tcl_GetString(target), "\" is not a directory",
+ (char *) NULL);
result = TCL_ERROR;
} else {
/*
- * Even though already have target == translated(argv[i+1]),
+ * Even though already have target == translated(objv[i+1]),
* pass the original argument down, so if there's an error, the
* error message will reflect the original arguments.
*/
- result = CopyRenameOneFile(interp, argv[i], argv[i + 1], copyFlag,
+ result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
force);
}
- Tcl_DStringFree(&targetBuffer);
return result;
}
* from each source, and append it to the end of the target path.
*/
- for ( ; i < argc - 1; i++) {
- char *jargv[2];
- char *source, *newFileName;
- Tcl_DString sourceBuffer, newFileNameBuffer;
-
- source = FileBasename(interp, argv[i], &sourceBuffer);
+ for ( ; i < objc - 1; i++) {
+ Tcl_Obj *jargv[2];
+ Tcl_Obj *source, *newFileName;
+ Tcl_Obj *temp;
+
+ source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
break;
}
- jargv[0] = argv[argc - 1];
+ jargv[0] = objv[objc - 1];
jargv[1] = source;
- Tcl_DStringInit(&newFileNameBuffer);
- newFileName = Tcl_JoinPath(2, jargv, &newFileNameBuffer);
- result = CopyRenameOneFile(interp, argv[i], newFileName, copyFlag,
+ temp = Tcl_NewListObj(2, jargv);
+ newFileName = Tcl_FSJoinPath(temp, -1);
+ Tcl_IncrRefCount(newFileName);
+ result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
force);
- Tcl_DStringFree(&sourceBuffer);
- Tcl_DStringFree(&newFileNameBuffer);
+ Tcl_DecrRefCount(newFileName);
+ Tcl_DecrRefCount(temp);
+ Tcl_DecrRefCount(source);
if (result == TCL_ERROR) {
break;
}
}
- Tcl_DStringFree(&targetBuffer);
return result;
}
\f
*----------------------------------------------------------------------
*/
int
-TclFileMakeDirsCmd(interp, argc, argv)
+TclFileMakeDirsCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting. */
- int argc; /* Number of arguments */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- Tcl_DString nameBuffer, targetBuffer;
- char *errfile;
- int result, i, j, pargc;
- char **pargv;
- struct stat statBuf;
+ Tcl_Obj *errfile;
+ int result, i, j, pobjc;
+ Tcl_Obj *split = NULL;
+ Tcl_Obj *target = NULL;
+ Tcl_StatBuf statBuf;
- pargv = NULL;
errfile = NULL;
- Tcl_DStringInit(&nameBuffer);
- Tcl_DStringInit(&targetBuffer);
result = TCL_OK;
- for (i = 2; i < argc; i++) {
- char *name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
- if (name == NULL) {
+ for (i = 2; i < objc; i++) {
+ if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
break;
}
- Tcl_SplitPath(name, &pargc, &pargv);
- if (pargc == 0) {
+ split = Tcl_FSSplitPath(objv[i],&pobjc);
+ if (pobjc == 0) {
errno = ENOENT;
- errfile = argv[i];
+ errfile = objv[i];
break;
}
- for (j = 0; j < pargc; j++) {
- char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
-
+ for (j = 0; j < pobjc; j++) {
+ target = Tcl_FSJoinPath(split, j + 1);
+ Tcl_IncrRefCount(target);
/*
- * Call TclStat() so that if target is a symlink that points
- * to a directory we will create subdirectories in that
- * directory.
+ * Call Tcl_FSStat() so that if target is a symlink that
+ * points to a directory we will create subdirectories in
+ * that directory.
*/
- if (TclStat(target, &statBuf) == 0) {
+ if (Tcl_FSStat(target, &statBuf) == 0) {
if (!S_ISDIR(statBuf.st_mode)) {
errno = EEXIST;
errfile = target;
goto done;
}
} else if ((errno != ENOENT)
- || (TclpCreateDirectory(target) != TCL_OK)) {
+ || (Tcl_FSCreateDirectory(target) != TCL_OK)) {
errfile = target;
goto done;
}
- Tcl_DStringFree(&targetBuffer);
+ /* Forget about this sub-path */
+ Tcl_DecrRefCount(target);
+ target = NULL;
}
- ckfree((char *) pargv);
- pargv = NULL;
- Tcl_DStringFree(&nameBuffer);
+ Tcl_DecrRefCount(split);
+ split = NULL;
}
done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "can't create directory \"",
- errfile, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
result = TCL_ERROR;
}
-
- Tcl_DStringFree(&nameBuffer);
- Tcl_DStringFree(&targetBuffer);
- if (pargv != NULL) {
- ckfree((char *) pargv);
+ if (split != NULL) {
+ Tcl_DecrRefCount(split);
+ }
+ if (target != NULL) {
+ Tcl_DecrRefCount(target);
}
return result;
}
*/
int
-TclFileDeleteCmd(interp, argc, argv)
+TclFileDeleteCmd(interp, objc, objv)
Tcl_Interp *interp; /* Used for error reporting */
- int argc; /* Number of arguments */
- char **argv; /* Argument strings passed to Tcl_FileCmd. */
+ int objc; /* Number of arguments */
+ Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */
{
- Tcl_DString nameBuffer, errorBuffer;
int i, force, result;
- char *errfile;
+ Tcl_Obj *errfile;
+ Tcl_Obj *errorBuffer = NULL;
- i = FileForceOption(interp, argc - 2, argv + 2, &force);
+ i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
- if ((argc - i) < 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ", argv[1], " ?options? file ?file ...?\"", (char *) NULL);
+ if ((objc - i) < 1) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
+ " ?options? file ?file ...?\"", (char *) NULL);
return TCL_ERROR;
}
errfile = NULL;
result = TCL_OK;
- Tcl_DStringInit(&errorBuffer);
- Tcl_DStringInit(&nameBuffer);
- for ( ; i < argc; i++) {
- struct stat statBuf;
- char *name;
+ for ( ; i < objc; i++) {
+ Tcl_StatBuf statBuf;
- errfile = argv[i];
- Tcl_DStringSetLength(&nameBuffer, 0);
- name = Tcl_TranslateFileName(interp, argv[i], &nameBuffer);
- if (name == NULL) {
+ errfile = objv[i];
+ if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
* Call lstat() to get info so can delete symbolic link itself.
*/
- if (TclpLstat(name, &statBuf) != 0) {
+ if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
/*
* Trying to delete a file that does not exist is not
* considered an error, just a no-op
result = TCL_ERROR;
}
} else if (S_ISDIR(statBuf.st_mode)) {
- result = TclpRemoveDirectory(name, force, &errorBuffer);
+ /*
+ * We own a reference count on errorBuffer, if it was set
+ * as a result of this call.
+ */
+ result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
- Tcl_AppendResult(interp, "error deleting \"", argv[i],
+ Tcl_AppendResult(interp, "error deleting \"",
+ Tcl_GetString(objv[i]),
"\": directory not empty", (char *) NULL);
Tcl_PosixError(interp);
goto done;
* If possible, use the untranslated name for the file.
*/
- errfile = Tcl_DStringValue(&errorBuffer);
- if (strcmp(name, errfile) == 0) {
- errfile = argv[i];
+ errfile = errorBuffer;
+ /* FS supposed to check between translated objv and errfile */
+ if (Tcl_FSEqualPaths(objv[i], errfile)) {
+ errfile = objv[i];
}
}
} else {
- result = TclpDeleteFile(name);
+ result = Tcl_FSDeleteFile(objv[i]);
}
- if (result == TCL_ERROR) {
+ if (result != TCL_OK) {
+ result = TCL_ERROR;
+ /*
+ * It is important that we break on error, otherwise we
+ * might end up owning reference counts on numerous
+ * errorBuffers.
+ */
break;
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "error deleting \"", errfile,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ if (errfile == NULL) {
+ /*
+ * We try to accomodate poor error results from our
+ * Tcl_FS calls
+ */
+ Tcl_AppendResult(interp, "error deleting unknown file: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ } else {
+ Tcl_AppendResult(interp, "error deleting \"",
+ Tcl_GetString(errfile), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
}
done:
- Tcl_DStringFree(&errorBuffer);
- Tcl_DStringFree(&nameBuffer);
+ if (errorBuffer != NULL) {
+ Tcl_DecrRefCount(errorBuffer);
+ }
return result;
}
\f
static int
CopyRenameOneFile(interp, source, target, copyFlag, force)
Tcl_Interp *interp; /* Used for error reporting. */
- char *source; /* Pathname of file to copy. May need to
+ Tcl_Obj *source; /* Pathname of file to copy. May need to
* be translated. */
- char *target; /* Pathname of file to create/overwrite.
+ Tcl_Obj *target; /* Pathname of file to create/overwrite.
* May need to be translated. */
int copyFlag; /* If non-zero, copy files. Otherwise,
* rename them. */
* exists. */
{
int result;
- Tcl_DString sourcePath, targetPath, errorBuffer;
- char *targetName, *sourceName, *errfile;
- struct stat sourceStatBuf, targetStatBuf;
+ Tcl_Obj *errfile, *errorBuffer;
+ /* If source is a link, then this is the real file/directory */
+ Tcl_Obj *actualSource = NULL;
+ Tcl_StatBuf sourceStatBuf, targetStatBuf;
- sourceName = Tcl_TranslateFileName(interp, source, &sourcePath);
- if (sourceName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
return TCL_ERROR;
}
- targetName = Tcl_TranslateFileName(interp, target, &targetPath);
- if (targetName == NULL) {
- Tcl_DStringFree(&sourcePath);
+ if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
errfile = NULL;
+ errorBuffer = NULL;
result = TCL_ERROR;
- Tcl_DStringInit(&errorBuffer);
/*
* We want to copy/rename links and not the files they point to, so we
* target.
*/
- if (TclpLstat(sourceName, &sourceStatBuf) != 0) {
+ if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
errfile = source;
goto done;
}
- if (TclpLstat(targetName, &targetStatBuf) != 0) {
+ if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
if (errno != ENOENT) {
errfile = target;
goto done;
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite file \"", target,
- "\" with directory \"", source, "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite file \"",
+ Tcl_GetString(target), "\" with directory \"",
+ Tcl_GetString(source), "\"", (char *) NULL);
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
&& S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite directory \"", target,
- "\" with file \"", source, "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite directory \"",
+ Tcl_GetString(target), "\" with file \"",
+ Tcl_GetString(source), "\"", (char *) NULL);
goto done;
}
}
if (copyFlag == 0) {
- result = TclpRenameFile(sourceName, targetName);
+ result = Tcl_FSRenameFile(source, target);
if (result == TCL_OK) {
goto done;
}
if (errno == EINVAL) {
- Tcl_AppendResult(interp, "error renaming \"", source, "\" to \"",
- target, "\": trying to rename a volume or ",
+ Tcl_AppendResult(interp, "error renaming \"",
+ Tcl_GetString(source), "\" to \"",
+ Tcl_GetString(target), "\": trying to rename a volume or ",
"move a directory into itself", (char *) NULL);
goto done;
} else if (errno != EXDEV) {
/*
* The rename failed because the move was across file systems.
* Fall through to copy file and then remove original. Note that
- * the low-level TclpRenameFile is allowed to implement
- * cross-filesystem moves itself.
+ * the low-level Tcl_FSRenameFileProc in the filesystem is allowed
+ * to implement cross-filesystem moves itself, if it desires.
+ */
+ }
+
+ actualSource = source;
+ Tcl_IncrRefCount(actualSource);
+#if 0
+#ifdef S_ISLNK
+ /*
+ * To add a flag to make 'copy' copy links instead of files, we could
+ * add a condition to ignore this 'if' here.
+ */
+ if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
+ /*
+ * We want to copy files not links. Therefore we must follow the
+ * link. There are two purposes to this 'stat' call here. First
+ * we want to know if the linked-file/dir actually exists, and
+ * second, in the block of code which follows, some 20 lines
+ * down, we want to check if the thing is a file or directory.
*/
+ if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
+ /* Actual file doesn't exist */
+ Tcl_AppendResult(interp,
+ "error copying \"", Tcl_GetString(source),
+ "\": the target of this link doesn't exist",
+ (char *) NULL);
+ goto done;
+ } else {
+ int counter = 0;
+ while (1) {
+ Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
+ if (path == NULL) {
+ break;
+ }
+ Tcl_DecrRefCount(actualSource);
+ actualSource = path;
+ counter++;
+ /* Arbitrary limit of 20 links to follow */
+ if (counter > 20) {
+ /* Too many links */
+ Tcl_SetErrno(EMLINK);
+ errfile = source;
+ goto done;
+ }
+ }
+ /* Now 'actualSource' is the correct file */
+ }
}
+#endif
+#endif
if (S_ISDIR(sourceStatBuf.st_mode)) {
- result = TclpCopyDirectory(sourceName, targetName, &errorBuffer);
+ result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
if (result != TCL_OK) {
- errfile = Tcl_DStringValue(&errorBuffer);
- if (strcmp(errfile, sourceName) == 0) {
- errfile = source;
- } else if (strcmp(errfile, targetName) == 0) {
- errfile = target;
+ if (errno == EXDEV) {
+ /*
+ * The copy failed because we're trying to do a
+ * cross-filesystem copy. We do this through our Tcl
+ * library.
+ */
+ Tcl_SavedResult savedResult;
+ Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
+ Tcl_IncrRefCount(copyCommand);
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("::tcl::CopyDirectory",-1));
+ if (copyFlag) {
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("copying",-1));
+ } else {
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("renaming",-1));
+ }
+ Tcl_ListObjAppendElement(interp, copyCommand, source);
+ Tcl_ListObjAppendElement(interp, copyCommand, target);
+ Tcl_SaveResult(interp, &savedResult);
+ result = Tcl_EvalObjEx(interp, copyCommand,
+ TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ Tcl_DecrRefCount(copyCommand);
+ if (result != TCL_OK) {
+ /*
+ * There was an error in the Tcl-level copy.
+ * We will pass on the Tcl error message and
+ * can ensure this by setting errfile to NULL
+ */
+ Tcl_DiscardResult(&savedResult);
+ errfile = NULL;
+ } else {
+ /* The copy was successful */
+ Tcl_RestoreResult(interp, &savedResult);
+ }
+ } else {
+ errfile = errorBuffer;
+ if (Tcl_FSEqualPaths(errfile, source)) {
+ errfile = source;
+ } else if (Tcl_FSEqualPaths(errfile, target)) {
+ errfile = target;
+ }
}
}
} else {
- result = TclpCopyFile(sourceName, targetName);
+ result = Tcl_FSCopyFile(actualSource, target);
+ if ((result != TCL_OK) && (errno == EXDEV)) {
+ result = TclCrossFilesystemCopy(interp, source, target);
+ }
if (result != TCL_OK) {
- /*
- * Well, there really shouldn't be a problem with source,
- * because up there we checked to see if it was ok to copy it.
+ /*
+ * We could examine 'errno' to double-check if the problem
+ * was with the target, but we checked the source above,
+ * so it should be quite clear
*/
-
errfile = target;
}
}
if ((copyFlag == 0) && (result == TCL_OK)) {
if (S_ISDIR(sourceStatBuf.st_mode)) {
- result = TclpRemoveDirectory(sourceName, 1, &errorBuffer);
+ result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
if (result != TCL_OK) {
- errfile = Tcl_DStringValue(&errorBuffer);
- if (strcmp(errfile, sourceName) == 0) {
+ if (Tcl_FSEqualPaths(errfile, source) == 0) {
errfile = source;
}
}
} else {
- result = TclpDeleteFile(sourceName);
+ result = Tcl_FSDeleteFile(source);
if (result != TCL_OK) {
errfile = source;
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "can't unlink \"", errfile, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "can't unlink \"",
+ Tcl_GetString(errfile), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
errfile = NULL;
}
}
if (errfile != NULL) {
Tcl_AppendResult(interp,
((copyFlag) ? "error copying \"" : "error renaming \""),
- source, (char *) NULL);
+ Tcl_GetString(source), (char *) NULL);
if (errfile != source) {
- Tcl_AppendResult(interp, "\" to \"", target, (char *) NULL);
+ Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target),
+ (char *) NULL);
if (errfile != target) {
- Tcl_AppendResult(interp, "\": \"", errfile, (char *) NULL);
+ Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile),
+ (char *) NULL);
}
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
- Tcl_DStringFree(&errorBuffer);
- Tcl_DStringFree(&sourcePath);
- Tcl_DStringFree(&targetPath);
+ if (errorBuffer != NULL) {
+ Tcl_DecrRefCount(errorBuffer);
+ }
+ if (actualSource != NULL) {
+ Tcl_DecrRefCount(actualSource);
+ }
return result;
}
\f
*/
static int
-FileForceOption(interp, argc, argv, forcePtr)
+FileForceOption(interp, objc, objv, forcePtr)
Tcl_Interp *interp; /* Interp, for error return. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. First command line
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. First command line
* option, if it exists, begins at 0. */
int *forcePtr; /* If the "-force" was specified, *forcePtr
* is filled with 1, otherwise with 0. */
int force, i;
force = 0;
- for (i = 0; i < argc; i++) {
- if (argv[i][0] != '-') {
+ for (i = 0; i < objc; i++) {
+ if (Tcl_GetString(objv[i])[0] != '-') {
break;
}
- if (strcmp(argv[i], "-force") == 0) {
+ if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
force = 1;
- } else if (strcmp(argv[i], "--") == 0) {
+ } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
i++;
break;
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[i],
+ Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]),
"\": should be -force or --", (char *)NULL);
return -1;
}
* if path is the root directory, returns no characters.
*
* Results:
- * Appends the string that represents the basename to the end of
- * the specified initialized DString, returning a pointer to the
- * resulting string. If there is an error, an error message is left
- * in interp, NULL is returned, and the Tcl_DString is unmodified.
+ * Returns the string object that represents the basename. If there
+ * is an error, an error message is left in interp, and NULL is
+ * returned.
*
* Side effects:
* None.
*---------------------------------------------------------------------------
*/
-static char *
-FileBasename(interp, path, bufferPtr)
+static Tcl_Obj *
+FileBasename(interp, pathPtr)
Tcl_Interp *interp; /* Interp, for error return. */
- char *path; /* Path whose basename to extract. */
- Tcl_DString *bufferPtr; /* Initialized DString that receives
- * basename. */
+ Tcl_Obj *pathPtr; /* Path whose basename to extract. */
{
- int argc;
- char **argv;
+ int objc;
+ Tcl_Obj *splitPtr;
+ Tcl_Obj *resultPtr = NULL;
- Tcl_SplitPath(path, &argc, &argv);
- if (argc == 0) {
- Tcl_DStringInit(bufferPtr);
- } else {
- if ((argc == 1) && (*path == '~')) {
- Tcl_DString buffer;
-
- ckfree((char *) argv);
- path = Tcl_TranslateFileName(interp, path, &buffer);
- if (path == NULL) {
+ splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
+
+ if (objc != 0) {
+ if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
+ Tcl_DecrRefCount(splitPtr);
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
}
- Tcl_SplitPath(path, &argc, &argv);
- Tcl_DStringFree(&buffer);
+ splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
}
- Tcl_DStringInit(bufferPtr);
/*
* Return the last component, unless it is the only component, and it
* is the root of an absolute path.
*/
- if (argc > 0) {
- if ((argc > 1)
- || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_DStringAppend(bufferPtr, argv[argc - 1], -1);
+ if (objc > 0) {
+ Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
+ if ((objc == 1) &&
+ (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
+ resultPtr = NULL;
}
}
}
- ckfree((char *) argv);
- return Tcl_DStringValue(bufferPtr);
+ if (resultPtr == NULL) {
+ resultPtr = Tcl_NewObj();
+ }
+ Tcl_IncrRefCount(resultPtr);
+ Tcl_DecrRefCount(splitPtr);
+ return resultPtr;
}
\f
/*
*
* TclFileAttrsCmd --
*
- * Sets or gets the platform-specific attributes of a file. The objc-objv
- * points to the file name with the rest of the command line following.
- * This routine uses platform-specific tables of option strings
- * and callbacks. The callback to get the attributes take three
- * parameters:
+ * Sets or gets the platform-specific attributes of a file. The
+ * objc-objv points to the file name with the rest of the command
+ * line following. This routine uses platform-specific tables of
+ * option strings and callbacks. The callback to get the
+ * attributes take three parameters:
* Tcl_Interp *interp; The interp to report errors with.
* Since this is an object-based API,
- * the object form of the result should be
- * used.
+ * the object form of the result should
+ * be used.
* CONST char *fileName; This is extracted using
* Tcl_TranslateFileName.
* TclObj **attrObjPtrPtr; A new object to hold the attribute
int objc; /* Number of command line arguments. */
Tcl_Obj *CONST objv[]; /* The command line objects. */
{
- char *fileName;
int result;
- Tcl_DString buffer;
-
+ CONST char ** attributeStrings;
+ Tcl_Obj* objStrings = NULL;
+ int numObjStrings = -1;
+ Tcl_Obj *filePtr;
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"name ?option? ?value? ?option value ...?");
return TCL_ERROR;
}
- fileName = Tcl_GetString(objv[2]);
- fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (fileName == NULL) {
+ filePtr = objv[2];
+ if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
objc -= 3;
objv += 3;
result = TCL_ERROR;
-
+ Tcl_SetErrno(0);
+ attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
+ if (attributeStrings == NULL) {
+ int index;
+ Tcl_Obj *objPtr;
+ if (objStrings == NULL) {
+ if (Tcl_GetErrno() != 0) {
+ /*
+ * There was an error, probably that the filePtr is
+ * not accepted by any filesystem
+ */
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "could not read \"", Tcl_GetString(filePtr),
+ "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ goto end;
+ }
+ /* We own the object now */
+ Tcl_IncrRefCount(objStrings);
+ /* Use objStrings as a list object */
+ if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
+ goto end;
+ }
+ attributeStrings = (CONST char **)
+ ckalloc ((1+numObjStrings) * sizeof(char*));
+ for (index = 0; index < numObjStrings; index++) {
+ Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
+ attributeStrings[index] = Tcl_GetString(objPtr);
+ }
+ attributeStrings[index] = NULL;
+ }
if (objc == 0) {
/*
* Get all attributes.
*/
int index;
- Tcl_Obj *listPtr, *objPtr;
+ Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
- for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
- objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
+ for (index = 0; attributeStrings[index] != NULL; index++) {
+ Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1);
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
-
- if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
- &objPtr) != TCL_OK) {
+ /* We now forget about objPtr, it is in the list */
+ objPtr = NULL;
+ if (Tcl_FSFileAttrsGet(interp, index, filePtr,
+ &objPtr) != TCL_OK) {
Tcl_DecrRefCount(listPtr);
goto end;
}
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
- }
+ }
Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
*/
int index;
- Tcl_Obj *objPtr;
-
- if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings,
+ Tcl_Obj *objPtr = NULL;
+
+ if (numObjStrings == 0) {
+ Tcl_AppendResult(interp, "bad option \"",
+ Tcl_GetString(objv[0]), "\", there are no file attributes"
+ " in this filesystem.", (char *) NULL);
+ goto end;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
- }
- if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
+ }
+ if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
}
int i, index;
+ if (numObjStrings == 0) {
+ Tcl_AppendResult(interp, "bad option \"",
+ Tcl_GetString(objv[0]), "\", there are no file attributes"
+ " in this filesystem.", (char *) NULL);
+ goto end;
+ }
+
for (i = 0; i < objc ; i += 2) {
- if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings,
+ if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", 0, &index) != TCL_OK) {
goto end;
}
(char *) NULL);
goto end;
}
- if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
+ if (Tcl_FSFileAttrsSet(interp, index, filePtr,
objv[i + 1]) != TCL_OK) {
goto end;
}
result = TCL_OK;
end:
- Tcl_DStringFree(&buffer);
+ if (numObjStrings != -1) {
+ /* Free up the array we allocated */
+ ckfree((char*)attributeStrings);
+ /*
+ * We don't need this object that was passed to us
+ * any more.
+ */
+ if (objStrings != NULL) {
+ Tcl_DecrRefCount(objStrings);
+ }
+ }
return result;
}
+++ /dev/null
-/*
- * tclFHandle.c --
- *
- * This file contains functions for manipulating Tcl file handles.
- *
- * Copyright (c) 1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclFHandle.c 1.9 96/07/01 15:41:26
- */
-
-#include "tcl.h"
-#include "tclInt.h"
-#include "tclPort.h"
-
-/*
- * The FileHashKey structure is used to associate the OS file handle and type
- * with the corresponding notifier data in a FileHandle.
- */
-
-typedef struct FileHashKey {
- int type; /* File handle type. */
- ClientData osHandle; /* Platform specific OS file handle. */
-} FileHashKey;
-
-typedef struct FileHandle {
- FileHashKey key; /* Hash key for a given file. */
- ClientData data; /* Platform specific notifier data. */
- Tcl_FileFreeProc *proc; /* Callback to invoke when file is freed. */
-} FileHandle;
-
-/*
- * Static variables used in this file:
- */
-
-static Tcl_HashTable fileTable; /* Hash table containing file handles. */
-static int initialized = 0; /* 1 if this module has been initialized. */
-
-/*
- * Static procedures used in this file:
- */
-
-static void FileExitProc _ANSI_ARGS_((ClientData clientData));
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetFile --
- *
- * This function retrieves the file handle associated with a
- * platform specific file handle of the given type. It creates
- * a new file handle if needed.
- *
- * Results:
- * Returns the file handle associated with the file descriptor.
- *
- * Side effects:
- * Initializes the file handle table if necessary.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_File
-Tcl_GetFile(osHandle, type)
- ClientData osHandle; /* Platform specific file handle. */
- int type; /* Type of file handle. */
-{
- FileHashKey key;
- Tcl_HashEntry *entryPtr;
- int new;
-
- if (!initialized) {
- Tcl_InitHashTable(&fileTable, sizeof(FileHashKey)/sizeof(int));
- Tcl_CreateExitHandler(FileExitProc, 0);
- initialized = 1;
- }
- key.osHandle = osHandle;
- key.type = type;
- entryPtr = Tcl_CreateHashEntry(&fileTable, (char *) &key, &new);
- if (new) {
- FileHandle *newHandlePtr;
- newHandlePtr = (FileHandle *) ckalloc(sizeof(FileHandle));
- newHandlePtr->key = key;
- newHandlePtr->data = NULL;
- newHandlePtr->proc = NULL;
- Tcl_SetHashValue(entryPtr, newHandlePtr);
- }
-
- return (Tcl_File) Tcl_GetHashValue(entryPtr);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_FreeFile --
- *
- * Deallocates an entry in the file handle table.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_FreeFile(handle)
- Tcl_File handle;
-{
- Tcl_HashEntry *entryPtr;
- FileHandle *handlePtr = (FileHandle *) handle;
-
- /*
- * Invoke free procedure, then delete the handle.
- */
-
- if (handlePtr->proc) {
- (*handlePtr->proc)(handlePtr->data);
- }
-
- /*
- * Tcl_File structures may be freed as a result of running the
- * channel table exit handler. The file table is freed by the file
- * table exit handler, which may run before the channel table exit
- * handler. The file table exit handler sets the "initialized"
- * variable back to zero, so that the Tcl_FreeFile (when invoked
- * from the channel table exit handler) can notice that the file
- * table has already been destroyed. Otherwise, accessing a
- * deleted hash table would cause a panic.
- */
-
- if (initialized) {
- entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key);
- if (entryPtr) {
- Tcl_DeleteHashEntry(entryPtr);
- }
- }
- ckfree((char *) handlePtr);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetFileInfo --
- *
- * This function retrieves the platform specific file data and
- * type from the file handle.
- *
- * Results:
- * If typePtr is not NULL, sets *typePtr to the type of the file.
- * Returns the platform specific file data.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-ClientData
-Tcl_GetFileInfo(handle, typePtr)
- Tcl_File handle;
- int *typePtr;
-{
- FileHandle *handlePtr = (FileHandle *) handle;
-
- if (typePtr) {
- *typePtr = handlePtr->key.type;
- }
- return handlePtr->key.osHandle;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetNotifierData --
- *
- * This function is used by the notifier to associate platform
- * specific notifier information and a deletion procedure with
- * a file handle.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Updates the data and delProc slots in the file handle.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetNotifierData(handle, proc, data)
- Tcl_File handle;
- Tcl_FileFreeProc *proc;
- ClientData data;
-{
- FileHandle *handlePtr = (FileHandle *) handle;
- handlePtr->proc = proc;
- handlePtr->data = data;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetNotifierData --
- *
- * This function is used by the notifier to retrieve the platform
- * specific notifier information associated with a file handle.
- *
- * Results:
- * Returns the data stored in a file handle by a previous call to
- * Tcl_SetNotifierData, and places a pointer to the free proc
- * in the location referred to by procPtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-ClientData
-Tcl_GetNotifierData(handle, procPtr)
- Tcl_File handle;
- Tcl_FileFreeProc **procPtr;
-{
- FileHandle *handlePtr = (FileHandle *) handle;
- if (procPtr != NULL) {
- *procPtr = handlePtr->proc;
- }
- return handlePtr->data;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * FileExitProc --
- *
- * This function an exit handler that frees any memory allocated
- * for the file handle table.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Cleans up the file handle table.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FileExitProc(clientData)
- ClientData clientData; /* Not used. */
-{
- Tcl_DeleteHashTable(&fileTable);
- initialized = 0;
-}
#include "tclPort.h"
#include "tclRegexp.h"
-/*
- * The following regular expression matches the root portion of a Windows
- * absolute or volume relative path. It will match both UNC and drive relative
- * paths.
+/*
+ * This define is used to activate Tcl's interpretation of Unix-style
+ * paths (containing forward slashes, '.' and '..') on MacOS. A
+ * side-effect of this is that some paths become ambiguous.
*/
+#define MAC_UNDERSTANDS_UNIX_PATHS
-#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*"
-
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
/*
* The following regular expression matches the root portion of a Macintosh
* absolute path. It will match degenerate Unix-style paths, tilde paths,
- * Unix-style paths, and Mac paths.
+ * Unix-style paths, and Mac paths. The various subexpressions in this
+ * can be summarised as follows: ^(/..|~user/unix|~user:mac|/unix|mac:dir).
+ * The subexpression indices which match the root portions, are as follows:
+ *
+ * degenerate unix-style: 2
+ * unix-tilde: 5
+ * mac-tilde: 7
+ * unix-style: 9 (or 10 to cut off the irrelevant header).
+ * mac: 12
+ *
*/
#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$"
static Tcl_ThreadDataKey dataKey;
+static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
+static void FileNameInit _ANSI_ARGS_((void));
+
+#endif
+
/*
* The following variable is set in the TclPlatformInit call to one
* of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS.
TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
/*
- * The "globParameters" argument of the globbing functions is an
- * or'ed combination of the following values:
- */
-
-#define GLOBMODE_NO_COMPLAIN 1
-#define GLOBMODE_JOIN 2
-#define GLOBMODE_DIR 4
-
-/*
* Prototypes for local procedures defined in this file:
*/
-static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
+static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *user, Tcl_DString *resultPtr));
static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
- Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr));
-static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
-static void FileNameInit _ANSI_ARGS_((void));
+ Tcl_DString *resultPtr, int offset,
+ Tcl_PathType *typePtr));
static int SkipToChar _ANSI_ARGS_((char **stringPtr,
char *match));
-static char * SplitMacPath _ANSI_ARGS_((CONST char *path,
- Tcl_DString *bufPtr));
-static char * SplitWinPath _ANSI_ARGS_((CONST char *path,
- Tcl_DString *bufPtr));
-static char * SplitUnixPath _ANSI_ARGS_((CONST char *path,
- Tcl_DString *bufPtr));
+static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path));
+static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path));
+static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path));
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
\f
/*
*----------------------------------------------------------------------
Tcl_DecrRefCount(tsdPtr->macRootPatternPtr);
tsdPtr->initialized = 0;
}
+#endif
\f
/*
*----------------------------------------------------------------------
* stored. */
Tcl_PathType *typePtr; /* Where to store pathType result */
{
- FileNameInit();
-
-
if (path[0] == '/' || path[0] == '\\') {
/* Might be a UNC or Vol-Relative path */
- char *host, *share, *tail;
+ CONST char *host, *share, *tail;
int hlen, slen;
if (path[1] != '/' && path[1] != '\\') {
Tcl_DStringSetLength(resultPtr, offset);
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, "/", 1);
return &path[1];
- }
- host = (char *)&path[2];
+ }
+ host = &path[2];
- /* Skip seperators */
+ /* Skip separators */
while (host[0] == '/' || host[0] == '\\') host++;
for (hlen = 0; host[hlen];hlen++) {
break;
}
if (host[hlen] == 0 || host[hlen+1] == 0) {
+ /*
+ * The path given is simply of the form
+ * '/foo', '//foo', '/////foo' or the same
+ * with backslashes. If there is exactly
+ * one leading '/' the path is volume relative
+ * (see filename man page). If there are more
+ * than one, we are simply assuming they
+ * are superfluous and we trim them away.
+ * (An alternative interpretation would
+ * be that it is a host name, but we have
+ * been documented that that is not the case).
+ */
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, "/", 1);
return &path[2];
Tcl_DStringSetLength(resultPtr, offset);
share = &host[hlen];
- /* Skip seperators */
+ /* Skip separators */
while (share[0] == '/' || share[0] == '\\') share++;
for (slen = 0; share[slen];slen++) {
tail = &share[slen];
- /* Skip seperators */
+ /* Skip separators */
while (tail[0] == '/' || tail[0] == '\\') tail++;
*typePtr = TCL_PATH_ABSOLUTE;
return tail;
- } else if (path[1] == ':') {
+ } else if (*path && path[1] == ':') {
/* Might be a drive sep */
Tcl_DStringSetLength(resultPtr, offset);
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, path, 2);
return &path[2];
- } else {
+ } else {
char *tail = (char*)&path[3];
- /* Skip seperators */
- while (tail[0] == '/' || tail[0] == '\\') tail++;
+ /* Skip separators */
+ while (*tail && (tail[0] == '/' || tail[0] == '\\')) tail++;
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringAppend(resultPtr, path, 2);
- Tcl_DStringAppend(resultPtr, "/", 1);
+ Tcl_DStringAppend(resultPtr, "/", 1);
- return tail;
+ return tail;
}
} else {
*typePtr = TCL_PATH_RELATIVE;
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute.
+ *
+ * The objectified Tcl_FSGetPathType should be used in
+ * preference to this function (as you can see below, this
+ * is just a wrapper around that other function).
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
Tcl_PathType
Tcl_GetPathType(path)
- char *path;
+ CONST char *path;
{
- ThreadSpecificData *tsdPtr;
- Tcl_PathType type = TCL_PATH_ABSOLUTE;
- Tcl_RegExp re;
-
- switch (tclPlatform) {
- case TCL_PLATFORM_UNIX:
- /*
- * Paths that begin with / or ~ are absolute.
- */
+ Tcl_PathType type;
+ Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);
+ Tcl_IncrRefCount(tempObj);
+ type = Tcl_FSGetPathType(tempObj);
+ Tcl_DecrRefCount(tempObj);
+ return type;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpGetNativePathType --
+ *
+ * Determines whether a given path is relative to the current
+ * directory, relative to the current volume, or absolute, but
+ * ONLY FOR THE NATIVE FILESYSTEM. This function is called from
+ * tclIOUtil.c (but needs to be here due to its dependence on
+ * static variables/functions in this file). The exported
+ * function Tcl_FSGetPathType should be used by extensions.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- if ((path[0] != '/') && (path[0] != '~')) {
- type = TCL_PATH_RELATIVE;
+Tcl_PathType
+TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
+ Tcl_Obj *pathObjPtr;
+ int *driveNameLengthPtr;
+ Tcl_Obj **driveNameRef;
+{
+ Tcl_PathType type = TCL_PATH_ABSOLUTE;
+ int pathLen;
+ char *path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
+
+ if (path[0] == '~') {
+ /*
+ * This case is common to all platforms.
+ * Paths that begin with ~ are absolute.
+ */
+ if (driveNameLengthPtr != NULL) {
+ char *end = path + 1;
+ while ((*end != '\0') && (*end != '/')) {
+ end++;
}
- break;
-
- case TCL_PLATFORM_MAC:
- if (path[0] == ':') {
- type = TCL_PATH_RELATIVE;
- } else if (path[0] != '~') {
- tsdPtr = TCL_TSD_INIT(&dataKey);
-
+ *driveNameLengthPtr = end - path;
+ }
+ } else {
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX: {
+ char *origPath = path;
+
/*
- * Since we have eliminated the easy cases, use the
- * root pattern to look for the other types.
+ * Paths that begin with / are absolute.
*/
- FileNameInit();
- re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr,
- REG_ADVANCED);
-
- if (!Tcl_RegExpExec(NULL, re, path, path)) {
+#ifdef __QNX__
+ /*
+ * Check for QNX //<node id> prefix
+ */
+ if (*path && (pathLen > 3) && (path[0] == '/')
+ && (path[1] == '/') && isdigit(UCHAR(path[2]))) {
+ path += 3;
+ while (isdigit(UCHAR(*path))) {
+ ++path;
+ }
+ }
+#endif
+ if (path[0] == '/') {
+ if (driveNameLengthPtr != NULL) {
+ /*
+ * We need this addition in case the QNX code
+ * was used
+ */
+ *driveNameLengthPtr = (1 + path - origPath);
+ }
+ } else {
+ type = TCL_PATH_RELATIVE;
+ }
+ break;
+ }
+ case TCL_PLATFORM_MAC:
+ if (path[0] == ':') {
type = TCL_PATH_RELATIVE;
} else {
- char *unixRoot, *dummy;
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
+ ThreadSpecificData *tsdPtr;
+ Tcl_RegExp re;
+
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Since we have eliminated the easy cases, use the
+ * root pattern to look for the other types.
+ */
- Tcl_RegExpRange(re, 2, &unixRoot, &dummy);
- if (unixRoot) {
+ FileNameInit();
+ re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr,
+ REG_ADVANCED);
+
+ if (!Tcl_RegExpExec(NULL, re, path, path)) {
type = TCL_PATH_RELATIVE;
+ } else {
+ CONST char *root, *end;
+ Tcl_RegExpRange(re, 2, &root, &end);
+ if (root != NULL) {
+ type = TCL_PATH_RELATIVE;
+ } else {
+ if (driveNameLengthPtr != NULL) {
+ Tcl_RegExpRange(re, 0, &root, &end);
+ *driveNameLengthPtr = end - root;
+ }
+ if (driveNameRef != NULL) {
+ if (*root == '/') {
+ char *c;
+ int gotColon = 0;
+ *driveNameRef = Tcl_NewStringObj(root + 1,
+ end - root -1);
+ c = Tcl_GetString(*driveNameRef);
+ while (*c != '\0') {
+ if (*c == '/') {
+ gotColon++;
+ *c = ':';
+ }
+ c++;
+ }
+ /*
+ * If there is no colon, we have just a
+ * volume name so we must add a colon so
+ * it is an absolute path.
+ */
+ if (gotColon == 0) {
+ Tcl_AppendToObj(*driveNameRef, ":", 1);
+ } else if ((gotColon > 1) &&
+ (*(c-1) == ':')) {
+ /* We have an extra colon */
+ Tcl_SetObjLength(*driveNameRef,
+ c - Tcl_GetString(*driveNameRef) - 1);
+ }
+ }
+ }
+ }
+ }
+#else
+ if (path[0] == '~') {
+ } else if (path[0] == ':') {
+ type = TCL_PATH_RELATIVE;
+ } else {
+ char *colonPos = strchr(path,':');
+ if (colonPos == NULL) {
+ type = TCL_PATH_RELATIVE;
+ } else {
+ }
+ }
+ if (type == TCL_PATH_ABSOLUTE) {
+ if (driveNameLengthPtr != NULL) {
+ *driveNameLengthPtr = strlen(path);
+ }
}
+#endif
}
- }
- break;
-
- case TCL_PLATFORM_WINDOWS:
- if (path[0] != '~') {
+ break;
+
+ case TCL_PLATFORM_WINDOWS: {
Tcl_DString ds;
-
+ CONST char *rootEnd;
+
Tcl_DStringInit(&ds);
- (VOID)ExtractWinRoot(path, &ds, 0, &type);
+ rootEnd = ExtractWinRoot(path, &ds, 0, &type);
+ if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
+ *driveNameLengthPtr = rootEnd - path;
+ if (driveNameRef != NULL) {
+ *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_IncrRefCount(*driveNameRef);
+ }
+ }
Tcl_DStringFree(&ds);
+ break;
}
- break;
+ }
}
return type;
}
\f
/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpNativeSplitPath --
+ *
+ * This function takes the given Tcl_Obj, which should be a valid
+ * path, and returns a Tcl List object containing each segment
+ * of that path as an element.
+ *
+ * Note this function currently calls the older Split(Plat)Path
+ * functions, which require more memory allocation than is
+ * desirable.
+ *
+ * Results:
+ * Returns list object with refCount of zero. If the passed in
+ * lenPtr is non-NULL, we use it to return the number of elements
+ * in the returned list.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclpNativeSplitPath(pathPtr, lenPtr)
+ Tcl_Obj *pathPtr; /* Path to split. */
+ int *lenPtr; /* int to store number of path elements. */
+{
+ Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
+
+ /*
+ * Perform platform specific splitting.
+ */
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
+ break;
+
+ case TCL_PLATFORM_WINDOWS:
+ resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
+ break;
+
+ case TCL_PLATFORM_MAC:
+ resultPtr = SplitMacPath(Tcl_GetString(pathPtr));
+ break;
+ }
+
+ /*
+ * Compute the number of elements in the result.
+ */
+
+ if (lenPtr != NULL) {
+ Tcl_ListObjLength(NULL, resultPtr, lenPtr);
+ }
+ return resultPtr;
+}
+\f
+/*
*----------------------------------------------------------------------
*
* Tcl_SplitPath --
CONST char *path; /* Pointer to string containing a path. */
int *argcPtr; /* Pointer to location to fill in with
* the number of elements in the path. */
- char ***argvPtr; /* Pointer to place to store pointer to array
+ CONST char ***argvPtr; /* Pointer to place to store pointer to array
* of pointers to path elements. */
{
- int i, size;
- char *p;
- Tcl_DString buffer;
-
- Tcl_DStringInit(&buffer);
+ Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
+ Tcl_Obj *tmpPtr, *eltPtr;
+ int i, size, len;
+ char *p, *str;
/*
- * Perform platform specific splitting. These routines will leave the
- * result in the specified buffer. Individual elements are terminated
- * with a null character.
+ * Perform the splitting, using objectified, vfs-aware code.
*/
- p = NULL; /* Needed only to prevent gcc warnings. */
- switch (tclPlatform) {
- case TCL_PLATFORM_UNIX:
- p = SplitUnixPath(path, &buffer);
- break;
-
- case TCL_PLATFORM_WINDOWS:
- p = SplitWinPath(path, &buffer);
- break;
-
- case TCL_PLATFORM_MAC:
- p = SplitMacPath(path, &buffer);
- break;
- }
-
- /*
- * Compute the number of elements in the result.
- */
+ tmpPtr = Tcl_NewStringObj(path, -1);
+ Tcl_IncrRefCount(tmpPtr);
+ resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
+ Tcl_DecrRefCount(tmpPtr);
- size = Tcl_DStringLength(&buffer);
- *argcPtr = 0;
- for (i = 0; i < size; i++) {
- if (p[i] == '\0') {
- (*argcPtr)++;
- }
+ /* Calculate space required for the result */
+
+ size = 1;
+ for (i = 0; i < *argcPtr; i++) {
+ Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
+ Tcl_GetStringFromObj(eltPtr, &len);
+ size += len + 1;
}
/*
- * Allocate a buffer large enough to hold the contents of the
- * DString plus the argv pointers and the terminating NULL pointer.
+ * Allocate a buffer large enough to hold the contents of all of
+ * the list plus the argv pointers and the terminating NULL pointer.
*/
- *argvPtr = (char **) ckalloc((unsigned)
+ *argvPtr = (CONST char **) ckalloc((unsigned)
((((*argcPtr) + 1) * sizeof(char *)) + size));
/*
* Position p after the last argv pointer and copy the contents of
- * the DString.
+ * the list in, piece by piece.
*/
p = (char *) &(*argvPtr)[(*argcPtr) + 1];
- memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size);
-
+ for (i = 0; i < *argcPtr; i++) {
+ Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
+ str = Tcl_GetStringFromObj(eltPtr, &len);
+ memcpy((VOID *) p, (VOID *) str, (size_t) len+1);
+ p += len+1;
+ }
+
/*
* Now set up the argv pointers.
*/
+ p = (char *) &(*argvPtr)[(*argcPtr) + 1];
+
for (i = 0; i < *argcPtr; i++) {
(*argvPtr)[i] = p;
while ((*p++) != '\0') {}
}
(*argvPtr)[i] = NULL;
- Tcl_DStringFree(&buffer);
+ /*
+ * Free the result ptr given to us by Tcl_FSSplitPath
+ */
+
+ Tcl_DecrRefCount(resultPtr);
}
\f
/*
*
* SplitUnixPath --
*
- * This routine is used by Tcl_SplitPath to handle splitting
+ * This routine is used by Tcl_(FS)SplitPath to handle splitting
* Unix paths.
*
* Results:
- * Stores a null separated array of strings in the specified
- * Tcl_DString.
+ * Returns a newly allocated Tcl list object.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-static char *
-SplitUnixPath(path, bufPtr)
+static Tcl_Obj*
+SplitUnixPath(path)
CONST char *path; /* Pointer to string containing a path. */
- Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
{
int length;
CONST char *p, *elementStart;
+ Tcl_Obj *result = Tcl_NewObj();
/*
* Deal with the root directory as a special case.
#endif
if (path[0] == '/') {
- Tcl_DStringAppend(bufPtr, "/", 2);
+ Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
p = path+1;
} else {
p = path;
}
length = p - elementStart;
if (length > 0) {
+ Tcl_Obj *nextElt;
if ((elementStart[0] == '~') && (elementStart != path)) {
- Tcl_DStringAppend(bufPtr, "./", 2);
+ nextElt = Tcl_NewStringObj("./",2);
+ Tcl_AppendToObj(nextElt, elementStart, length);
+ } else {
+ nextElt = Tcl_NewStringObj(elementStart, length);
}
- Tcl_DStringAppend(bufPtr, elementStart, length);
- Tcl_DStringAppend(bufPtr, "", 1);
+ Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*p++ == '\0') {
break;
}
}
- return Tcl_DStringValue(bufPtr);
+ return result;
}
+
\f
/*
*----------------------------------------------------------------------
*
* SplitWinPath --
*
- * This routine is used by Tcl_SplitPath to handle splitting
+ * This routine is used by Tcl_(FS)SplitPath to handle splitting
* Windows paths.
*
* Results:
- * Stores a null separated array of strings in the specified
- * Tcl_DString.
+ * Returns a newly allocated Tcl list object.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-static char *
-SplitWinPath(path, bufPtr)
+static Tcl_Obj*
+SplitWinPath(path)
CONST char *path; /* Pointer to string containing a path. */
- Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
{
int length;
CONST char *p, *elementStart;
Tcl_PathType type = TCL_PATH_ABSOLUTE;
-
- p = ExtractWinRoot(path, bufPtr, 0, &type);
+ Tcl_DString buf;
+ Tcl_Obj *result = Tcl_NewObj();
+ Tcl_DStringInit(&buf);
+
+ p = ExtractWinRoot(path, &buf, 0, &type);
/*
* Terminate the root portion, if we matched something.
*/
if (p != path) {
- Tcl_DStringAppend(bufPtr, "", 1);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(Tcl_DStringValue(&buf),
+ Tcl_DStringLength(&buf)));
}
-
+ Tcl_DStringFree(&buf);
+
/*
* Split on slashes. Embedded elements that start with tilde will be
* prefixed with "./" so they are not affected by tilde substitution.
}
length = p - elementStart;
if (length > 0) {
+ Tcl_Obj *nextElt;
if ((elementStart[0] == '~') && (elementStart != path)) {
- Tcl_DStringAppend(bufPtr, "./", 2);
+ nextElt = Tcl_NewStringObj("./",2);
+ Tcl_AppendToObj(nextElt, elementStart, length);
+ } else {
+ nextElt = Tcl_NewStringObj(elementStart, length);
}
- Tcl_DStringAppend(bufPtr, elementStart, length);
- Tcl_DStringAppend(bufPtr, "", 1);
+ Tcl_ListObjAppendElement(NULL, result, nextElt);
}
} while (*p++ != '\0');
- return Tcl_DStringValue(bufPtr);
+ return result;
}
\f
/*
*
* SplitMacPath --
*
- * This routine is used by Tcl_SplitPath to handle splitting
+ * This routine is used by Tcl_(FS)SplitPath to handle splitting
* Macintosh paths.
*
* Results:
- * Returns a newly allocated argv array.
+ * Returns a newly allocated Tcl list object.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-static char *
-SplitMacPath(path, bufPtr)
+static Tcl_Obj*
+SplitMacPath(path)
CONST char *path; /* Pointer to string containing a path. */
- Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
{
int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */
- int i, length;
+ int length;
CONST char *p, *elementStart;
+ Tcl_Obj *result;
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
Tcl_RegExp re;
+ int i;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
+#endif
+
+ result = Tcl_NewObj();
+
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
/*
* Initialize the path name parser for Macintosh path names.
*/
re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED);
if (Tcl_RegExpExec(NULL, re, path, path) == 1) {
- char *start, *end;
+ CONST char *start, *end;
+ Tcl_Obj *nextElt;
/*
* Treat degenerate absolute paths like / and /../.. as
Tcl_RegExpRange(re, 2, &start, &end);
if (start) {
- Tcl_DStringAppend(bufPtr, ":", 1);
+ Tcl_Obj *elt = Tcl_NewStringObj(":", 1);
Tcl_RegExpRange(re, 0, &start, &end);
- Tcl_DStringAppend(bufPtr, path, end - start + 1);
- return Tcl_DStringValue(bufPtr);
+ Tcl_AppendToObj(elt, path, end - start);
+ Tcl_ListObjAppendElement(NULL, result, elt);
+ return result;
}
Tcl_RegExpRange(re, 5, &start, &end);
} else {
Tcl_RegExpRange(re, 10, &start, &end);
if (start) {
-
/*
* Normal Unix style paths.
*/
} else {
Tcl_RegExpRange(re, 12, &start, &end);
if (start) {
-
/*
* Normal Mac style paths.
*/
}
}
}
-
Tcl_RegExpRange(re, i, &start, &end);
length = end - start;
/*
- * Append the element and terminate it with a : and a null. Note that
- * we are forcing the DString to contain an extra null at the end.
+ * Append the element and terminate it with a :
*/
- Tcl_DStringAppend(bufPtr, start, length);
- Tcl_DStringAppend(bufPtr, ":", 2);
+ nextElt = Tcl_NewStringObj(start, length);
+ Tcl_AppendToObj(nextElt, ":", 1);
+ Tcl_ListObjAppendElement(NULL, result, nextElt);
p = end;
} else {
isMac = (strchr(path, ':') != NULL);
p = path;
}
+#else
+ if ((path[0] != ':') && (path[0] == '~' || (strchr(path,':') != NULL))) {
+ CONST char *end;
+ Tcl_Obj *nextElt;
+
+ isMac = 1;
+
+ end = strchr(path,':');
+ if (end == NULL) {
+ length = strlen(path);
+ } else {
+ length = end - path;
+ }
+
+ /*
+ * Append the element and terminate it with a :
+ */
+
+ nextElt = Tcl_NewStringObj(path, length);
+ Tcl_AppendToObj(nextElt, ":", 1);
+ Tcl_ListObjAppendElement(NULL, result, nextElt);
+ p = path + length;
+ } else {
+ isMac = (strchr(path, ':') != NULL);
+ isMac = 1;
+ p = path;
+ }
+#endif
if (isMac) {
/*
* p is pointing at the first colon in the path. There
* will always be one, since this is a Mac-style path.
+ * (This is no longer true if MAC_UNDERSTANDS_UNIX_PATHS
+ * is false, so we must check whether 'p' points to the
+ * end of the string.)
*/
-
- elementStart = p++;
+ elementStart = p;
+ if (*p == ':') {
+ p++;
+ }
+
while ((p = strchr(p, ':')) != NULL) {
length = p - elementStart;
if (length == 1) {
while (*p == ':') {
- Tcl_DStringAppend(bufPtr, "::", 3);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj("::", 2));
elementStart = p++;
}
} else {
elementStart++;
length--;
}
- Tcl_DStringAppend(bufPtr, elementStart, length);
- Tcl_DStringAppend(bufPtr, "", 1);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(elementStart, length));
elementStart = p++;
}
}
- if (elementStart[1] != '\0' || elementStart == path) {
- if ((elementStart[1] != '~') && (elementStart[1] != '\0')
+ if (elementStart[0] != ':') {
+ if (elementStart[0] != '\0') {
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(elementStart, -1));
+ }
+ } else {
+ if (elementStart[1] != '\0' || elementStart == path) {
+ if ((elementStart[1] != '~') && (elementStart[1] != '\0')
&& (strchr(elementStart+1, '/') == NULL)) {
elementStart++;
+ }
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(elementStart, -1));
}
- Tcl_DStringAppend(bufPtr, elementStart, -1);
- Tcl_DStringAppend(bufPtr, "", 1);
}
} else {
length = p - elementStart;
if (length > 0) {
if ((length == 1) && (elementStart[0] == '.')) {
- Tcl_DStringAppend(bufPtr, ":", 2);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(":", 1));
} else if ((length == 2) && (elementStart[0] == '.')
&& (elementStart[1] == '.')) {
- Tcl_DStringAppend(bufPtr, "::", 3);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj("::", 2));
} else {
+ Tcl_Obj *nextElt;
if (*elementStart == '~') {
- Tcl_DStringAppend(bufPtr, ":", 1);
+ nextElt = Tcl_NewStringObj(":",1);
+ Tcl_AppendToObj(nextElt, elementStart, length);
+ } else {
+ nextElt = Tcl_NewStringObj(elementStart, length);
}
- Tcl_DStringAppend(bufPtr, elementStart, length);
- Tcl_DStringAppend(bufPtr, "", 1);
+ Tcl_ListObjAppendElement(NULL, result, nextElt);
}
}
if (*p++ == '\0') {
}
}
}
- return Tcl_DStringValue(bufPtr);
+ return result;
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_JoinPath --
+ * Tcl_FSJoinToPath --
*
- * Combine a list of paths in a platform specific manner.
+ * This function takes the given object, which should usually be a
+ * valid path or NULL, and joins onto it the array of paths
+ * segments given.
*
* Results:
- * Appends the joined path to the end of the specified
- * returning a pointer to the resulting string. Note that
- * the Tcl_DString must already be initialized.
+ * Returns object with refCount of zero
*
* Side effects:
- * Modifies the Tcl_DString.
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-char *
-Tcl_JoinPath(argc, argv, resultPtr)
- int argc;
- char **argv;
- Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */
+Tcl_Obj*
+Tcl_FSJoinToPath(basePtr, objc, objv)
+ Tcl_Obj *basePtr;
+ int objc;
+ Tcl_Obj *CONST objv[];
{
- int oldLength, length, i, needsSep;
- Tcl_DString buffer;
- char c, *dest;
- CONST char *p;
- Tcl_PathType type = TCL_PATH_ABSOLUTE;
+ int i;
+ Tcl_Obj *lobj, *ret;
+
+ if (basePtr == NULL) {
+ lobj = Tcl_NewListObj(0, NULL);
+ } else {
+ lobj = Tcl_NewListObj(1, &basePtr);
+ }
+
+ for (i = 0; i<objc;i++) {
+ Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
+ }
+ ret = Tcl_FSJoinPath(lobj, -1);
+ Tcl_DecrRefCount(lobj);
+ return ret;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpNativeJoinPath --
+ *
+ * 'prefix' is absolute, 'joining' is relative to prefix.
+ *
+ * Results:
+ * modifies prefix
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclpNativeJoinPath(prefix, joining)
+ Tcl_Obj *prefix;
+ char* joining;
+{
+ int length, needsSep;
+ char *dest, *p, *start;
+
+ start = Tcl_GetStringFromObj(prefix, &length);
+
+ /*
+ * Remove the ./ from tilde prefixed elements unless
+ * it is the first component.
+ */
+
+ p = joining;
+
+ if (length != 0) {
+ if ((p[0] == '.') && (p[1] == '/') && (p[2] == '~')) {
+ p += 2;
+ }
+ }
+
+ if (*p == '\0') {
+ return;
+ }
- Tcl_DStringInit(&buffer);
- oldLength = Tcl_DStringLength(resultPtr);
switch (tclPlatform) {
- case TCL_PLATFORM_UNIX:
- for (i = 0; i < argc; i++) {
- p = argv[i];
- /*
- * If the path is absolute, reset the result buffer.
- * Consume any duplicate leading slashes or a ./ in
- * front of a tilde prefixed path that isn't at the
- * beginning of the path.
- */
+ case TCL_PLATFORM_UNIX:
+ /*
+ * Append a separator if needed.
+ */
-#ifdef __QNX__
- /*
- * Check for QNX //<node id> prefix
- */
- if (*p && (strlen(p) > 3) && (p[0] == '/') && (p[1] == '/')
- && isdigit(UCHAR(p[2]))) { /* INTL: digit */
- p += 3;
- while (isdigit(UCHAR(*p))) { /* INTL: digit */
- ++p;
- }
- }
-#endif
+ if (length > 0 && (start[length-1] != '/')) {
+ Tcl_AppendToObj(prefix, "/", 1);
+ length++;
+ }
+ needsSep = 0;
+
+ /*
+ * Append the element, eliminating duplicate and trailing
+ * slashes.
+ */
+
+ Tcl_SetObjLength(prefix, length + (int) strlen(p));
+
+ dest = Tcl_GetString(prefix) + length;
+ for (; *p != '\0'; p++) {
if (*p == '/') {
- Tcl_DStringSetLength(resultPtr, oldLength);
- Tcl_DStringAppend(resultPtr, "/", 1);
- while (*p == '/') {
+ while (p[1] == '/') {
p++;
}
- } else if (*p == '~') {
- Tcl_DStringSetLength(resultPtr, oldLength);
- } else if ((Tcl_DStringLength(resultPtr) != oldLength)
- && (p[0] == '.') && (p[1] == '/')
- && (p[2] == '~')) {
- p += 2;
- }
-
- if (*p == '\0') {
- continue;
+ if (p[1] != '\0') {
+ if (needsSep) {
+ *dest++ = '/';
+ }
+ }
+ } else {
+ *dest++ = *p;
+ needsSep = 1;
}
+ }
+ length = dest - Tcl_GetString(prefix);
+ Tcl_SetObjLength(prefix, length);
+ break;
- /*
- * Append a separator if needed.
- */
-
- length = Tcl_DStringLength(resultPtr);
- if ((length != oldLength)
- && (Tcl_DStringValue(resultPtr)[length-1] != '/')) {
- Tcl_DStringAppend(resultPtr, "/", 1);
- length++;
- }
+ case TCL_PLATFORM_WINDOWS:
+ /*
+ * Check to see if we need to append a separator.
+ */
- /*
- * Append the element, eliminating duplicate and trailing
- * slashes.
- */
+ if ((length > 0) &&
+ (start[length-1] != '/') && (start[length-1] != ':')) {
+ Tcl_AppendToObj(prefix, "/", 1);
+ length++;
+ }
+ needsSep = 0;
+
+ /*
+ * Append the element, eliminating duplicate and
+ * trailing slashes.
+ */
- Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
- dest = Tcl_DStringValue(resultPtr) + length;
- for (; *p != '\0'; p++) {
- if (*p == '/') {
- while (p[1] == '/') {
- p++;
- }
- if (p[1] != '\0') {
- *dest++ = '/';
- }
- } else {
- *dest++ = *p;
+ Tcl_SetObjLength(prefix, length + (int) strlen(p));
+ dest = Tcl_GetString(prefix) + length;
+ for (; *p != '\0'; p++) {
+ if ((*p == '/') || (*p == '\\')) {
+ while ((p[1] == '/') || (p[1] == '\\')) {
+ p++;
+ }
+ if ((p[1] != '\0') && needsSep) {
+ *dest++ = '/';
}
+ } else {
+ *dest++ = *p;
+ needsSep = 1;
}
- length = dest - Tcl_DStringValue(resultPtr);
- Tcl_DStringSetLength(resultPtr, length);
}
+ length = dest - Tcl_GetString(prefix);
+ Tcl_SetObjLength(prefix, length);
break;
- case TCL_PLATFORM_WINDOWS:
+ case TCL_PLATFORM_MAC: {
+ int newLength;
+
/*
- * Iterate over all of the components. If a component is
- * absolute, then reset the result and start building the
- * path from the current component on.
+ * Sort out separators. We basically add the object we've
+ * been given, but we have to make sure that there is
+ * exactly one separator inbetween (unless the object we're
+ * adding contains multiple contiguous colons, all of which
+ * we must add). Also if an object is just ':' we don't
+ * bother to add it unless it's the very first element.
*/
- for (i = 0; i < argc; i++) {
- p = ExtractWinRoot(argv[i], resultPtr, oldLength, &type);
- length = Tcl_DStringLength(resultPtr);
-
- /*
- * If the pointer didn't move, then this is a relative path
- * or a tilde prefixed path.
- */
-
- if (p == argv[i]) {
- /*
- * Remove the ./ from tilde prefixed elements unless
- * it is the first component.
- */
-
- if ((length != oldLength)
- && (p[0] == '.')
- && ((p[1] == '/') || (p[1] == '\\'))
- && (p[2] == '~')) {
- p += 2;
- } else if (*p == '~') {
- Tcl_DStringSetLength(resultPtr, oldLength);
- length = oldLength;
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
+ int adjustedPath = 0;
+ if ((strchr(p, ':') == NULL) && (strchr(p, '/') != NULL)) {
+ char *start = p;
+ adjustedPath = 1;
+ while (*start != '\0') {
+ if (*start == '/') {
+ *start = ':';
}
+ start++;
}
-
- if (*p != '\0') {
- /*
- * Check to see if we need to append a separator.
- */
-
-
- if (length != oldLength) {
- c = Tcl_DStringValue(resultPtr)[length-1];
- if ((c != '/') && (c != ':')) {
- Tcl_DStringAppend(resultPtr, "/", 1);
- }
- }
-
- /*
- * Append the element, eliminating duplicate and
- * trailing slashes.
- */
-
- length = Tcl_DStringLength(resultPtr);
- Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
- dest = Tcl_DStringValue(resultPtr) + length;
- for (; *p != '\0'; p++) {
- if ((*p == '/') || (*p == '\\')) {
- while ((p[1] == '/') || (p[1] == '\\')) {
- p++;
- }
- if (p[1] != '\0') {
- *dest++ = '/';
- }
- } else {
- *dest++ = *p;
- }
+ }
+#endif
+ if (length > 0) {
+ if ((p[0] == ':') && (p[1] == '\0')) {
+ return;
+ }
+ if (start[length-1] != ':') {
+ if (*p != '\0' && *p != ':') {
+ Tcl_AppendToObj(prefix, ":", 1);
+ length++;
}
- length = dest - Tcl_DStringValue(resultPtr);
- Tcl_DStringSetLength(resultPtr, length);
+ } else if (*p == ':') {
+ p++;
+ }
+ } else {
+ if (*p != '\0' && *p != ':') {
+ Tcl_AppendToObj(prefix, ":", 1);
+ length++;
}
}
- break;
+
+ /*
+ * Append the element
+ */
- case TCL_PLATFORM_MAC:
- needsSep = 1;
- for (i = 0; i < argc; i++) {
- Tcl_DStringSetLength(&buffer, 0);
- p = SplitMacPath(argv[i], &buffer);
- if ((*p != ':') && (*p != '\0')
- && (strchr(p, ':') != NULL)) {
- Tcl_DStringSetLength(resultPtr, oldLength);
- length = strlen(p);
- Tcl_DStringAppend(resultPtr, p, length);
- needsSep = 0;
- p += length+1;
+ newLength = strlen(p);
+ /*
+ * It may not be good to just do 'Tcl_AppendToObj(prefix,
+ * p, newLength)' because the object may contain duplicate
+ * colons which we want to get rid of.
+ */
+ Tcl_AppendToObj(prefix, p, newLength);
+
+ /* Remove spurious trailing single ':' */
+ dest = Tcl_GetString(prefix) + length + newLength;
+ if (*(dest-1) == ':') {
+ if (dest-1 > Tcl_GetString(prefix)) {
+ if (*(dest-2) != ':') {
+ Tcl_SetObjLength(prefix, length + newLength -1);
+ }
}
-
- /*
- * Now append the rest of the path elements, skipping
- * : unless it is the first element of the path, and
- * watching out for :: et al. so we don't end up with
- * too many colons in the result.
- */
-
- for (; *p != '\0'; p += length+1) {
- if (p[0] == ':' && p[1] == '\0') {
- if (Tcl_DStringLength(resultPtr) != oldLength) {
- p++;
- } else {
- needsSep = 0;
- }
- } else {
- c = p[1];
- if (*p == ':') {
- if (!needsSep) {
- p++;
- }
- } else {
- if (needsSep) {
- Tcl_DStringAppend(resultPtr, ":", 1);
- }
- }
- needsSep = (c == ':') ? 0 : 1;
+ }
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
+ /* Revert the path to what it was */
+ if (adjustedPath) {
+ char *start = joining;
+ while (*start != '\0') {
+ if (*start == ':') {
+ *start = '/';
}
- length = strlen(p);
- Tcl_DStringAppend(resultPtr, p, length);
+ start++;
}
}
+#endif
break;
-
+ }
}
- Tcl_DStringFree(&buffer);
+ return;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_JoinPath --
+ *
+ * Combine a list of paths in a platform specific manner. The
+ * function 'Tcl_FSJoinPath' should be used in preference where
+ * possible.
+ *
+ * Results:
+ * Appends the joined path to the end of the specified
+ * Tcl_DString returning a pointer to the resulting string. Note
+ * that the Tcl_DString must already be initialized.
+ *
+ * Side effects:
+ * Modifies the Tcl_DString.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_JoinPath(argc, argv, resultPtr)
+ int argc;
+ CONST char * CONST *argv;
+ Tcl_DString *resultPtr; /* Pointer to previously initialized DString */
+{
+ int i, len;
+ Tcl_Obj *listObj = Tcl_NewObj();
+ Tcl_Obj *resultObj;
+ char *resultStr;
+
+ /* Build the list of paths */
+ for (i = 0; i < argc; i++) {
+ Tcl_ListObjAppendElement(NULL, listObj,
+ Tcl_NewStringObj(argv[i], -1));
+ }
+
+ /* Ask the objectified code to join the paths */
+ Tcl_IncrRefCount(listObj);
+ resultObj = Tcl_FSJoinPath(listObj, argc);
+ Tcl_IncrRefCount(resultObj);
+ Tcl_DecrRefCount(listObj);
+
+ /* Store the result */
+ resultStr = Tcl_GetStringFromObj(resultObj, &len);
+ Tcl_DStringAppend(resultPtr, resultStr, len);
+ Tcl_DecrRefCount(resultObj);
+
+ /* Return a pointer to the result */
return Tcl_DStringValue(resultPtr);
}
\f
Tcl_TranslateFileName(interp, name, bufferPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
- char *name; /* File name, which may begin with "~" (to
+ CONST char *name; /* File name, which may begin with "~" (to
* indicate current user's home directory) or
* "~<user>" (to indicate any user's home
* directory). */
Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
* with name after tilde substitution. */
{
- register char *p;
+ Tcl_Obj *path = Tcl_NewStringObj(name, -1);
+ CONST char *result;
+
+ Tcl_IncrRefCount(path);
+ result = Tcl_FSGetTranslatedStringPath(interp, path);
+ if (result == NULL) {
+ Tcl_DecrRefCount(path);
+ return NULL;
+ }
+ Tcl_DStringInit(bufferPtr);
+ Tcl_DStringAppend(bufferPtr, result, -1);
+ Tcl_DecrRefCount(path);
/*
- * Handle tilde substitutions, if needed.
+ * Convert forward slashes to backslashes in Windows paths because
+ * some system interfaces don't accept forward slashes.
*/
- if (name[0] == '~') {
- int argc, length;
- char **argv;
- Tcl_DString temp;
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+#if defined(__CYGWIN__) && defined(__WIN32__)
+
+ extern int cygwin_conv_to_win32_path
+ _ANSI_ARGS_((CONST char *, char *));
+ char winbuf[MAX_PATH];
- Tcl_SplitPath(name, &argc, (char ***) &argv);
-
/*
- * Strip the trailing ':' off of a Mac path before passing the user
- * name to DoTildeSubst.
+ * In the Cygwin world, call conv_to_win32_path in order to use the
+ * mount table to translate the file name into something Windows will
+ * understand. Take care when converting empty strings!
*/
-
- if (tclPlatform == TCL_PLATFORM_MAC) {
- length = strlen(argv[0]);
- argv[0][length-1] = '\0';
- }
-
- Tcl_DStringInit(&temp);
- argv[0] = DoTildeSubst(interp, argv[0]+1, &temp);
- if (argv[0] == NULL) {
- Tcl_DStringFree(&temp);
- ckfree((char *)argv);
- return NULL;
+ if (Tcl_DStringLength(bufferPtr)) {
+ cygwin_conv_to_win32_path(Tcl_DStringValue(bufferPtr), winbuf);
+ Tcl_DStringFree(bufferPtr);
+ Tcl_DStringAppend(bufferPtr, winbuf, -1);
}
- Tcl_DStringInit(bufferPtr);
- Tcl_JoinPath(argc, (char **) argv, bufferPtr);
- Tcl_DStringFree(&temp);
- ckfree((char*)argv);
- } else {
- Tcl_DStringInit(bufferPtr);
- Tcl_JoinPath(1, (char **) &name, bufferPtr);
- }
-
- /*
- * Convert forward slashes to backslashes in Windows paths because
- * some system interfaces don't accept forward slashes.
- */
+#else /* __CYGWIN__ && __WIN32__ */
-#ifndef __CYGWIN__
- if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ register char *p;
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '/') {
*p = '\\';
}
}
+#endif /* __CYGWIN__ && __WIN32__ */
}
-#endif
return Tcl_DStringValue(bufferPtr);
}
\f
break;
case TCL_PLATFORM_MAC:
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
if (strchr(name, ':') == NULL) {
lastSep = strrchr(name, '/');
} else {
lastSep = strrchr(name, ':');
}
+#else
+ lastSep = strrchr(name, ':');
+#endif
break;
case TCL_PLATFORM_WINDOWS:
break;
}
p = strrchr(name, '.');
- if ((p != NULL) && (lastSep != NULL)
- && (lastSep > p)) {
+ if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) {
p = NULL;
}
*----------------------------------------------------------------------
*/
-static char *
+static CONST char *
DoTildeSubst(interp, user, resultPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
Tcl_DString *resultPtr; /* Initialized DString filled with name
* after tilde substitution. */
{
- char *dir;
+ CONST char *dir;
if (*user == '\0') {
Tcl_DString dirString;
return NULL;
}
}
- return resultPtr->string;
+ return Tcl_DStringValue(resultPtr);
}
\f
/*
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int index, i, globFlags, pathlength, length, join, dir, result;
- char *string, *pathOrDir, *separators;
+ int index, i, globFlags, length, join, dir, result;
+ char *string, *separators;
Tcl_Obj *typePtr, *resultPtr, *look;
- Tcl_DString prefix, directory;
- static char *options[] = {
- "-directory", "-join", "-nocomplain", "-path", "-types", "--", NULL
+ Tcl_Obj *pathOrDir = NULL;
+ Tcl_DString prefix;
+ static CONST char *options[] = {
+ "-directory", "-join", "-nocomplain", "-path", "-tails",
+ "-types", "--", NULL
};
enum options {
- GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TYPE, GLOB_LAST
+ GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
+ GLOB_TYPE, GLOB_LAST
};
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
- GlobTypeData *globTypes = NULL;
+ Tcl_GlobTypeData *globTypes = NULL;
globFlags = 0;
join = 0;
dir = PATH_NONE;
- pathOrDir = NULL;
typePtr = NULL;
resultPtr = Tcl_GetObjResult(interp);
for (i = 1; i < objc; i++) {
}
switch (index) {
case GLOB_NOCOMPLAIN: /* -nocomplain */
- globFlags |= GLOBMODE_NO_COMPLAIN;
+ globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
break;
case GLOB_DIR: /* -dir */
if (i == (objc-1)) {
"missing argument to \"-directory\"", -1);
return TCL_ERROR;
}
- if (dir != -1) {
+ if (dir != PATH_NONE) {
Tcl_AppendToObj(resultPtr,
"\"-directory\" cannot be used with \"-path\"",
-1);
return TCL_ERROR;
}
dir = PATH_DIR;
- globFlags |= GLOBMODE_DIR;
- pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength);
+ globFlags |= TCL_GLOBMODE_DIR;
+ pathOrDir = objv[i+1];
i++;
break;
case GLOB_JOIN: /* -join */
join = 1;
break;
+ case GLOB_TAILS: /* -tails */
+ globFlags |= TCL_GLOBMODE_TAILS;
+ break;
case GLOB_PATH: /* -path */
if (i == (objc-1)) {
Tcl_AppendToObj(resultPtr,
"missing argument to \"-path\"", -1);
return TCL_ERROR;
}
- if (dir != -1) {
+ if (dir != PATH_NONE) {
Tcl_AppendToObj(resultPtr,
"\"-path\" cannot be used with \"-directory\"",
-1);
return TCL_ERROR;
}
dir = PATH_GENERAL;
- pathOrDir = Tcl_GetStringFromObj(objv[i+1], &pathlength);
+ pathOrDir = objv[i+1];
i++;
break;
case GLOB_TYPE: /* -types */
Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
return TCL_ERROR;
}
-
+ if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
+ Tcl_AppendToObj(resultPtr,
+ "\"-tails\" must be used with either \"-directory\" or \"-path\"",
+ -1);
+ return TCL_ERROR;
+ }
+
separators = NULL; /* lint. */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
break;
}
if (dir == PATH_GENERAL) {
+ int pathlength;
char *last;
+ char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
*/
- last = pathOrDir + pathlength;
- for (; last != pathOrDir; last--) {
+ last = first + pathlength;
+ for (; last != first; last--) {
if (strchr(separators, *(last-1)) != NULL) {
break;
}
}
- if (last == pathOrDir + pathlength) {
+ if (last == first + pathlength) {
/* It's really a directory */
- dir = 1;
+ dir = PATH_DIR;
} else {
Tcl_DString pref;
char *search, *find;
Tcl_DStringInit(&pref);
- Tcl_DStringInit(&directory);
- if (last == pathOrDir) {
+ if (last == first) {
/* The whole thing is a prefix */
- Tcl_DStringAppend(&pref, pathOrDir, -1);
+ Tcl_DStringAppend(&pref, first, -1);
pathOrDir = NULL;
} else {
/* Have to split off the end */
- Tcl_DStringAppend(&pref, last, pathOrDir+pathlength-last);
- Tcl_DStringAppend(&directory, pathOrDir, last-pathOrDir-1);
- pathOrDir = Tcl_DStringValue(&directory);
+ Tcl_DStringAppend(&pref, last, first+pathlength-last);
+ pathOrDir = Tcl_NewStringObj(first, last-first-1);
}
/* Need to quote 'prefix' */
Tcl_DStringInit(&prefix);
Tcl_DStringFree(&pref);
}
}
-
+
+ if (pathOrDir != NULL) {
+ Tcl_IncrRefCount(pathOrDir);
+ }
+
if (typePtr != NULL) {
/*
* The rest of the possible type arguments (except 'd') are
* on an incompatible platform.
*/
Tcl_ListObjLength(interp, typePtr, &length);
- globTypes = (GlobTypeData*) ckalloc(sizeof(GlobTypeData));
+ globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
}
}
/*
- * Error cases
+ * Error cases. We re-get the interpreter's result,
+ * just to be sure it hasn't changed, and we reset
+ * the 'join' flag to zero, since we haven't yet
+ * made use of it.
*/
badTypesArg:
+ resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
Tcl_AppendObjToObj(resultPtr, look);
result = TCL_ERROR;
+ join = 0;
goto endOfGlob;
badMacTypesArg:
+ resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr,
- "only one MacOS type or creator argument to \"-types\" allowed", -1);
+ "only one MacOS type or creator argument"
+ " to \"-types\" allowed", -1);
result = TCL_ERROR;
+ join = 0;
goto endOfGlob;
}
}
}
}
}
- if ((globFlags & GLOBMODE_NO_COMPLAIN) == 0) {
+ if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
&length) != TCL_OK) {
/* This should never happen. Maybe we should be more dramatic */
endOfGlob:
if (join || (dir == PATH_GENERAL)) {
Tcl_DStringFree(&prefix);
- if (dir == PATH_GENERAL) {
- Tcl_DStringFree(&directory);
- }
+ }
+ if (pathOrDir != NULL) {
+ Tcl_DecrRefCount(pathOrDir);
}
if (globTypes != NULL) {
if (globTypes->macType != NULL) {
* This procedure prepares arguments for the TclDoGlob call.
* It sets the separator string based on the platform, performs
* tilde substitution, and calls TclDoGlob.
+ *
+ * The interpreter's result, on entry to this function, must
+ * be a valid Tcl list (e.g. it could be empty), since we will
+ * lappend any new results to that list. If it is not a valid
+ * list, this function will fail to do anything very meaningful.
*
* Results:
* The return value is a standard Tcl result indicating whether
* an error occurred in globbing. After a normal return the
* result in interp (set by TclDoGlob) holds all of the file names
- * given by the dir and rem arguments. After an error the
- * result in interp will hold an error message.
+ * given by the pattern and unquotedPrefix arguments. After an
+ * error the result in interp will hold an error message, unless
+ * the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
+ * an error results in a TCL_OK return leaving the interpreter's
+ * result unmodified.
*
* Side effects:
- * The currentArgString is written to.
+ * The 'pattern' is written to.
*
*----------------------------------------------------------------------
*/
* or appending list of matching file names. */
char *pattern; /* Glob pattern to match. Must not refer
* to a static string. */
- char *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
- * is considered literally. May be static. */
+ Tcl_Obj *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
+ * is considered literally. */
int globFlags; /* Stores or'ed combination of flags */
- GlobTypeData *types; /* Struct containing acceptable types.
+ Tcl_GlobTypeData *types; /* Struct containing acceptable types.
* May be NULL. */
{
char *separators;
- char *head, *tail, *start;
+ CONST char *head;
+ char *tail, *start;
char c;
- int result;
+ int result, prefixLen;
Tcl_DString buffer;
+ Tcl_Obj *oldResult;
separators = NULL; /* lint. */
switch (tclPlatform) {
separators = "/\\:";
break;
case TCL_PLATFORM_MAC:
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
if (unquotedPrefix == NULL) {
separators = (strchr(pattern, ':') == NULL) ? "/" : ":";
} else {
separators = ":";
}
+#else
+ separators = ":";
+#endif
break;
}
Tcl_DStringInit(&buffer);
if (unquotedPrefix != NULL) {
- start = unquotedPrefix;
+ start = Tcl_GetString(unquotedPrefix);
} else {
start = pattern;
}
}
/*
- * Determine the home directory for the specified user. Note that
- * we don't allow special characters in the user name.
+ * Determine the home directory for the specified user.
*/
c = *tail;
*tail = '\0';
- /*
- * I don't think we need to worry about special characters in
- * the user name anymore (Vince Darley, June 1999), since the
- * new code is designed to handle special chars.
- */
-#ifndef NOT_NEEDED_ANYMORE
- head = DoTildeSubst(interp, start+1, &buffer);
-#else
-
- if (strpbrk(start+1, "\\[]*?{}") == NULL) {
- head = DoTildeSubst(interp, start+1, &buffer);
+ if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
+ /*
+ * We will ignore any error message here, and we
+ * don't want to mess up the interpreter's result.
+ */
+ head = DoTildeSubst(NULL, start+1, &buffer);
} else {
- if (!(globFlags & GLOBMODE_NO_COMPLAIN)) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "globbing characters not ",
- "supported in user names", (char *) NULL);
- }
- head = NULL;
+ head = DoTildeSubst(interp, start+1, &buffer);
}
-#endif
*tail = c;
if (head == NULL) {
- if (globFlags & GLOBMODE_NO_COMPLAIN) {
- /*
- * We should in fact pass down the nocomplain flag
- * or save the interp result or use another mechanism
- * so the interp result is not mangled on errors in that case.
- * but that would a bigger change than reasonable for a patch
- * release.
- * (see fileName.test 15.2-15.4 for expected behaviour)
- */
- Tcl_ResetResult(interp);
+ if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
return TCL_OK;
} else {
return TCL_ERROR;
} else {
tail = pattern;
if (unquotedPrefix != NULL) {
- Tcl_DStringAppend(&buffer,unquotedPrefix,-1);
+ Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1);
}
}
+
/*
- * If the prefix is a directory, make sure it ends in a directory
- * separator.
+ * We want to remember the length of the current prefix,
+ * in case we are using TCL_GLOBMODE_TAILS. Also if we
+ * are using TCL_GLOBMODE_DIR, we must make sure the
+ * prefix ends in a directory separator.
*/
- if (unquotedPrefix != NULL) {
- if (globFlags & GLOBMODE_DIR) {
- c = Tcl_DStringValue(&buffer)[Tcl_DStringLength(&buffer)-1];
- if (strchr(separators, c) == NULL) {
+ prefixLen = Tcl_DStringLength(&buffer);
+
+ if (prefixLen > 0) {
+ c = Tcl_DStringValue(&buffer)[prefixLen-1];
+ if (strchr(separators, c) == NULL) {
+ /*
+ * If the prefix is a directory, make sure it ends in a
+ * directory separator.
+ */
+ if (globFlags & TCL_GLOBMODE_DIR) {
Tcl_DStringAppend(&buffer,separators,1);
}
+ prefixLen++;
}
}
+ /*
+ * We need to get the old result, in case it is over-written
+ * below when we still need it.
+ */
+ oldResult = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(oldResult);
+ Tcl_ResetResult(interp);
+
result = TclDoGlob(interp, separators, &buffer, tail, types);
- Tcl_DStringFree(&buffer);
+
if (result != TCL_OK) {
- if (globFlags & GLOBMODE_NO_COMPLAIN) {
- Tcl_ResetResult(interp);
- return TCL_OK;
+ if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
+ /* Put back the old result and reset the return code */
+ Tcl_SetObjResult(interp, oldResult);
+ result = TCL_OK;
+ }
+ } else {
+ /*
+ * Now we must concatenate the 'oldResult' and the current
+ * result, and then place that into the interpreter.
+ *
+ * If we only want the tails, we must strip off the prefix now.
+ * It may seem more efficient to pass the tails flag down into
+ * TclDoGlob, Tcl_FSMatchInDirectory, but those functions are
+ * continually adjusting the prefix as the various pieces of
+ * the pattern are assimilated, so that would add a lot of
+ * complexity to the code. This way is a little slower (when
+ * the -tails flag is given), but much simpler to code.
+ */
+ int objc, i;
+ Tcl_Obj **objv;
+
+ /* Ensure sole ownership */
+ if (Tcl_IsShared(oldResult)) {
+ Tcl_DecrRefCount(oldResult);
+ oldResult = Tcl_DuplicateObj(oldResult);
+ Tcl_IncrRefCount(oldResult);
+ }
+
+ Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp),
+ &objc, &objv);
+#ifdef MAC_TCL
+ /* adjust prefixLen if TclDoGlob prepended a ':' */
+ if ((prefixLen > 0) && (objc > 0)
+ && (Tcl_DStringValue(&buffer)[0] != ':')) {
+ char *str = Tcl_GetStringFromObj(objv[0],NULL);
+ if (str[0] == ':') {
+ prefixLen++;
+ }
+ }
+#endif
+ for (i = 0; i< objc; i++) {
+ Tcl_Obj* elt;
+ if (globFlags & TCL_GLOBMODE_TAILS) {
+ int len;
+ char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
+ if (len == prefixLen) {
+ if ((pattern[0] == '\0')
+ || (strchr(separators, pattern[0]) == NULL)) {
+ elt = Tcl_NewStringObj(".",1);
+ } else {
+ elt = Tcl_NewStringObj("/",1);
+ }
+ } else {
+ elt = Tcl_NewStringObj(oldStr + prefixLen,
+ len - prefixLen);
+ }
+ } else {
+ elt = objv[i];
+ }
+ /* Assumption that 'oldResult' is a valid list */
+ Tcl_ListObjAppendElement(interp, oldResult, elt);
}
+ Tcl_SetObjResult(interp, oldResult);
}
+ /*
+ * Release our temporary copy. All code paths above must
+ * end here so we free our reference.
+ */
+ Tcl_DecrRefCount(oldResult);
+ Tcl_DStringFree(&buffer);
return result;
}
\f
Tcl_DString *headPtr; /* Completely expanded prefix. */
char *tail; /* The unexpanded remainder of the path.
* Must not be a pointer to a static string. */
- GlobTypeData *types; /* List object containing list of acceptable types.
- * May be NULL. */
+ Tcl_GlobTypeData *types; /* List object containing list of acceptable
+ * types. May be NULL. */
{
int baseLength, quoted, count;
int result = TCL_OK;
switch (tclPlatform) {
case TCL_PLATFORM_MAC:
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
if (*separators == '/') {
if (((length == 0) && (count == 0))
|| ((length > 0) && (lastChar != ':'))) {
Tcl_DStringAppend(headPtr, ":", 1);
}
} else {
+#endif
if (count == 0) {
if ((length > 0) && (lastChar != ':')) {
Tcl_DStringAppend(headPtr, ":", 1);
Tcl_DStringAppend(headPtr, ":", 1);
}
}
+#ifdef MAC_UNDERSTANDS_UNIX_PATHS
}
+#endif
break;
case TCL_PLATFORM_WINDOWS:
/*
* element. Add an extra slash if this is a UNC path.
*/
+#if defined(__CYGWIN__) && defined(__WIN32__)
+ {
+
+ extern int cygwin_conv_to_win32_path
+ _ANSI_ARGS_((CONST char *, char *));
+ char winbuf[MAX_PATH];
+
+ /*
+ * In the Cygwin world, call conv_to_win32_path in order to use
+ * the mount table to translate the file name into something
+ * Windows will understand.
+ */
+ cygwin_conv_to_win32_path(Tcl_DStringValue(headPtr), winbuf);
+ Tcl_DStringFree(headPtr);
+ Tcl_DStringAppend(headPtr, winbuf, -1);
+
+ }
+#endif /* __CYGWIN__ && __WIN32__ */
+
if (*name == ':') {
Tcl_DStringAppend(headPtr, ":", 1);
if (count > 1) {
Tcl_DStringSetLength(&newName, baseLength);
Tcl_DStringAppend(&newName, element, p-element);
Tcl_DStringAppend(&newName, closeBrace+1, -1);
- result = TclDoGlob(interp, separators,
- headPtr, Tcl_DStringValue(&newName), types);
+ result = TclDoGlob(interp, separators, headPtr,
+ Tcl_DStringValue(&newName), types);
if (result != TCL_OK) {
break;
}
* if the string is a static.
*/
- savedChar = *p;
- *p = '\0';
- firstSpecialChar = strpbrk(tail, "*[]?\\");
- *p = savedChar;
+ savedChar = *p;
+ *p = '\0';
+ firstSpecialChar = strpbrk(tail, "*[]?\\");
+ *p = savedChar;
} else {
firstSpecialChar = strpbrk(tail, "*[]?\\");
}
if (firstSpecialChar != NULL) {
+ int ret;
+ Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1);
+ Tcl_IncrRefCount(head);
/*
- * Look for matching files in the current directory. The
- * implementation of this function is platform specific, but may
- * recursively call TclDoGlob. For each file that matches, it will
- * add the match onto the interp's result, or call TclDoGlob if there
- * are more characters to be processed.
+ * Look for matching files in the given directory. The
+ * implementation of this function is platform specific. For
+ * each file that matches, it will add the match onto the
+ * resultPtr given.
*/
+ if (*p == '\0') {
+ ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
+ head, tail, types);
+ } else {
+ Tcl_Obj* resultPtr;
- return TclpMatchFilesTypes(interp, separators, headPtr, tail, p, types);
+ /*
+ * We do the recursion ourselves. This makes implementing
+ * Tcl_FSMatchInDirectory for each filesystem much easier.
+ */
+ Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL };
+ char save = *p;
+
+ *p = '\0';
+ resultPtr = Tcl_NewListObj(0, NULL);
+ ret = Tcl_FSMatchInDirectory(interp, resultPtr,
+ head, tail, &dirOnly);
+ *p = save;
+ if (ret == TCL_OK) {
+ int resLength;
+ ret = Tcl_ListObjLength(interp, resultPtr, &resLength);
+ if (ret == TCL_OK) {
+ int i;
+ for (i =0; i< resLength; i++) {
+ Tcl_Obj *elt;
+ Tcl_DString ds;
+ Tcl_ListObjIndex(interp, resultPtr, i, &elt);
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1);
+ if(tclPlatform == TCL_PLATFORM_MAC) {
+ Tcl_DStringAppend(&ds, ":",1);
+ } else {
+ Tcl_DStringAppend(&ds, "/",1);
+ }
+ ret = TclDoGlob(interp, separators, &ds, p+1, types);
+ Tcl_DStringFree(&ds);
+ if (ret != TCL_OK) {
+ break;
+ }
+ }
+ }
+ }
+ Tcl_DecrRefCount(resultPtr);
+ }
+ Tcl_DecrRefCount(head);
+ return ret;
}
Tcl_DStringAppend(headPtr, tail, p-tail);
if (*p != '\0') {
return TclDoGlob(interp, separators, headPtr, p, types);
- }
+ } else {
+ /*
+ * This is the code path reached by a command like 'glob foo'.
+ *
+ * There are no more wildcards in the pattern and no more
+ * unprocessed characters in the tail, so now we can construct
+ * the path, and pass it to Tcl_FSMatchInDirectory with an
+ * empty pattern to verify the existence of the file and check
+ * it is of the correct type (if a 'types' flag it given -- if
+ * no such flag was given, we could just use 'Tcl_FSLStat', but
+ * for simplicity we keep to a common approach).
+ */
- /*
- * There are no more wildcards in the pattern and no more unprocessed
- * characters in the tail, so now we can construct the path and verify
- * the existence of the file.
- */
+ Tcl_Obj *nameObj;
+ /* Used to deal with one special case pertinent to MacOS */
+ int macSpecialCase = 0;
- switch (tclPlatform) {
- case TCL_PLATFORM_MAC: {
- if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
- Tcl_DStringAppend(headPtr, ":", 1);
- }
- name = Tcl_DStringValue(headPtr);
- if (TclpAccess(name, F_OK) == 0) {
- if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) {
- Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(name + 1,-1));
- } else {
- Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(name,-1));
+ switch (tclPlatform) {
+ case TCL_PLATFORM_MAC: {
+ if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
+ Tcl_DStringAppend(headPtr, ":", 1);
}
+ macSpecialCase = 1;
+ break;
}
- break;
- }
- case TCL_PLATFORM_WINDOWS: {
- int exists;
-#ifndef __CYGWIN__
-
- /*
- * We need to convert slashes to backslashes before checking
- * for the existence of the file. Once we are done, we need
- * to convert the slashes back.
- */
-
- if (Tcl_DStringLength(headPtr) == 0) {
- if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
- || (*name == '/')) {
- Tcl_DStringAppend(headPtr, "\\", 1);
- } else {
- Tcl_DStringAppend(headPtr, ".", 1);
+ case TCL_PLATFORM_WINDOWS: {
+ if (Tcl_DStringLength(headPtr) == 0) {
+ if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
+ || (*name == '/')) {
+ Tcl_DStringAppend(headPtr, "\\", 1);
+ } else {
+ Tcl_DStringAppend(headPtr, ".", 1);
+ }
}
- } else {
+ /*
+ * Convert to forward slashes. This is required to pass
+ * some Tcl tests. We should probably remove the conversions
+ * here and in tclWinFile.c, since they aren't needed since
+ * the dropping of support for Win32s.
+ */
for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
- if (*p == '/') {
- *p = '\\';
+ if (*p == '\\') {
+ *p = '/';
}
}
+ break;
}
-#endif
- name = Tcl_DStringValue(headPtr);
- exists = (TclpAccess(name, F_OK) == 0);
-
- for (p = name; *p != '\0'; p++) {
- if (*p == '\\') {
- *p = '/';
+ case TCL_PLATFORM_UNIX: {
+ if (Tcl_DStringLength(headPtr) == 0) {
+ if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
+ Tcl_DStringAppend(headPtr, "/", 1);
+ } else {
+ Tcl_DStringAppend(headPtr, ".", 1);
+ }
}
+ break;
}
- if (exists) {
- Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(name,-1));
- }
- break;
}
- case TCL_PLATFORM_UNIX: {
- if (Tcl_DStringLength(headPtr) == 0) {
- if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
- Tcl_DStringAppend(headPtr, "/", 1);
- } else {
- Tcl_DStringAppend(headPtr, ".", 1);
- }
- }
- name = Tcl_DStringValue(headPtr);
- if (TclpAccess(name, F_OK) == 0) {
- Tcl_ListObjAppendElement(interp, Tcl_GetObjResult(interp),
- Tcl_NewStringObj(name,-1));
- }
- break;
+ /* Common for all platforms */
+ name = Tcl_DStringValue(headPtr);
+ nameObj = Tcl_NewStringObj(name, Tcl_DStringLength(headPtr));
+
+ Tcl_IncrRefCount(nameObj);
+ Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), nameObj,
+ NULL, types);
+ Tcl_DecrRefCount(nameObj);
+ return TCL_OK;
+ }
+}
+
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFileDirname
+ *
+ * This procedure calculates the directory above a given
+ * path: basically 'file dirname'. It is used both by
+ * the 'dirname' subcommand of file and by code in tclIOUtil.c.
+ *
+ * Results:
+ * NULL if an error occurred, otherwise a Tcl_Obj owned by
+ * the caller (i.e. most likely with refCount 1).
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclFileDirname(interp, pathPtr)
+ Tcl_Interp *interp; /* Used for error reporting */
+ Tcl_Obj *pathPtr; /* Path to take dirname of */
+{
+ int splitElements;
+ Tcl_Obj *splitPtr;
+ Tcl_Obj *splitResultPtr = NULL;
+
+ /*
+ * The behaviour we want here is slightly different to
+ * the standard Tcl_FSSplitPath in the handling of home
+ * directories; Tcl_FSSplitPath preserves the "~" while
+ * this code computes the actual full path name, if we
+ * had just a single component.
+ */
+ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
+ if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) {
+ Tcl_DecrRefCount(splitPtr);
+ splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
+ if (splitPtr == NULL) {
+ return NULL;
}
+ splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
}
- return TCL_OK;
+ /*
+ * Return all but the last component. If there is only one
+ * component, return it if the path was non-relative, otherwise
+ * return the current directory.
+ */
+
+ if (splitElements > 1) {
+ splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
+ } else if (splitElements == 0 ||
+ (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
+ splitResultPtr = Tcl_NewStringObj(
+ ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
+ } else {
+ Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr);
+ }
+ Tcl_IncrRefCount(splitResultPtr);
+ Tcl_DecrRefCount(splitPtr);
+ return splitResultPtr;
}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_AllocStatBuf
+ *
+ * This procedure allocates a Tcl_StatBuf on the heap. It exists
+ * so that extensions may be used unchanged on systems where
+ * largefile support is optional.
+ *
+ * Results:
+ * A pointer to a Tcl_StatBuf which may be deallocated by being
+ * passed to ckfree().
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_StatBuf *
+Tcl_AllocStatBuf() {
+ return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
+}
int
Tcl_GetInt(interp, string, intPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- char *string; /* String containing a (possibly signed)
+ CONST char *string; /* String containing a (possibly signed)
* integer in a form acceptable to strtol. */
int *intPtr; /* Place to store converted result. */
{
- char *end, *p;
+ char *end;
+ CONST char *p;
long i;
/*
TclGetLong(interp, string, longPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting
* if not NULL. */
- char *string; /* String containing a (possibly signed)
+ CONST char *string; /* String containing a (possibly signed)
* long integer in a form acceptable to
* strtoul. */
long *longPtr; /* Place to store converted long result. */
{
- char *end, *p;
+ char *end;
+ CONST char *p;
long i;
/*
int
Tcl_GetDouble(interp, string, doublePtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
- char *string; /* String containing a floating-point number
+ CONST char *string; /* String containing a floating-point number
* in a form acceptable to strtod. */
double *doublePtr; /* Place to store converted result. */
{
int
Tcl_GetBoolean(interp, string, boolPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
- char *string; /* String containing a boolean number
+ CONST char *string; /* String containing a boolean number
* specified either as 1/0 or true/false or
* yes/no. */
int *boolPtr; /* Place to store converted result, which
}
return TCL_OK;
}
-
#include "tclInt.h"
#include "tclPort.h"
-#ifdef MAC_TCL
+#if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH)
# define EPOCH 1904
# define START_OF_TIME 1904
# define END_OF_TIME 2039
result = Convert(Month, (time_t) tm->tm_mday, Year,
(time_t) tm->tm_hour, (time_t) tm->tm_min, (time_t) tm->tm_sec,
MER24, DSTmaybe, &Julian);
+
+ /*
+ * The Julian time returned above is behind by one day, if "month"
+ * or "year" is used to specify relative time and the GMT flag is true.
+ * This problem occurs only when the current time is closer to
+ * midnight, the difference being not more than its time difference
+ * with GMT. For example, in US/Pacific time zone, the problem occurs
+ * whenever the current time is between midnight to 8:00am or 7:00amDST.
+ * See Bug# 413397 for more details and sample script.
+ * To resolve this bug, we simply add the number of seconds corresponding
+ * to timezone difference with GMT to Julian time, if GMT flag is true.
+ */
+
+ if (TclDateTimezone == 0) {
+ Julian += TclpGetTimeZone((unsigned long) Start) * 60L;
+ }
+
/*
* The following iteration takes into account the case were we jump
* into a "short month". Far example, "one month from Jan 31" will
*timePtr = Start;
return 0;
}
-
#include "tclInt.h"
/*
+ * Prevent macros from clashing with function definitions.
+ */
+
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# undef Tcl_FindHashEntry
+# undef Tcl_CreateHashEntry
+#endif
+
+/*
* When there are this many entries per bucket, on average, rebuild
* the hash table to make it larger.
*/
#define REBUILD_MULTIPLIER 3
-
/*
* The following macro takes a preliminary integer hash value and
* produces an index into a hash tables bucket list. The idea is
(((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask)
/*
+ * Prototypes for the array hash key methods.
+ */
+
+static Tcl_HashEntry * AllocArrayEntry _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+static int CompareArrayKeys _ANSI_ARGS_((
+ VOID *keyPtr, Tcl_HashEntry *hPtr));
+static unsigned int HashArrayKey _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+
+/*
+ * Prototypes for the one word hash key methods.
+ */
+
+#if 0
+static Tcl_HashEntry * AllocOneWordEntry _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+static int CompareOneWordKeys _ANSI_ARGS_((
+ VOID *keyPtr, Tcl_HashEntry *hPtr));
+static unsigned int HashOneWordKey _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+#endif
+
+/*
+ * Prototypes for the string hash key methods.
+ */
+
+static Tcl_HashEntry * AllocStringEntry _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+static int CompareStringKeys _ANSI_ARGS_((
+ VOID *keyPtr, Tcl_HashEntry *hPtr));
+static unsigned int HashStringKey _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+
+/*
* Procedure prototypes for static procedures in this file:
*/
-static Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key));
-static Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key, int *newPtr));
+#if TCL_PRESERVE_BINARY_COMPATABILITY
static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key));
static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
CONST char *key, int *newPtr));
-static unsigned int HashString _ANSI_ARGS_((CONST char *string));
+#endif
+
static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr));
-static Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key));
-static Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key, int *newPtr));
-static Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key));
-static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr,
- CONST char *key, int *newPtr));
+
+Tcl_HashKeyType tclArrayHashKeyType = {
+ TCL_HASH_KEY_TYPE_VERSION, /* version */
+ TCL_HASH_KEY_RANDOMIZE_HASH, /* flags */
+ HashArrayKey, /* hashKeyProc */
+ CompareArrayKeys, /* compareKeysProc */
+ AllocArrayEntry, /* allocEntryProc */
+ NULL /* freeEntryProc */
+};
+
+Tcl_HashKeyType tclOneWordHashKeyType = {
+ TCL_HASH_KEY_TYPE_VERSION, /* version */
+ 0, /* flags */
+ NULL, /* HashOneWordKey, */ /* hashProc */
+ NULL, /* CompareOneWordKey, */ /* compareProc */
+ NULL, /* AllocOneWordKey, */ /* allocEntryProc */
+ NULL /* FreeOneWordKey, */ /* freeEntryProc */
+};
+
+Tcl_HashKeyType tclStringHashKeyType = {
+ TCL_HASH_KEY_TYPE_VERSION, /* version */
+ 0, /* flags */
+ HashStringKey, /* hashKeyProc */
+ CompareStringKeys, /* compareKeysProc */
+ AllocStringEntry, /* allocEntryProc */
+ NULL /* freeEntryProc */
+};
+
\f
/*
*----------------------------------------------------------------------
*----------------------------------------------------------------------
*/
+#undef Tcl_InitHashTable
void
Tcl_InitHashTable(tablePtr, keyType)
register Tcl_HashTable *tablePtr; /* Pointer to table record, which
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* or an integer >= 2. */
{
+ /*
+ * Use a special value to inform the extended version that it must
+ * not access any of the new fields in the Tcl_HashTable. If an
+ * extension is rebuilt then any calls to this function will be
+ * redirected to the extended version by a macro.
+ */
+ Tcl_InitCustomHashTable(tablePtr, keyType, (Tcl_HashKeyType *) -1);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitCustomHashTable --
+ *
+ * Given storage for a hash table, set up the fields to prepare
+ * the hash table for use. This is an extended version of
+ * Tcl_InitHashTable which supports user defined keys.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * TablePtr is now ready to be passed to Tcl_FindHashEntry and
+ * Tcl_CreateHashEntry.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_InitCustomHashTable(tablePtr, keyType, typePtr)
+ register Tcl_HashTable *tablePtr; /* Pointer to table record, which
+ * is supplied by the caller. */
+ int keyType; /* Type of keys to use in table:
+ * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
+ * TCL_CUSTOM_TYPE_KEYS,
+ * TCL_CUSTOM_PTR_KEYS, or an
+ * integer >= 2. */
+ Tcl_HashKeyType *typePtr; /* Pointer to structure which defines
+ * the behaviour of this table. */
+{
#if (TCL_SMALL_HASH_TABLE != 4)
- panic("Tcl_InitHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
+ panic("Tcl_InitCustomHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
TCL_SMALL_HASH_TABLE);
#endif
tablePtr->downShift = 28;
tablePtr->mask = 3;
tablePtr->keyType = keyType;
- if (keyType == TCL_STRING_KEYS) {
- tablePtr->findProc = StringFind;
- tablePtr->createProc = StringCreate;
- } else if (keyType == TCL_ONE_WORD_KEYS) {
- tablePtr->findProc = OneWordFind;
- tablePtr->createProc = OneWordCreate;
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ tablePtr->findProc = Tcl_FindHashEntry;
+ tablePtr->createProc = Tcl_CreateHashEntry;
+
+ if (typePtr == NULL) {
+ /*
+ * The caller has been rebuilt so the hash table is an extended
+ * version.
+ */
+ } else if (typePtr != (Tcl_HashKeyType *) -1) {
+ /*
+ * The caller is requesting a customized hash table so it must be
+ * an extended version.
+ */
+ tablePtr->typePtr = typePtr;
+ } else {
+ /*
+ * The caller has not been rebuilt so the hash table is not
+ * extended.
+ */
+ }
+#else
+ if (typePtr == NULL) {
+ /*
+ * Use the key type to decide which key type is needed.
+ */
+ if (keyType == TCL_STRING_KEYS) {
+ typePtr = &tclStringHashKeyType;
+ } else if (keyType == TCL_ONE_WORD_KEYS) {
+ typePtr = &tclOneWordHashKeyType;
+ } else if (keyType == TCL_CUSTOM_TYPE_KEYS) {
+ Tcl_Panic ("No type structure specified for TCL_CUSTOM_TYPE_KEYS");
+ } else if (keyType == TCL_CUSTOM_PTR_KEYS) {
+ Tcl_Panic ("No type structure specified for TCL_CUSTOM_PTR_KEYS");
+ } else {
+ typePtr = &tclArrayHashKeyType;
+ }
+ } else if (typePtr == (Tcl_HashKeyType *) -1) {
+ /*
+ * If the caller has not been rebuilt then we cannot continue as
+ * the hash table is not an extended version.
+ */
+ Tcl_Panic ("Hash table is not compatible");
+ }
+ tablePtr->typePtr = typePtr;
+#endif
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindHashEntry --
+ *
+ * Given a hash table find the entry with a matching key.
+ *
+ * Results:
+ * The return value is a token for the matching entry in the
+ * hash table, or NULL if there was no matching entry.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashEntry *
+Tcl_FindHashEntry(tablePtr, key)
+ Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
+ CONST char *key; /* Key to use to find matching entry. */
+{
+ register Tcl_HashEntry *hPtr;
+ Tcl_HashKeyType *typePtr;
+ unsigned int hash;
+ int index;
+
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ if (tablePtr->keyType == TCL_STRING_KEYS) {
+ typePtr = &tclStringHashKeyType;
+ } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+ typePtr = &tclOneWordHashKeyType;
+ } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+ || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+ typePtr = tablePtr->typePtr;
+ } else {
+ typePtr = &tclArrayHashKeyType;
+ }
+#else
+ typePtr = tablePtr->typePtr;
+ if (typePtr == NULL) {
+ Tcl_Panic("called Tcl_FindHashEntry on deleted table");
+ return NULL;
+ }
+#endif
+
+ if (typePtr->hashKeyProc) {
+ hash = typePtr->hashKeyProc (tablePtr, (VOID *) key);
+ if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
+ index = RANDOM_INDEX (tablePtr, hash);
+ } else {
+ index = hash & tablePtr->mask;
+ }
+ } else {
+ hash = (unsigned int) key;
+ index = RANDOM_INDEX (tablePtr, hash);
+ }
+
+ /*
+ * Search all of the entries in the appropriate bucket.
+ */
+
+ if (typePtr->compareKeysProc) {
+ for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+ hPtr = hPtr->nextPtr) {
+#if TCL_HASH_KEY_STORE_HASH
+ if (hash != (unsigned int) hPtr->hash) {
+ continue;
+ }
+#endif
+ if (typePtr->compareKeysProc ((VOID *) key, hPtr)) {
+ return hPtr;
+ }
+ }
+ } else {
+ for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+ hPtr = hPtr->nextPtr) {
+#if TCL_HASH_KEY_STORE_HASH
+ if (hash != (unsigned int) hPtr->hash) {
+ continue;
+ }
+#endif
+ if (key == hPtr->key.oneWordValue) {
+ return hPtr;
+ }
+ }
+ }
+
+ return NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateHashEntry --
+ *
+ * Given a hash table with string keys, and a string key, find
+ * the entry with a matching key. If there is no matching entry,
+ * then create a new entry that does match.
+ *
+ * Results:
+ * The return value is a pointer to the matching entry. If this
+ * is a newly-created entry, then *newPtr will be set to a non-zero
+ * value; otherwise *newPtr will be set to 0. If this is a new
+ * entry the value stored in the entry will initially be 0.
+ *
+ * Side effects:
+ * A new entry may be added to the hash table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashEntry *
+Tcl_CreateHashEntry(tablePtr, key, newPtr)
+ Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
+ CONST char *key; /* Key to use to find or create matching
+ * entry. */
+ int *newPtr; /* Store info here telling whether a new
+ * entry was created. */
+{
+ register Tcl_HashEntry *hPtr;
+ Tcl_HashKeyType *typePtr;
+ unsigned int hash;
+ int index;
+
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ if (tablePtr->keyType == TCL_STRING_KEYS) {
+ typePtr = &tclStringHashKeyType;
+ } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+ typePtr = &tclOneWordHashKeyType;
+ } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+ || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+ typePtr = tablePtr->typePtr;
+ } else {
+ typePtr = &tclArrayHashKeyType;
+ }
+#else
+ typePtr = tablePtr->typePtr;
+ if (typePtr == NULL) {
+ Tcl_Panic("called Tcl_CreateHashEntry on deleted table");
+ return NULL;
+ }
+#endif
+
+ if (typePtr->hashKeyProc) {
+ hash = typePtr->hashKeyProc (tablePtr, (VOID *) key);
+ if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
+ index = RANDOM_INDEX (tablePtr, hash);
+ } else {
+ index = hash & tablePtr->mask;
+ }
+ } else {
+ hash = (unsigned int) key;
+ index = RANDOM_INDEX (tablePtr, hash);
+ }
+
+ /*
+ * Search all of the entries in the appropriate bucket.
+ */
+
+ if (typePtr->compareKeysProc) {
+ for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+ hPtr = hPtr->nextPtr) {
+#if TCL_HASH_KEY_STORE_HASH
+ if (hash != (unsigned int) hPtr->hash) {
+ continue;
+ }
+#endif
+ if (typePtr->compareKeysProc ((VOID *) key, hPtr)) {
+ *newPtr = 0;
+ return hPtr;
+ }
+ }
+ } else {
+ for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+ hPtr = hPtr->nextPtr) {
+#if TCL_HASH_KEY_STORE_HASH
+ if (hash != (unsigned int) hPtr->hash) {
+ continue;
+ }
+#endif
+ if (key == hPtr->key.oneWordValue) {
+ *newPtr = 0;
+ return hPtr;
+ }
+ }
+ }
+
+ /*
+ * Entry not found. Add a new one to the bucket.
+ */
+
+ *newPtr = 1;
+ if (typePtr->allocEntryProc) {
+ hPtr = typePtr->allocEntryProc (tablePtr, (VOID *) key);
} else {
- tablePtr->findProc = ArrayFind;
- tablePtr->createProc = ArrayCreate;
- };
+ hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry));
+ hPtr->key.oneWordValue = (char *) key;
+ }
+
+ hPtr->tablePtr = tablePtr;
+#if TCL_HASH_KEY_STORE_HASH
+# if TCL_PRESERVE_BINARY_COMPATABILITY
+ hPtr->hash = (VOID *) hash;
+# else
+ hPtr->hash = hash;
+# endif
+ hPtr->nextPtr = tablePtr->buckets[index];
+ tablePtr->buckets[index] = hPtr;
+#else
+ hPtr->bucketPtr = &(tablePtr->buckets[index]);
+ hPtr->nextPtr = *hPtr->bucketPtr;
+ *hPtr->bucketPtr = hPtr;
+#endif
+ hPtr->clientData = 0;
+ tablePtr->numEntries++;
+
+ /*
+ * If the table has exceeded a decent size, rebuild it with many
+ * more buckets.
+ */
+
+ if (tablePtr->numEntries >= tablePtr->rebuildSize) {
+ RebuildTable(tablePtr);
+ }
+ return hPtr;
}
\f
/*
Tcl_HashEntry *entryPtr;
{
register Tcl_HashEntry *prevPtr;
+ Tcl_HashKeyType *typePtr;
+ Tcl_HashTable *tablePtr;
+ Tcl_HashEntry **bucketPtr;
+#if TCL_HASH_KEY_STORE_HASH
+ int index;
+#endif
+
+ tablePtr = entryPtr->tablePtr;
- if (*entryPtr->bucketPtr == entryPtr) {
- *entryPtr->bucketPtr = entryPtr->nextPtr;
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ if (tablePtr->keyType == TCL_STRING_KEYS) {
+ typePtr = &tclStringHashKeyType;
+ } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+ typePtr = &tclOneWordHashKeyType;
+ } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+ || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+ typePtr = tablePtr->typePtr;
+ } else {
+ typePtr = &tclArrayHashKeyType;
+ }
+#else
+ typePtr = tablePtr->typePtr;
+#endif
+
+#if TCL_HASH_KEY_STORE_HASH
+ if (typePtr->hashKeyProc == NULL
+ || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
+ index = RANDOM_INDEX (tablePtr, entryPtr->hash);
+ } else {
+ index = ((unsigned int) entryPtr->hash) & tablePtr->mask;
+ }
+
+ bucketPtr = &(tablePtr->buckets[index]);
+#else
+ bucketPtr = entryPtr->bucketPtr;
+#endif
+
+ if (*bucketPtr == entryPtr) {
+ *bucketPtr = entryPtr->nextPtr;
} else {
- for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) {
+ for (prevPtr = *bucketPtr; ; prevPtr = prevPtr->nextPtr) {
if (prevPtr == NULL) {
panic("malformed bucket chain in Tcl_DeleteHashEntry");
}
}
}
}
- entryPtr->tablePtr->numEntries--;
- ckfree((char *) entryPtr);
+
+ tablePtr->numEntries--;
+ if (typePtr->freeEntryProc) {
+ typePtr->freeEntryProc (entryPtr);
+ } else {
+ ckfree((char *) entryPtr);
+ }
}
\f
/*
register Tcl_HashTable *tablePtr; /* Table to delete. */
{
register Tcl_HashEntry *hPtr, *nextPtr;
+ Tcl_HashKeyType *typePtr;
int i;
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ if (tablePtr->keyType == TCL_STRING_KEYS) {
+ typePtr = &tclStringHashKeyType;
+ } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+ typePtr = &tclOneWordHashKeyType;
+ } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+ || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+ typePtr = tablePtr->typePtr;
+ } else {
+ typePtr = &tclArrayHashKeyType;
+ }
+#else
+ typePtr = tablePtr->typePtr;
+#endif
+
/*
* Free up all the entries in the table.
*/
hPtr = tablePtr->buckets[i];
while (hPtr != NULL) {
nextPtr = hPtr->nextPtr;
- ckfree((char *) hPtr);
+ if (typePtr->freeEntryProc) {
+ typePtr->freeEntryProc (hPtr);
+ } else {
+ ckfree((char *) hPtr);
+ }
hPtr = nextPtr;
}
}
* re-initialization.
*/
+#if TCL_PRESERVE_BINARY_COMPATABILITY
tablePtr->findProc = BogusFind;
tablePtr->createProc = BogusCreate;
+#else
+ tablePtr->typePtr = NULL;
+#endif
}
\f
/*
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_HashStats(tablePtr)
Tcl_HashTable *tablePtr; /* Table for which to produce stats. */
{
/*
*----------------------------------------------------------------------
*
- * HashString --
+ * AllocArrayEntry --
*
- * Compute a one-word summary of a text string, which can be
- * used to generate a hash index.
+ * Allocate space for a Tcl_HashEntry containing the array key.
*
* Results:
- * The return value is a one-word summary of the information in
- * string.
+ * The return value is a pointer to the created entry.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-static unsigned int
-HashString(string)
- register CONST char *string;/* String from which to compute hash value. */
+static Tcl_HashEntry *
+AllocArrayEntry(tablePtr, keyPtr)
+ Tcl_HashTable *tablePtr; /* Hash table. */
+ VOID *keyPtr; /* Key to store in the hash table entry. */
{
- register unsigned int result;
- register int c;
-
- /*
- * I tried a zillion different hash functions and asked many other
- * people for advice. Many people had their own favorite functions,
- * all different, but no-one had much idea why they were good ones.
- * I chose the one below (multiply by 9 and add new character)
- * because of the following reasons:
- *
- * 1. Multiplying by 10 is perfect for keys that are decimal strings,
- * and multiplying by 9 is just about as good.
- * 2. Times-9 is (shift-left-3) plus (old). This means that each
- * character's bits hang around in the low-order bits of the
- * hash value for ever, plus they spread fairly rapidly up to
- * the high-order bits to fill out the hash value. This seems
- * works well both for decimal and non-decimal strings.
- */
+ int *array = (int *) keyPtr;
+ register int *iPtr1, *iPtr2;
+ Tcl_HashEntry *hPtr;
+ int count;
+ unsigned int size;
- result = 0;
- while (1) {
- c = *string;
- string++;
- if (c == 0) {
- break;
- }
- result += (result<<3) + c;
+ count = tablePtr->keyType;
+
+ size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key);
+ if (size < sizeof(Tcl_HashEntry))
+ size = sizeof(Tcl_HashEntry);
+ hPtr = (Tcl_HashEntry *) ckalloc(size);
+
+ for (iPtr1 = array, iPtr2 = hPtr->key.words;
+ count > 0; count--, iPtr1++, iPtr2++) {
+ *iPtr2 = *iPtr1;
}
- return result;
+
+ return hPtr;
}
\f
/*
*----------------------------------------------------------------------
*
- * StringFind --
+ * CompareArrayKeys --
*
- * Given a hash table with string keys, and a string key, find
- * the entry with a matching key.
+ * Compares two array keys.
*
* Results:
- * The return value is a token for the matching entry in the
- * hash table, or NULL if there was no matching entry.
+ * The return value is 0 if they are different and 1 if they are
+ * the same.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-static Tcl_HashEntry *
-StringFind(tablePtr, key)
- Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
- CONST char *key; /* Key to use to find matching entry. */
+static int
+CompareArrayKeys(keyPtr, hPtr)
+ VOID *keyPtr; /* New key to compare. */
+ Tcl_HashEntry *hPtr; /* Existing key to compare. */
{
- register Tcl_HashEntry *hPtr;
- register CONST char *p1, *p2;
- int index;
-
- index = HashString(key) & tablePtr->mask;
-
- /*
- * Search all of the entries in the appropriate bucket.
- */
-
- for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
- hPtr = hPtr->nextPtr) {
- for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
- if (*p1 != *p2) {
- break;
- }
- if (*p1 == '\0') {
- return hPtr;
- }
+ register CONST int *iPtr1 = (CONST int *) keyPtr;
+ register CONST int *iPtr2 = (CONST int *) hPtr->key.words;
+ Tcl_HashTable *tablePtr = hPtr->tablePtr;
+ int count;
+
+ for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
+ if (count == 0) {
+ return 1;
}
- }
- return NULL;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * StringCreate --
- *
- * Given a hash table with string keys, and a string key, find
- * the entry with a matching key. If there is no matching entry,
- * then create a new entry that does match.
- *
- * Results:
- * The return value is a pointer to the matching entry. If this
- * is a newly-created entry, then *newPtr will be set to a non-zero
- * value; otherwise *newPtr will be set to 0. If this is a new
- * entry the value stored in the entry will initially be 0.
- *
- * Side effects:
- * A new entry may be added to the hash table.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_HashEntry *
-StringCreate(tablePtr, key, newPtr)
- Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
- CONST char *key; /* Key to use to find or create matching
- * entry. */
- int *newPtr; /* Store info here telling whether a new
- * entry was created. */
-{
- register Tcl_HashEntry *hPtr;
- register CONST char *p1, *p2;
- int index;
-
- index = HashString(key) & tablePtr->mask;
-
- /*
- * Search all of the entries in this bucket.
- */
-
- for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
- hPtr = hPtr->nextPtr) {
- for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) {
- if (*p1 != *p2) {
- break;
- }
- if (*p1 == '\0') {
- *newPtr = 0;
- return hPtr;
- }
+ if (*iPtr1 != *iPtr2) {
+ break;
}
}
-
- /*
- * Entry not found. Add a new one to the bucket.
- */
-
- *newPtr = 1;
- hPtr = (Tcl_HashEntry *) ckalloc((unsigned)
- (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1)));
- hPtr->tablePtr = tablePtr;
- hPtr->bucketPtr = &(tablePtr->buckets[index]);
- hPtr->nextPtr = *hPtr->bucketPtr;
- hPtr->clientData = 0;
- strcpy(hPtr->key.string, key);
- *hPtr->bucketPtr = hPtr;
- tablePtr->numEntries++;
-
- /*
- * If the table has exceeded a decent size, rebuild it with many
- * more buckets.
- */
-
- if (tablePtr->numEntries >= tablePtr->rebuildSize) {
- RebuildTable(tablePtr);
- }
- return hPtr;
+ return 0;
}
\f
/*
*----------------------------------------------------------------------
*
- * OneWordFind --
+ * HashArrayKey --
*
- * Given a hash table with one-word keys, and a one-word key, find
- * the entry with a matching key.
+ * Compute a one-word summary of an array, which can be
+ * used to generate a hash index.
*
* Results:
- * The return value is a token for the matching entry in the
- * hash table, or NULL if there was no matching entry.
+ * The return value is a one-word summary of the information in
+ * string.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-static Tcl_HashEntry *
-OneWordFind(tablePtr, key)
- Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
- register CONST char *key; /* Key to use to find matching entry. */
+static unsigned int
+HashArrayKey(tablePtr, keyPtr)
+ Tcl_HashTable *tablePtr; /* Hash table. */
+ VOID *keyPtr; /* Key from which to compute hash value. */
{
- register Tcl_HashEntry *hPtr;
- int index;
-
- index = RANDOM_INDEX(tablePtr, key);
-
- /*
- * Search all of the entries in the appropriate bucket.
- */
+ register CONST int *array = (CONST int *) keyPtr;
+ register unsigned int result;
+ int count;
- for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
- hPtr = hPtr->nextPtr) {
- if (hPtr->key.oneWordValue == key) {
- return hPtr;
- }
+ for (result = 0, count = tablePtr->keyType; count > 0;
+ count--, array++) {
+ result += *array;
}
- return NULL;
+ return result;
}
\f
/*
*----------------------------------------------------------------------
*
- * OneWordCreate --
+ * AllocStringEntry --
*
- * Given a hash table with one-word keys, and a one-word key, find
- * the entry with a matching key. If there is no matching entry,
- * then create a new entry that does match.
+ * Allocate space for a Tcl_HashEntry containing the string key.
*
* Results:
- * The return value is a pointer to the matching entry. If this
- * is a newly-created entry, then *newPtr will be set to a non-zero
- * value; otherwise *newPtr will be set to 0. If this is a new
- * entry the value stored in the entry will initially be 0.
+ * The return value is a pointer to the created entry.
*
* Side effects:
- * A new entry may be added to the hash table.
+ * None.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
-OneWordCreate(tablePtr, key, newPtr)
- Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
- register CONST char *key; /* Key to use to find or create matching
- * entry. */
- int *newPtr; /* Store info here telling whether a new
- * entry was created. */
+AllocStringEntry(tablePtr, keyPtr)
+ Tcl_HashTable *tablePtr; /* Hash table. */
+ VOID *keyPtr; /* Key to store in the hash table entry. */
{
- register Tcl_HashEntry *hPtr;
- int index;
-
- index = RANDOM_INDEX(tablePtr, key);
-
- /*
- * Search all of the entries in this bucket.
- */
-
- for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
- hPtr = hPtr->nextPtr) {
- if (hPtr->key.oneWordValue == key) {
- *newPtr = 0;
- return hPtr;
- }
- }
-
- /*
- * Entry not found. Add a new one to the bucket.
- */
-
- *newPtr = 1;
- hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry));
- hPtr->tablePtr = tablePtr;
- hPtr->bucketPtr = &(tablePtr->buckets[index]);
- hPtr->nextPtr = *hPtr->bucketPtr;
- hPtr->clientData = 0;
- hPtr->key.oneWordValue = (char *) key; /* CONST XXXX */
- *hPtr->bucketPtr = hPtr;
- tablePtr->numEntries++;
+ CONST char *string = (CONST char *) keyPtr;
+ Tcl_HashEntry *hPtr;
+ unsigned int size;
- /*
- * If the table has exceeded a decent size, rebuild it with many
- * more buckets.
- */
+ size = sizeof(Tcl_HashEntry) + strlen(string) + 1 - sizeof(hPtr->key);
+ if (size < sizeof(Tcl_HashEntry))
+ size = sizeof(Tcl_HashEntry);
+ hPtr = (Tcl_HashEntry *) ckalloc(size);
+ strcpy(hPtr->key.string, string);
- if (tablePtr->numEntries >= tablePtr->rebuildSize) {
- RebuildTable(tablePtr);
- }
return hPtr;
}
\f
/*
*----------------------------------------------------------------------
*
- * ArrayFind --
+ * CompareStringKeys --
*
- * Given a hash table with array-of-int keys, and a key, find
- * the entry with a matching key.
+ * Compares two string keys.
*
* Results:
- * The return value is a token for the matching entry in the
- * hash table, or NULL if there was no matching entry.
+ * The return value is 0 if they are different and 1 if they are
+ * the same.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
-static Tcl_HashEntry *
-ArrayFind(tablePtr, key)
- Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
- CONST char *key; /* Key to use to find matching entry. */
+static int
+CompareStringKeys(keyPtr, hPtr)
+ VOID *keyPtr; /* New key to compare. */
+ Tcl_HashEntry *hPtr; /* Existing key to compare. */
{
- register Tcl_HashEntry *hPtr;
- int *arrayPtr = (int *) key;
- register int *iPtr1, *iPtr2;
- int index, count;
-
- for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
- count > 0; count--, iPtr1++) {
- index += *iPtr1;
- }
- index = RANDOM_INDEX(tablePtr, index);
-
- /*
- * Search all of the entries in the appropriate bucket.
- */
+ register CONST char *p1 = (CONST char *) keyPtr;
+ register CONST char *p2 = (CONST char *) hPtr->key.string;
- for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
- hPtr = hPtr->nextPtr) {
- for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
- count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
- if (count == 0) {
- return hPtr;
- }
- if (*iPtr1 != *iPtr2) {
- break;
- }
+ for (;; p1++, p2++) {
+ if (*p1 != *p2) {
+ break;
+ }
+ if (*p1 == '\0') {
+ return 1;
}
}
- return NULL;
+ return 0;
}
\f
/*
*----------------------------------------------------------------------
*
- * ArrayCreate --
+ * HashStringKey --
*
- * Given a hash table with one-word keys, and a one-word key, find
- * the entry with a matching key. If there is no matching entry,
- * then create a new entry that does match.
+ * Compute a one-word summary of a text string, which can be
+ * used to generate a hash index.
*
* Results:
- * The return value is a pointer to the matching entry. If this
- * is a newly-created entry, then *newPtr will be set to a non-zero
- * value; otherwise *newPtr will be set to 0. If this is a new
- * entry the value stored in the entry will initially be 0.
+ * The return value is a one-word summary of the information in
+ * string.
*
* Side effects:
- * A new entry may be added to the hash table.
+ * None.
*
*----------------------------------------------------------------------
*/
-static Tcl_HashEntry *
-ArrayCreate(tablePtr, key, newPtr)
- Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */
- register CONST char *key; /* Key to use to find or create matching
- * entry. */
- int *newPtr; /* Store info here telling whether a new
- * entry was created. */
+static unsigned int
+HashStringKey(tablePtr, keyPtr)
+ Tcl_HashTable *tablePtr; /* Hash table. */
+ VOID *keyPtr; /* Key from which to compute hash value. */
{
- register Tcl_HashEntry *hPtr;
- int *arrayPtr = (int *) key;
- register int *iPtr1, *iPtr2;
- int index, count;
-
- for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr;
- count > 0; count--, iPtr1++) {
- index += *iPtr1;
- }
- index = RANDOM_INDEX(tablePtr, index);
+ register CONST char *string = (CONST char *) keyPtr;
+ register unsigned int result;
+ register int c;
/*
- * Search all of the entries in the appropriate bucket.
+ * I tried a zillion different hash functions and asked many other
+ * people for advice. Many people had their own favorite functions,
+ * all different, but no-one had much idea why they were good ones.
+ * I chose the one below (multiply by 9 and add new character)
+ * because of the following reasons:
+ *
+ * 1. Multiplying by 10 is perfect for keys that are decimal strings,
+ * and multiplying by 9 is just about as good.
+ * 2. Times-9 is (shift-left-3) plus (old). This means that each
+ * character's bits hang around in the low-order bits of the
+ * hash value for ever, plus they spread fairly rapidly up to
+ * the high-order bits to fill out the hash value. This seems
+ * works well both for decimal and non-decimal strings.
*/
- for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
- hPtr = hPtr->nextPtr) {
- for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words,
- count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
- if (count == 0) {
- *newPtr = 0;
- return hPtr;
- }
- if (*iPtr1 != *iPtr2) {
- break;
- }
+ result = 0;
+ while (1) {
+ c = *string;
+ string++;
+ if (c == 0) {
+ break;
}
+ result += (result<<3) + c;
}
-
- /*
- * Entry not found. Add a new one to the bucket.
- */
-
- *newPtr = 1;
- hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)
- + (tablePtr->keyType*sizeof(int)) - 4));
- hPtr->tablePtr = tablePtr;
- hPtr->bucketPtr = &(tablePtr->buckets[index]);
- hPtr->nextPtr = *hPtr->bucketPtr;
- hPtr->clientData = 0;
- for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType;
- count > 0; count--, iPtr1++, iPtr2++) {
- *iPtr2 = *iPtr1;
- }
- *hPtr->bucketPtr = hPtr;
- tablePtr->numEntries++;
-
- /*
- * If the table has exceeded a decent size, rebuild it with many
- * more buckets.
- */
-
- if (tablePtr->numEntries >= tablePtr->rebuildSize) {
- RebuildTable(tablePtr);
- }
- return hPtr;
+ return result;
}
\f
+#if TCL_PRESERVE_BINARY_COMPATABILITY
/*
*----------------------------------------------------------------------
*
panic("called Tcl_CreateHashEntry on deleted table");
return NULL;
}
+#endif
\f
/*
*----------------------------------------------------------------------
Tcl_HashEntry **oldBuckets;
register Tcl_HashEntry **oldChainPtr, **newChainPtr;
register Tcl_HashEntry *hPtr;
+ Tcl_HashKeyType *typePtr;
+ VOID *key;
oldSize = tablePtr->numBuckets;
oldBuckets = tablePtr->buckets;
tablePtr->downShift -= 2;
tablePtr->mask = (tablePtr->mask << 2) + 3;
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+ if (tablePtr->keyType == TCL_STRING_KEYS) {
+ typePtr = &tclStringHashKeyType;
+ } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+ typePtr = &tclOneWordHashKeyType;
+ } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+ || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+ typePtr = tablePtr->typePtr;
+ } else {
+ typePtr = &tclArrayHashKeyType;
+ }
+#else
+ typePtr = tablePtr->typePtr;
+#endif
+
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
*oldChainPtr = hPtr->nextPtr;
- if (tablePtr->keyType == TCL_STRING_KEYS) {
- index = HashString(hPtr->key.string) & tablePtr->mask;
- } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
- index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue);
- } else {
- register int *iPtr;
- int count;
- for (index = 0, count = tablePtr->keyType,
- iPtr = hPtr->key.words; count > 0; count--, iPtr++) {
- index += *iPtr;
+ key = (VOID *) Tcl_GetHashKey (tablePtr, hPtr);
+
+#if TCL_HASH_KEY_STORE_HASH
+ if (typePtr->hashKeyProc == NULL
+ || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
+ index = RANDOM_INDEX (tablePtr, hPtr->hash);
+ } else {
+ index = ((unsigned int) hPtr->hash) & tablePtr->mask;
+ }
+ hPtr->nextPtr = tablePtr->buckets[index];
+ tablePtr->buckets[index] = hPtr;
+#else
+ if (typePtr->hashKeyProc) {
+ unsigned int hash;
+ hash = typePtr->hashKeyProc (tablePtr, (VOID *) key);
+ if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
+ index = RANDOM_INDEX (tablePtr, hash);
+ } else {
+ index = hash & tablePtr->mask;
}
- index = RANDOM_INDEX(tablePtr, index);
+ } else {
+ index = RANDOM_INDEX (tablePtr, key);
}
+
hPtr->bucketPtr = &(tablePtr->buckets[index]);
hPtr->nextPtr = *hPtr->bucketPtr;
*hPtr->bucketPtr = hPtr;
+#endif
}
}
Tcl_RecordAndEval(interp, cmd, flags)
Tcl_Interp *interp; /* Token for interpreter in which command
* will be executed. */
- char *cmd; /* Command to record. */
+ CONST char *cmd; /* Command to record. */
int flags; /* Additional flags. TCL_NO_EVAL means
* only record: don't execute command.
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
ChannelState *statePtr, char *result,
int space));
static int CopyBuffer _ANSI_ARGS_((
- Channel *chanPtr, char *result,
- int space));
+ Channel *chanPtr, char *result, int space));
static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask));
static void CopyEventProc _ANSI_ARGS_((ClientData clientData,
int mask));
ClientData clientData, Tcl_Interp *interp));
static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int mask));
+static int DetachChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan));
static void DiscardInputQueued _ANSI_ARGS_((ChannelState *statePtr,
int discardSavedBuffers));
static void DiscardOutputQueued _ANSI_ARGS_((
ChannelState *chanPtr));
static int DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr,
int slen));
-static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *src,
+static int DoWrite _ANSI_ARGS_((Channel *chanPtr, CONST char *src,
int srcLen));
+static int DoReadChars _ANSI_ARGS_ ((Channel* chan,
+ Tcl_Obj* objPtr, int toRead, int appendFlag));
+static int DoWriteChars _ANSI_ARGS_ ((Channel* chan,
+ CONST char* src, int len));
static int FilterInputBytes _ANSI_ARGS_((Channel *chanPtr,
GetsState *statePtr));
static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int calledFromAsyncFlush));
static Tcl_HashTable * GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp));
static int GetInput _ANSI_ARGS_((Channel *chanPtr));
+static int HaveVersion _ANSI_ARGS_((Tcl_ChannelType *typePtr,
+ Tcl_ChannelTypeVersion minimumVersion));
static void PeekAhead _ANSI_ARGS_((Channel *chanPtr,
char **dstEndPtr, GetsState *gsPtr));
static int ReadBytes _ANSI_ARGS_((ChannelState *statePtr,
Tcl_Obj *objPtr, int charsLeft,
int *offsetPtr));
static int ReadChars _ANSI_ARGS_((ChannelState *statePtr,
- Tcl_Obj *objPtr, int charsLeft, int *offsetPtr,
- int *factorPtr));
+ Tcl_Obj *objPtr, int charsLeft,
+ int *offsetPtr, int *factorPtr));
static void RecycleBuffer _ANSI_ARGS_((ChannelState *statePtr,
ChannelBuffer *bufPtr, int mustDiscard));
static int StackSetBlockMode _ANSI_ARGS_((Channel *chanPtr,
Channel *chanPtr, int mode));
static void StopCopy _ANSI_ARGS_((CopyState *csPtr));
static int TranslateInputEOL _ANSI_ARGS_((ChannelState *statePtr,
- char *dst, CONST char *src, int *dstLenPtr,
- int *srcLenPtr));
+ char *dst, CONST char *src,
+ int *dstLenPtr, int *srcLenPtr));
static int TranslateOutputEOL _ANSI_ARGS_((ChannelState *statePtr,
- char *dst, CONST char *src, int *dstLenPtr,
- int *srcLenPtr));
+ char *dst, CONST char *src,
+ int *dstLenPtr, int *srcLenPtr));
static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr));
static int WriteBytes _ANSI_ARGS_((Channel *chanPtr,
CONST char *src, int srcLen));
/*
*----------------------------------------------------------------------
*
+ * Tcl_IsStandardChannel --
+ *
+ * Test if the given channel is a standard channel. No attempt
+ * is made to check if the channel or the standard channels
+ * are initialized or otherwise valid.
+ *
+ * Results:
+ * Returns 1 if true, 0 if false.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_IsStandardChannel(chan)
+ Tcl_Channel chan; /* Channel to check. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if ((chan == tsdPtr->stdinChannel)
+ || (chan == tsdPtr->stdoutChannel)
+ || (chan == tsdPtr->stderrChannel)) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_RegisterChannel --
*
* Adds an already-open channel to the channel table of an interpreter.
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
- if (statePtr->channelName == (char *) NULL) {
+ if (statePtr->channelName == (CONST char *) NULL) {
panic("Tcl_RegisterChannel: channel without name");
}
if (interp != (Tcl_Interp *) NULL) {
*
* Deletes the hash entry for a channel associated with an interpreter.
* If the interpreter given as argument is NULL, it only decrements the
- * reference count.
+ * reference count. (This all happens in the Tcl_DetachChannel helper
+ * function).
+ *
+ * Finally, if the reference count of the channel drops to zero,
+ * it is deleted.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Deletes the hash entry for a channel associated with an interpreter.
+ * Calls Tcl_DetachChannel which deletes the hash entry for a channel
+ * associated with an interpreter.
+ *
+ * May delete the channel, which can have a variety of consequences,
+ * especially if we are forced to close the channel.
*
*----------------------------------------------------------------------
*/
Tcl_Interp *interp; /* Interpreter in which channel is defined. */
Tcl_Channel chan; /* Channel to delete. */
{
- Tcl_HashTable *hTblPtr; /* Hash table of channels. */
- Tcl_HashEntry *hPtr; /* Search variable. */
- Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of the real channel. */
- /*
- * Always (un)register bottom-most channel in the stack. This makes
- * management of the channel list easier because no manipulation is
- * necessary during (un)stack operation.
- */
- chanPtr = ((Channel *) chan)->state->bottomChanPtr;
- statePtr = chanPtr->state;
-
- if (interp != (Tcl_Interp *) NULL) {
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- return TCL_OK;
- }
- hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- return TCL_OK;
- }
- if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
- return TCL_OK;
- }
- Tcl_DeleteHashEntry(hPtr);
-
- /*
- * Remove channel handlers that refer to this interpreter, so that they
- * will not be present if the actual close is delayed and more events
- * happen on the channel. This may occur if the channel is shared
- * between several interpreters, or if the channel has async
- * flushing active.
- */
-
- CleanupChannelHandlers(interp, chanPtr);
+ if (DetachChannel(interp, chan) != TCL_OK) {
+ return TCL_OK;
}
-
- statePtr->refCount--;
+ statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
+
/*
* Perform special handling for standard channels being closed. If the
* refCount is now 1 it means that the last reference to the standard
statePtr->curOutPtr->nextRemoved)) {
statePtr->flags |= BUFFER_READY;
}
- statePtr->flags |= CHANNEL_CLOSED;
+ Tcl_Preserve((ClientData)statePtr);
if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) {
- if (Tcl_Close(interp, chan) != TCL_OK) {
- return TCL_ERROR;
- }
+ /* We don't want to re-enter Tcl_Close */
+ if (!(statePtr->flags & CHANNEL_CLOSED)) {
+ if (Tcl_Close(interp, chan) != TCL_OK) {
+ statePtr->flags |= CHANNEL_CLOSED;
+ Tcl_Release((ClientData)statePtr);
+ return TCL_ERROR;
+ }
+ }
}
+ statePtr->flags |= CHANNEL_CLOSED;
+ Tcl_Release((ClientData)statePtr);
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DetachChannel --
+ *
+ * Deletes the hash entry for a channel associated with an interpreter.
+ * If the interpreter given as argument is NULL, it only decrements the
+ * reference count. Even if the ref count drops to zero, the
+ * channel is NOT closed or cleaned up. This allows a channel to
+ * be detached from an interpreter and left in the same state it
+ * was in when it was originally returned by 'Tcl_OpenFileChannel',
+ * for example.
+ *
+ * This function cannot be used on the standard channels, and
+ * will return TCL_ERROR if that is attempted.
+ *
+ * This function should only be necessary for special purposes
+ * in which you need to generate a pristine channel from one
+ * that has already been used. All ordinary purposes will almost
+ * always want to use Tcl_UnregisterChannel instead.
+ *
+ * Provided the channel is not attached to any other interpreter,
+ * it can then be closed with Tcl_Close, rather than with
+ * Tcl_UnregisterChannel.
+ *
+ * Results:
+ * A standard Tcl result. If the channel is not currently registered
+ * with the given interpreter, TCL_ERROR is returned, otherwise
+ * TCL_OK. However no error messages are left in the interp's result.
+ *
+ * Side effects:
+ * Deletes the hash entry for a channel associated with an
+ * interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DetachChannel(interp, chan)
+ Tcl_Interp *interp; /* Interpreter in which channel is defined. */
+ Tcl_Channel chan; /* Channel to delete. */
+{
+ if (Tcl_IsStandardChannel(chan)) {
+ return TCL_ERROR;
+ }
+
+ return DetachChannel(interp, chan);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DetachChannel --
+ *
+ * Deletes the hash entry for a channel associated with an interpreter.
+ * If the interpreter given as argument is NULL, it only decrements the
+ * reference count. Even if the ref count drops to zero, the
+ * channel is NOT closed or cleaned up. This allows a channel to
+ * be detached from an interpreter and left in the same state it
+ * was in when it was originally returned by 'Tcl_OpenFileChannel',
+ * for example.
+ *
+ * Results:
+ * A standard Tcl result. If the channel is not currently registered
+ * with the given interpreter, TCL_ERROR is returned, otherwise
+ * TCL_OK. However no error messages are left in the interp's result.
+ *
+ * Side effects:
+ * Deletes the hash entry for a channel associated with an
+ * interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DetachChannel(interp, chan)
+ Tcl_Interp *interp; /* Interpreter in which channel is defined. */
+ Tcl_Channel chan; /* Channel to delete. */
+{
+ Tcl_HashTable *hTblPtr; /* Hash table of channels. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Channel *chanPtr; /* The real IO channel. */
+ ChannelState *statePtr; /* State of the real channel. */
+
+ /*
+ * Always (un)register bottom-most channel in the stack. This makes
+ * management of the channel list easier because no manipulation is
+ * necessary during (un)stack operation.
+ */
+ chanPtr = ((Channel *) chan)->state->bottomChanPtr;
+ statePtr = chanPtr->state;
+
+ if (interp != (Tcl_Interp *) NULL) {
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ return TCL_ERROR;
+ }
+ hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
+ if (hPtr == (Tcl_HashEntry *) NULL) {
+ return TCL_ERROR;
+ }
+ if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
+ return TCL_ERROR;
+ }
+ Tcl_DeleteHashEntry(hPtr);
+
+ /*
+ * Remove channel handlers that refer to this interpreter, so that they
+ * will not be present if the actual close is delayed and more events
+ * happen on the channel. This may occur if the channel is shared
+ * between several interpreters, or if the channel has async
+ * flushing active.
+ */
+
+ CleanupChannelHandlers(interp, chanPtr);
}
+
+ statePtr->refCount--;
+
return TCL_OK;
}
+
\f
/*
*---------------------------------------------------------------------------
Tcl_GetChannel(interp, chanName, modePtr)
Tcl_Interp *interp; /* Interpreter in which to find or create
* the channel. */
- char *chanName; /* The name of the channel. */
+ CONST char *chanName; /* The name of the channel. */
int *modePtr; /* Where to store the mode in which the
* channel was opened? Will contain an ORed
* combination of TCL_READABLE and
Channel *chanPtr; /* The actual channel. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashEntry *hPtr; /* Search variable. */
- char *name; /* Translated name. */
+ CONST char *name; /* Translated name. */
/*
* Substitute "stdin", etc. Note that even though we immediately
Tcl_Channel
Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
Tcl_ChannelType *typePtr; /* The channel type record. */
- char *chanName; /* Name of channel to record. */
+ CONST char *chanName; /* Name of channel to record. */
ClientData instanceData; /* Instance specific data. */
int mask; /* TCL_READABLE & TCL_WRITABLE to indicate
* if the channel is readable, writable. */
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*));
+ /*
+ * JH: We could subsequently memset these to 0 to avoid the
+ * numerous assignments to 0/NULL below.
+ */
chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));
statePtr = (ChannelState *) ckalloc((unsigned) sizeof(ChannelState));
chanPtr->state = statePtr;
*/
if (chanName != (char *) NULL) {
- statePtr->channelName = ckalloc((unsigned) (strlen(chanName) + 1));
- strcpy(statePtr->channelName, chanName);
+ char *tmp = ckalloc((unsigned) (strlen(chanName) + 1));
+ statePtr->channelName = tmp;
+ strcpy(tmp, chanName);
} else {
panic("Tcl_CreateChannel: NULL channel name");
}
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels
* in the list on exit.
+ *
+ * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.
*/
- statePtr->nextCSPtr = tsdPtr->firstCSPtr;
- tsdPtr->firstCSPtr = statePtr;
+ statePtr->nextCSPtr = tsdPtr->firstCSPtr;
+ tsdPtr->firstCSPtr = statePtr;
+
+ /*
+ * TIP #10. Mark the current thread as the one managing the new
+ * channel. Note: 'Tcl_GetCurrentThread' returns sensible
+ * values even for a non-threaded core.
+ */
+
+ statePtr->managingThread = Tcl_GetCurrentThread ();
/*
* Install this channel in the first empty standard channel slot, if
/*
*----------------------------------------------------------------------
*
+ * Tcl_GetChannelThread --
+ *
+ * Given a channel structure, returns the thread managing it.
+ * TIP #10
+ *
+ * Results:
+ * Returns the id of the thread managing the channel.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_ThreadId
+Tcl_GetChannelThread(chan)
+ Tcl_Channel chan; /* The channel to return managing thread for. */
+{
+ Channel *chanPtr = (Channel *) chan; /* The actual channel. */
+
+ return chanPtr->state->managingThread;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetChannelType --
*
* Given a channel structure, returns the channel type structure.
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetChannelName(chan)
Tcl_Channel chan; /* The channel for which to return the name. */
{
}
/*
+ * Only save buffers which are at least as big as the requested
+ * buffersize for the channel. This is to honor dynamic changes
+ * of the buffersize made by the user.
+ */
+
+ if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
+ ckfree((char *) bufPtr);
+ return;
+ }
+
+ /*
* Only save buffers for the input queue if the channel is readable.
*/
toWrite = bufPtr->nextAdded - bufPtr->nextRemoved;
written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
- (char *) bufPtr->buf + bufPtr->nextRemoved, toWrite,
+ bufPtr->buf + bufPtr->nextRemoved, toWrite,
&errorCode);
/*
} else {
Tcl_SetErrno(errorCode);
if (interp != NULL) {
+
+ /*
+ * Casting away CONST here is safe because the
+ * TCL_VOLATILE flag guarantees CONST treatment
+ * of the Posix error string.
+ */
+
Tcl_SetResult(interp,
- Tcl_PosixError(interp), TCL_VOLATILE);
+ (char *) Tcl_PosixError(interp), TCL_VOLATILE);
}
}
{
int result = 0; /* Of calling driver close
* operation. */
- ChannelState *prevCSPtr; /* Preceding channel state in list of
- * all states - used to splice a
- * channel out of the list on close. */
ChannelState *statePtr; /* state of the channel stack. */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
c = (char) statePtr->outEofChar;
(chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy);
}
-#if 0
- /*
- * Remove TCL_READABLE and TCL_WRITABLE from statePtr->flags, so
- * that close callbacks can not do input or output (assuming they
- * squirreled the channel away in their clientData). This also
- * prevents infinite loops if the callback calls any C API that
- * could call FlushChannel.
- */
-
- /*
- * This prevents any data from being flushed from stacked channels.
- */
- statePtr->flags &= (~(TCL_READABLE|TCL_WRITABLE));
-#endif
/*
- * Splice this channel out of the list of all channels.
+ * Remove this channel from of the list of all channels.
*/
-
- if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
- tsdPtr->firstCSPtr = statePtr->nextCSPtr;
- } else {
- for (prevCSPtr = tsdPtr->firstCSPtr;
- prevCSPtr && (prevCSPtr->nextCSPtr != statePtr);
- prevCSPtr = prevCSPtr->nextCSPtr) {
- /* Empty loop body. */
- }
- if (prevCSPtr == (ChannelState *) NULL) {
- panic("FlushChannel: damaged channel list");
- }
- prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
- }
+ Tcl_CutChannel((Tcl_Channel) chanPtr);
/*
* Close and free the channel driver state.
if (chanPtr == statePtr->bottomChanPtr) {
if (statePtr->channelName != (char *) NULL) {
- ckfree(statePtr->channelName);
+ ckfree((char *) statePtr->channelName);
statePtr->channelName = NULL;
}
*/
if (chanPtr->downChanPtr != (Channel *) NULL) {
-#if 0
- int code = TCL_OK;
-
- while (chanPtr->downChanPtr != (Channel *) NULL) {
- /*
- * Unwind the state of the transformation, and then restore the
- * state of (unstack) the underlying channel into the TOP channel
- * structure.
- */
- code = Tcl_UnstackChannel(interp, (Tcl_Channel) chanPtr);
- if (code == TCL_ERROR) {
- errorCode = Tcl_GetErrno();
- break;
- }
- chanPtr = chanPtr->downChanPtr;
- }
-#else
Channel *downChanPtr = chanPtr->downChanPtr;
statePtr->nextCSPtr = tsdPtr->firstCSPtr;
Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
return Tcl_Close(interp, (Tcl_Channel) downChanPtr);
-#endif
}
/*
* There is only the TOP Channel, so we free the remaining
- * pointers we have and then ourselves.
+ * pointers we have and then ourselves. Since this is the
+ * last of the channels in the stack, make sure to free the
+ * ChannelState structure associated with it. We use
+ * Tcl_EventuallyFree to allow for any last
*/
chanPtr->typePtr = NULL;
+ Tcl_EventuallyFree((ClientData) statePtr, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC);
return errorCode;
/*
*----------------------------------------------------------------------
*
- * Tcl_Close --
+ * Tcl_CutChannel --
*
- * Closes a channel.
+ * Removes a channel from the (thread-)global list of all channels
+ * (in that thread). This is actually the statePtr for the stack
+ * of channel.
*
* Results:
- * A standard Tcl result.
+ * Nothing.
*
* Side effects:
- * Closes the channel if this is the last reference.
+ * Resets the field 'nextCSPtr' of the specified channel state to NULL.
*
* NOTE:
- * Tcl_Close removes the channel as far as the user is concerned.
- * However, it may continue to exist for a while longer if it has
- * a background flush scheduled. The device itself is eventually
- * closed and the channel record removed, in CloseChannel, above.
+ * The channel to splice out of the list must not be referenced
+ * in any interpreter. This is something this procedure cannot
+ * check (despite the refcount) because the caller usually wants
+ * fiddle with the channel (like transfering it to a different
+ * thread) and thus keeps the refcount artifically high to prevent
+ * its destruction.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
-int
-Tcl_Close(interp, chan)
- Tcl_Interp *interp; /* Interpreter for errors. */
- Tcl_Channel chan; /* The channel being closed. Must
+void
+Tcl_CutChannel(chan)
+ Tcl_Channel chan; /* The channel being removed. Must
* not be referenced in any
* interpreter. */
{
- ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */
- CloseCallback *cbPtr; /* Iterate over close callbacks
- * for this channel. */
- EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */
- Channel *chanPtr; /* The real IO channel. */
- ChannelState *statePtr; /* State of real IO channel. */
- int result; /* Of calling FlushChannel. */
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- NextChannelHandler *nhPtr;
-
- if (chan == (Tcl_Channel) NULL) {
- return TCL_OK;
- }
+ ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
+ ChannelState *prevCSPtr; /* Preceding channel state in list of
+ * all states - used to splice a
+ * channel out of the list on close. */
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* state of the channel stack. */
/*
- * Perform special handling for standard channels being closed. If the
- * refCount is now 1 it means that the last reference to the standard
- * channel is being explicitly closed, so bump the refCount down
- * artificially to 0. This will ensure that the channel is actually
- * closed, below. Also set the static pointer to NULL for the channel.
+ * Remove this channel from of the list of all channels
+ * (in the current thread).
*/
- CheckForStdChannelsBeingClosed(chan);
-
- /*
- * This operation should occur at the top of a channel stack.
- */
+ if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
+ tsdPtr->firstCSPtr = statePtr->nextCSPtr;
+ } else {
+ for (prevCSPtr = tsdPtr->firstCSPtr;
+ prevCSPtr && (prevCSPtr->nextCSPtr != statePtr);
+ prevCSPtr = prevCSPtr->nextCSPtr) {
+ /* Empty loop body. */
+ }
+ if (prevCSPtr == (ChannelState *) NULL) {
+ panic("FlushChannel: damaged channel list");
+ }
+ prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
+ }
- chanPtr = (Channel *) chan;
- statePtr = chanPtr->state;
- chanPtr = statePtr->topChanPtr;
+ statePtr->nextCSPtr = (ChannelState *) NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SpliceChannel --
+ *
+ * Adds a channel to the (thread-)global list of all channels
+ * (in that thread). Expects that the field 'nextChanPtr' in
+ * the channel is set to NULL.
+ *
+ * Results:
+ * Nothing.
+ *
+ * Side effects:
+ * Nothing.
+ *
+ * NOTE:
+ * The channel to add to the list must not be referenced in any
+ * interpreter. This is something this procedure cannot check
+ * (despite the refcount) because the caller usually wants figgle
+ * with the channel (like transfering it to a different thread)
+ * and thus keeps the refcount artifically high to prevent its
+ * destruction.
+ *
+ *----------------------------------------------------------------------
+ */
- if (statePtr->refCount > 0) {
- panic("called Tcl_Close on channel with refCount > 0");
+void
+Tcl_SpliceChannel(chan)
+ Tcl_Channel chan; /* The channel being added. Must
+ * not be referenced in any
+ * interpreter. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ChannelState *statePtr = ((Channel *) chan)->state;
+
+ if (statePtr->nextCSPtr != (ChannelState *) NULL) {
+ panic("Tcl_SpliceChannel: trying to add channel used in different list");
}
+ statePtr->nextCSPtr = tsdPtr->firstCSPtr;
+ tsdPtr->firstCSPtr = statePtr;
+
/*
- * Remove any references to channel handlers for this channel that
- * may be about to be invoked.
+ * TIP #10. Mark the current thread as the new one managing this
+ * channel. Note: 'Tcl_GetCurrentThread' returns sensible
+ * values even for a non-threaded core.
*/
- for (nhPtr = tsdPtr->nestedHandlerPtr;
- nhPtr != (NextChannelHandler *) NULL;
- nhPtr = nhPtr->nestedHandlerPtr) {
- if (nhPtr->nextHandlerPtr &&
- (nhPtr->nextHandlerPtr->chanPtr == chanPtr)) {
- nhPtr->nextHandlerPtr = NULL;
- }
- }
+ statePtr->managingThread = Tcl_GetCurrentThread ();
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Close --
+ *
+ * Closes a channel.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Closes the channel if this is the last reference.
+ *
+ * NOTE:
+ * Tcl_Close removes the channel as far as the user is concerned.
+ * However, it may continue to exist for a while longer if it has
+ * a background flush scheduled. The device itself is eventually
+ * closed and the channel record removed, in CloseChannel, above.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * Remove all the channel handler records attached to the channel
- * itself.
- */
+ /* ARGSUSED */
+int
+Tcl_Close(interp, chan)
+ Tcl_Interp *interp; /* Interpreter for errors. */
+ Tcl_Channel chan; /* The channel being closed. Must
+ * not be referenced in any
+ * interpreter. */
+{
+ CloseCallback *cbPtr; /* Iterate over close callbacks
+ * for this channel. */
+ Channel *chanPtr; /* The real IO channel. */
+ ChannelState *statePtr; /* State of real IO channel. */
+ int result; /* Of calling FlushChannel. */
- for (chPtr = statePtr->chPtr;
- chPtr != (ChannelHandler *) NULL;
- chPtr = chNext) {
- chNext = chPtr->nextPtr;
- ckfree((char *) chPtr);
+ if (chan == (Tcl_Channel) NULL) {
+ return TCL_OK;
}
- statePtr->chPtr = (ChannelHandler *) NULL;
/*
- * Cancel any pending copy operation.
+ * Perform special handling for standard channels being closed. If the
+ * refCount is now 1 it means that the last reference to the standard
+ * channel is being explicitly closed, so bump the refCount down
+ * artificially to 0. This will ensure that the channel is actually
+ * closed, below. Also set the static pointer to NULL for the channel.
*/
- StopCopy(statePtr->csPtr);
+ CheckForStdChannelsBeingClosed(chan);
/*
- * Must set the interest mask now to 0, otherwise infinite loops
- * will occur if Tcl_DoOneEvent is called before the channel is
- * finally deleted in FlushChannel. This can happen if the channel
- * has a background flush active.
+ * This operation should occur at the top of a channel stack.
*/
-
- statePtr->interestMask = 0;
-
+
+ chanPtr = (Channel *) chan;
+ statePtr = chanPtr->state;
+ chanPtr = statePtr->topChanPtr;
+
+ if (statePtr->refCount > 0) {
+ panic("called Tcl_Close on channel with refCount > 0");
+ }
+
/*
- * Remove any EventScript records for this channel.
+ * When the channel has an escape sequence driven encoding such as
+ * iso2022, the terminated escape sequence must write to the buffer.
*/
-
- for (ePtr = statePtr->scriptRecordPtr;
- ePtr != (EventScriptRecord *) NULL;
- ePtr = eNextPtr) {
- eNextPtr = ePtr->nextPtr;
- Tcl_DecrRefCount(ePtr->scriptPtr);
- ckfree((char *) ePtr);
+ if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
+ && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
+ statePtr->outputEncodingFlags |= TCL_ENCODING_END;
+ WriteChars(chanPtr, "", 0);
}
- statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
-
+
+ Tcl_ClearChannelHandlers(chan);
+
/*
* Invoke the registered close callbacks and delete their records.
*/
/*
*----------------------------------------------------------------------
*
+ * Tcl_ClearChannelHandlers --
+ *
+ * Removes all channel handlers and event scripts from the channel,
+ * cancels all background copies involving the channel and any interest
+ * in events.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * See above. Deallocates memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ClearChannelHandlers (channel)
+ Tcl_Channel channel;
+{
+ ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */
+ EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */
+ Channel *chanPtr; /* The real IO channel. */
+ ChannelState *statePtr; /* State of real IO channel. */
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ NextChannelHandler *nhPtr;
+
+ /*
+ * This operation should occur at the top of a channel stack.
+ */
+
+ chanPtr = (Channel *) channel;
+ statePtr = chanPtr->state;
+ chanPtr = statePtr->topChanPtr;
+
+ /*
+ * Remove any references to channel handlers for this channel that
+ * may be about to be invoked.
+ */
+
+ for (nhPtr = tsdPtr->nestedHandlerPtr;
+ nhPtr != (NextChannelHandler *) NULL;
+ nhPtr = nhPtr->nestedHandlerPtr) {
+ if (nhPtr->nextHandlerPtr &&
+ (nhPtr->nextHandlerPtr->chanPtr == chanPtr)) {
+ nhPtr->nextHandlerPtr = NULL;
+ }
+ }
+
+ /*
+ * Remove all the channel handler records attached to the channel
+ * itself.
+ */
+
+ for (chPtr = statePtr->chPtr;
+ chPtr != (ChannelHandler *) NULL;
+ chPtr = chNext) {
+ chNext = chPtr->nextPtr;
+ ckfree((char *) chPtr);
+ }
+ statePtr->chPtr = (ChannelHandler *) NULL;
+
+ /*
+ * Cancel any pending copy operation.
+ */
+
+ StopCopy(statePtr->csPtr);
+
+ /*
+ * Must set the interest mask now to 0, otherwise infinite loops
+ * will occur if Tcl_DoOneEvent is called before the channel is
+ * finally deleted in FlushChannel. This can happen if the channel
+ * has a background flush active.
+ */
+
+ statePtr->interestMask = 0;
+
+ /*
+ * Remove any EventScript records for this channel.
+ */
+
+ for (ePtr = statePtr->scriptRecordPtr;
+ ePtr != (EventScriptRecord *) NULL;
+ ePtr = eNextPtr) {
+ eNextPtr = ePtr->nextPtr;
+ Tcl_DecrRefCount(ePtr->scriptPtr);
+ ckfree((char *) ePtr);
+ }
+ statePtr->scriptRecordPtr = (EventScriptRecord *) NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_Write --
*
* Puts a sequence of bytes into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
- * line buffering mode.
+ * line buffering mode. Compensates stacking, i.e. will redirect the
+ * data from the specified channel to the topmost channel in a stack.
+ *
+ * No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
int
Tcl_Write(chan, src, srcLen)
Tcl_Channel chan; /* The channel to buffer output for. */
- char *src; /* Data to queue in output buffer. */
+ CONST char *src; /* Data to queue in output buffer. */
int srcLen; /* Length of data in bytes, or < 0 for
* strlen(). */
{
* Puts a sequence of bytes into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
- * line buffering mode.
+ * line buffering mode. Writes directly to the driver of the channel,
+ * does not compensate for stacking.
+ *
+ * No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
int
Tcl_WriteRaw(chan, src, srcLen)
Tcl_Channel chan; /* The channel to buffer output for. */
- char *src; /* Data to queue in output buffer. */
+ CONST char *src; /* Data to queue in output buffer. */
int srcLen; /* Length of data in bytes, or < 0 for
* strlen(). */
{
* using the channel's current encoding, may queue the buffer for
* output if it gets full, and also remembers whether the current
* buffer is ready e.g. if it contains a newline and we are in
- * line buffering mode.
+ * line buffering mode. Compensates stacking, i.e. will redirect the
+ * data from the specified channel to the topmost channel in a stack.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
int len; /* Length of string in bytes, or < 0 for
* strlen(). */
{
- /*
- * Always use the topmost channel of the stack
- */
- Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
statePtr = ((Channel *) chan)->state;
- chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
+
+ return DoWriteChars ((Channel*) chan, src, len);
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * DoWriteChars --
+ *
+ * Takes a sequence of UTF-8 characters and converts them for output
+ * using the channel's current encoding, may queue the buffer for
+ * output if it gets full, and also remembers whether the current
+ * buffer is ready e.g. if it contains a newline and we are in
+ * line buffering mode. Compensates stacking, i.e. will redirect the
+ * data from the specified channel to the topmost channel in a stack.
+ *
+ * Results:
+ * The number of bytes written or -1 in case of error. If -1,
+ * Tcl_GetErrno will return the error code.
+ *
+ * Side effects:
+ * May buffer up output and may cause output to be produced on the
+ * channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DoWriteChars(chanPtr, src, len)
+ Channel* chanPtr; /* The channel to buffer output for. */
+ CONST char *src; /* UTF-8 characters to queue in output buffer. */
+ int len; /* Length of string in bytes, or < 0 for
+ * strlen(). */
+{
+ /*
+ * Always use the topmost channel of the stack
+ */
+ ChannelState *statePtr; /* state info for channel */
+
+ statePtr = chanPtr->state;
+ chanPtr = statePtr->topChanPtr;
+
if (len < 0) {
len = strlen(src);
}
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
char *dst;
- int dstLen, dstMax, sawLF, savedLF, total, toWrite;
+ int dstMax, sawLF, savedLF, total, dstLen, toWrite;
total = 0;
sawLF = 0;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
char *dst, *stage;
- int saved, savedLF, sawLF, total, toWrite, flags;
- int dstWrote, dstLen, stageLen, stageMax, stageRead;
+ int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
+ int stageLen, toWrite, stageRead, endEncoding, result;
+ int consumedSomething;
Tcl_Encoding encoding;
char safe[BUFFER_PADDING];
encoding = statePtr->encoding;
/*
+ * Write the terminated escape sequence even if srcLen is 0.
+ */
+
+ endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
+
+ /*
* Loop over all UTF-8 characters in src, storing them in staging buffer
* with proper EOL translation.
*/
- while (srcLen + savedLF > 0) {
+ consumedSomething = 1;
+ while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
+ consumedSomething = 0;
stage = statePtr->outputStage;
stageMax = statePtr->bufSize;
stageLen = stageMax;
src += toWrite;
srcLen -= toWrite;
- flags = statePtr->outputEncodingFlags;
- if (srcLen == 0) {
- flags |= TCL_ENCODING_END;
- }
-
/*
* Loop over all UTF-8 characters in staging buffer, converting them
* to external encoding, storing them in output buffer.
*/
- while (stageLen + saved > 0) {
+ while (stageLen + saved + endEncoding > 0) {
bufPtr = statePtr->curOutPtr;
if (bufPtr == NULL) {
bufPtr = AllocChannelBuffer(statePtr->bufSize);
saved = 0;
}
- Tcl_UtfToExternal(NULL, encoding, stage, stageLen, flags,
+ result = Tcl_UtfToExternal(NULL, encoding, stage, stageLen,
+ statePtr->outputEncodingFlags,
&statePtr->outputEncodingState, dst,
dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL);
- if (stageRead + dstWrote == 0) {
+
+ /* Fix for SF #506297, reported by Martin Forssen
+ * <ruric@users.sourceforge.net>.
+ *
+ * The encoding chosen in the script exposing the bug writes out
+ * three intro characters when TCL_ENCODING_START is set, but does
+ * not consume any input as TCL_ENCODING_END is cleared. As some
+ * output was generated the enclosing loop calls UtfToExternal
+ * again, again with START set. Three more characters in the out
+ * and still no use of input ... To break this infinite loop we
+ * remove TCL_ENCODING_START from the set of flags after the first
+ * call (no condition is required, the later calls remove an unset
+ * flag, which is a no-op). This causes the subsequent calls to
+ * UtfToExternal to consume and convert the actual input.
+ */
+
+ statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
+ /*
+ * The following code must be executed only when result is not 0.
+ */
+ if (result && ((stageRead + dstWrote) == 0)) {
/*
* We have an incomplete UTF-8 character at the end of the
* staging buffer. It will get moved to the beginning of the
stage += stageRead;
stageLen -= stageRead;
sawLF = 0;
+
+ consumedSomething = 1;
+
+ /*
+ * If all translated characters are written to the buffer,
+ * endEncoding is set to 0 because the escape sequence may be
+ * output.
+ */
+
+ if ((stageLen + saved == 0) && (result == 0)) {
+ endEncoding = 0;
+ }
}
}
+
+ /* If nothing was written and it happened because there was no progress
+ * in the UTF conversion, we throw an error.
+ */
+
+ if (!consumedSomething && (total == 0)) {
+ Tcl_SetErrno (EINVAL);
+ return -1;
+ }
return total;
}
\f
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
- int inEofChar, skip, copiedTotal;
+ int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
- int oldLength, oldFlags, oldRemoved;
/*
* This operation should occur at the top of a channel stack.
if (statePtr->flags & CHANNEL_EOF) {
skip = 0;
eol = dstEnd;
- if (eol == objPtr->bytes) {
+ if (eol == objPtr->bytes + oldLength) {
/*
- * If we didn't produce any bytes before encountering EOF,
+ * If we didn't append any bytes before encountering EOF,
* caller needs to see -1.
*/
- Tcl_SetObjLength(objPtr, 0);
+ Tcl_SetObjLength(objPtr, oldLength);
CommonGetsCleanup(chanPtr, encoding);
copiedTotal = -1;
goto done;
statePtr->inputEncodingState = gs.state;
Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved,
gs.rawRead, statePtr->inputEncodingFlags,
- &statePtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX,
- &gs.rawRead, NULL, &gs.charsWrote);
+ &statePtr->inputEncodingState, dst,
+ eol - dst + skip + TCL_UTF_MAX, &gs.rawRead, NULL,
+ &gs.charsWrote);
bufPtr->nextRemoved += gs.rawRead;
/*
char *dst;
int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length;
Tcl_Obj *objPtr;
-#define ENCODING_LINESIZE 30 /* Lower bound on how many bytes to convert
+#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert
* at a time. Since we don't know a priori
* how many bytes of storage this many source
* bytes will use, we actually need at least
* seen EOL. Need to read more bytes from the channel device.
* Side effect is to allocate another channel buffer.
*/
-
+
read:
if (statePtr->flags & CHANNEL_BLOCKED) {
if (statePtr->flags & CHANNEL_NONBLOCKING) {
result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState,
dst, spaceLeft, &gsPtr->rawRead, &gsPtr->bytesWrote,
- &gsPtr->charsWrote);
+ &gsPtr->charsWrote);
+
+ /*
+ * Make sure that if we go through 'gets', that we reset the
+ * TCL_ENCODING_START flag still. [Bug #523988]
+ */
+ statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
+
if (result == TCL_CONVERT_MULTIBYTE) {
/*
* The last few bytes in this channel buffer were the start of a
int
Tcl_ReadRaw(chan, bufPtr, bytesToRead)
Tcl_Channel chan; /* The channel from which to read. */
- char *bufPtr; /* Where to store input read. */
+ char *bufPtr; /* Where to store input read. */
int bytesToRead; /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
statePtr->flags &= (~(CHANNEL_BLOCKED));
}
- /*
- * Now go to the driver to get as much as is possible to
- * fill the remaining request. Do all the error handling
- * by ourselves. The code was stolen from 'GetInput' and
- * slightly adapted (different return value here).
- *
- * The case of 'bytesToRead == 0' at this point cannot happen.
- */
-
- nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
+ if ((statePtr->flags & CHANNEL_TIMER_FEV) &&
+ (statePtr->flags & CHANNEL_NONBLOCKING)) {
+ nread = -1;
+ result = EWOULDBLOCK;
+ } else {
+ /*
+ * Now go to the driver to get as much as is possible to
+ * fill the remaining request. Do all the error handling
+ * by ourselves. The code was stolen from 'GetInput' and
+ * slightly adapted (different return value here).
+ *
+ * The case of 'bytesToRead == 0' at this point cannot happen.
+ */
+
+ nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
bufPtr + copied, bytesToRead - copied, &result);
+ }
if (nread > 0) {
/*
* If we get a short read, signal up that we may be
* of the object. */
{
- Channel *chanPtr = (Channel *) chan;
- ChannelState *statePtr = chanPtr->state; /* state info for channel */
- ChannelBuffer *bufPtr;
- int offset, factor, copied, copiedNow, result;
- Tcl_Encoding encoding;
-#define UTF_EXPANSION_FACTOR 1024
+ Channel* chanPtr = (Channel *) chan;
+ ChannelState* statePtr = chanPtr->state; /* state info for channel */
/*
* This operation should occur at the top of a channel stack.
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
- copied = -1;
- goto done;
+ /*
+ * Update the notifier state so we don't block while there is still
+ * data in the buffers.
+ */
+ UpdateInterest(chanPtr);
+ return -1;
}
+ return DoReadChars (chanPtr, objPtr, toRead, appendFlag);
+}
+/*
+ *---------------------------------------------------------------------------
+ *
+ * DoReadChars --
+ *
+ * Reads from the channel until the requested number of characters
+ * have been seen, EOF is seen, or the channel would block. EOL
+ * and EOF translation is done. If reading binary data, the raw
+ * bytes are wrapped in a Tcl byte array object. Otherwise, the raw
+ * bytes are converted to UTF-8 using the channel's current encoding
+ * and stored in a Tcl string object.
+ *
+ * Results:
+ * The number of characters read, or -1 on error. Use Tcl_GetErrno()
+ * to retrieve the error code for the error that occurred.
+ *
+ * Side effects:
+ * May cause input to be buffered.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+DoReadChars(chanPtr, objPtr, toRead, appendFlag)
+ Channel* chanPtr; /* The channel to read. */
+ Tcl_Obj *objPtr; /* Input data is stored in this object. */
+ int toRead; /* Maximum number of characters to store,
+ * or -1 to read all available data (up to EOF
+ * or when channel blocks). */
+ int appendFlag; /* If non-zero, data read from the channel
+ * will be appended to the object. Otherwise,
+ * the data will replace the existing contents
+ * of the object. */
+
+{
+ ChannelState *statePtr = chanPtr->state; /* state info for channel */
+ ChannelBuffer *bufPtr;
+ int offset, factor, copied, copiedNow, result;
+ Tcl_Encoding encoding;
+#define UTF_EXPANSION_FACTOR 1024
+
+ /*
+ * This operation should occur at the top of a channel stack.
+ */
+
+ chanPtr = statePtr->topChanPtr;
encoding = statePtr->encoding;
- factor = UTF_EXPANSION_FACTOR;
+ factor = UTF_EXPANSION_FACTOR;
if (appendFlag == 0) {
if (encoding == NULL) {
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
if (nextPtr == NULL) {
- statePtr->inQueueTail = nextPtr;
+ statePtr->inQueueTail = NULL;
}
}
}
static int
ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr)
ChannelState *statePtr; /* State of the channel to read. */
- int bytesToRead; /* Maximum number of characters to store,
- * or < 0 to get all available characters.
- * Characters are obtained from the first
- * buffer in the queue -- even if this number
- * is larger than the number of characters
- * available in the first buffer, only the
- * characters from the first buffer are
- * returned. */
Tcl_Obj *objPtr; /* Input data is appended to this ByteArray
* object. Its length is how much space
* has been allocated to hold data, not how
* many bytes of data have been stored in the
* object. */
+ int bytesToRead; /* Maximum number of bytes to store,
+ * or < 0 to get all available bytes.
+ * Bytes are obtained from the first
+ * buffer in the queue -- even if this number
+ * is larger than the number of bytes
+ * available in the first buffer, only the
+ * bytes from the first buffer are
+ * returned. */
int *offsetPtr; /* On input, contains how many bytes of
* objPtr have been used to hold data. On
* output, filled with how many bytes are now
* being used. */
{
- int toRead, srcLen, srcRead, dstWrote, offset, length;
+ int toRead, srcLen, offset, length, srcRead, dstWrote;
ChannelBuffer *bufPtr;
char *src, *dst;
static int
ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr)
ChannelState *statePtr; /* State of channel to read. */
+ Tcl_Obj *objPtr; /* Input data is appended to this object.
+ * objPtr->length is how much space has been
+ * allocated to hold data, not how many bytes
+ * of data have been stored in the object. */
int charsToRead; /* Maximum number of characters to store,
* or -1 to get all available characters.
* Characters are obtained from the first
* available in the first buffer, only the
* characters from the first buffer are
* returned. */
- Tcl_Obj *objPtr; /* Input data is appended to this object.
- * objPtr->length is how much space has been
- * allocated to hold data, not how many bytes
- * of data have been stored in the object. */
int *offsetPtr; /* On input, contains how many bytes of
* objPtr have been used to hold data. On
* output, filled with how many bytes are now
* UTF-8. On output, contains another guess
* based on the data seen so far. */
{
- int toRead, factor, offset, spaceLeft, length;
- int srcLen, srcRead, dstNeeded, dstRead, dstWrote, numChars;
+ int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded;
+ int srcRead, dstWrote, numChars, dstRead;
ChannelBuffer *bufPtr;
char *src, *dst;
Tcl_EncodingState oldState;
srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;
toRead = charsToRead;
- if ((unsigned) toRead > (unsigned) srcLen) {
+ if ((unsigned)toRead > (unsigned)srcLen) {
toRead = srcLen;
}
nextPtr = bufPtr->nextPtr;
if (nextPtr == NULL) {
- /*
- * There isn't enough data in the buffers to complete the next
- * character, so we need to wait for more data before the next
- * file event can be delivered.
- */
+ if (srcLen > 0) {
+ /*
+ * There isn't enough data in the buffers to complete the next
+ * character, so we need to wait for more data before the next
+ * file event can be delivered.
+ *
+ * SF #478856.
+ *
+ * The exception to this is if the input buffer was
+ * completely empty before we tried to convert its
+ * contents. Nothing in, nothing out, and no incomplete
+ * character data. The conversion before the current one
+ * was complete.
+ */
- statePtr->flags |= CHANNEL_NEED_MORE_DATA;
+ statePtr->flags |= CHANNEL_NEED_MORE_DATA;
+ }
return -1;
}
nextPtr->nextRemoved -= srcLen;
if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) {
/*
* Hit EOF char. How many bytes of src correspond to where the
- * EOF was located in dst?
+ * EOF was located in dst? Run the conversion again with an
+ * output buffer just big enough to hold the data so we can
+ * get the correct value for srcRead.
*/
if (dstWrote == 0) {
* Got too many chars.
*/
- char *eof;
+ CONST char *eof;
eof = Tcl_UtfAtIndex(dst, toRead);
statePtr->inputEncodingState = oldState;
int
Tcl_Ungets(chan, str, len, atEnd)
Tcl_Channel chan; /* The channel for which to add the input. */
- char *str; /* The input itself. */
+ CONST char *str; /* The input itself. */
int len; /* The length of the input. */
int atEnd; /* If non-zero, add at end of queue; otherwise
* add at head of queue. */
} else {
bufPtr = statePtr->saveInBufPtr;
statePtr->saveInBufPtr = NULL;
+
+ /*
+ * Check the actual buffersize against the requested
+ * buffersize. Buffers which are smaller than requested are
+ * squashed. This is done to honor dynamic changes of the
+ * buffersize made by the user.
+ */
+
+ if ((bufPtr != NULL) && ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize)) {
+ ckfree((char *) bufPtr);
+ bufPtr = NULL;
+ }
+
if (bufPtr == NULL) {
bufPtr = AllocChannelBuffer(statePtr->bufSize);
}
bufPtr->nextPtr = (ChannelBuffer *) NULL;
- toRead = statePtr->bufSize;
+ /* SF #427196: Use the actual size of the buffer to determine
+ * the number of bytes to read from the channel and not the
+ * size for new buffers. They can be different if the
+ * buffersize was changed between reads.
+ *
+ * Note: This affects performance negatively if the buffersize
+ * was extended but this small buffer is reused for all
+ * subsequent reads. The system never uses buffers with the
+ * requested bigger size in that case. An adjunct patch could
+ * try and delete all unused buffers it encounters and which
+ * are smaller than the formally requested buffersize.
+ */
+
+ toRead = bufPtr->bufLength - bufPtr->nextAdded;
+
if (statePtr->inQueueTail == NULL) {
statePtr->inQueueHead = bufPtr;
} else {
}
statePtr->inQueueTail = bufPtr;
}
-
+
/*
* If EOF is set, we should avoid calling the driver because on some
* platforms it is impossible to read from a device after EOF.
return 0;
}
- nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
- bufPtr->buf + bufPtr->nextAdded, toRead, &result);
+ if ((statePtr->flags & CHANNEL_TIMER_FEV) &&
+ (statePtr->flags & CHANNEL_NONBLOCKING)) {
+ nread = -1;
+ result = EWOULDBLOCK;
+ } else {
+ nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
+ bufPtr->buf + bufPtr->nextAdded, toRead, &result);
+ }
if (nread > 0) {
bufPtr->nextAdded += nread;
}
Tcl_SetErrno(result);
return result;
- }
+ }
return 0;
}
\f
*----------------------------------------------------------------------
*/
-int
+Tcl_WideInt
Tcl_Seek(chan, offset, mode)
Tcl_Channel chan; /* The channel on which to seek. */
- int offset; /* Offset to seek to. */
+ Tcl_WideInt offset; /* Offset to seek to. */
int mode; /* Relative to which location to seek? */
{
Channel *chanPtr = (Channel *) chan; /* The real IO channel. */
ChannelState *statePtr = chanPtr->state; /* state info for channel */
- ChannelBuffer *bufPtr;
int inputBuffered, outputBuffered;
+ /* # bytes held in buffers. */
int result; /* Of device driver operations. */
- int curPos; /* Position on the device. */
+ Tcl_WideInt curPos; /* Position on the device. */
int wasAsync; /* Was the channel nonblocking before the
* seek operation? If so, must restore to
* nonblocking mode after the seek. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
- return -1;
+ return Tcl_LongAsWide(-1);
}
/*
* registered in an interpreter.
*/
- if (CheckForDeadChannel(NULL, statePtr)) return -1;
+ if (CheckForDeadChannel(NULL, statePtr)) {
+ return Tcl_LongAsWide(-1);
+ }
/*
* This operation should occur at the top of a channel stack.
if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
Tcl_SetErrno(EINVAL);
- return -1;
+ return Tcl_LongAsWide(-1);
}
/*
* output is buffered, cannot compute the current position.
*/
- for (bufPtr = statePtr->inQueueHead, inputBuffered = 0;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
- }
-
- /*
- * Don't forget the bytes in the topmost pushback area.
- */
-
- for (bufPtr = statePtr->topChanPtr->inQueueHead;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
- }
-
- for (bufPtr = statePtr->outQueueHead, outputBuffered = 0;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
- }
- if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
- (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
- statePtr->flags |= BUFFER_READY;
- outputBuffered +=
- (statePtr->curOutPtr->nextAdded - statePtr->curOutPtr->nextRemoved);
- }
+ inputBuffered = Tcl_InputBuffered(chan);
+ outputBuffered = Tcl_OutputBuffered(chan);
if ((inputBuffered != 0) && (outputBuffered != 0)) {
Tcl_SetErrno(EFAULT);
- return -1;
+ return Tcl_LongAsWide(-1);
}
/*
wasAsync = 1;
result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING);
if (result != 0) {
- return -1;
+ return Tcl_LongAsWide(-1);
}
statePtr->flags &= (~(CHANNEL_NONBLOCKING));
if (statePtr->flags & BG_FLUSH_SCHEDULED) {
/*
* Now seek to the new position in the channel as requested by the
- * caller.
+ * caller. Note that we prefer the wideSeekProc if that is
+ * available and non-NULL...
*/
- curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData,
- (long) offset, mode, &result);
- if (curPos == -1) {
- Tcl_SetErrno(result);
- }
+ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
+ chanPtr->typePtr->wideSeekProc != NULL) {
+ curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
+ offset, mode, &result);
+ } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
+ offset > Tcl_LongAsWide(LONG_MAX)) {
+ Tcl_SetErrno(EOVERFLOW);
+ curPos = Tcl_LongAsWide(-1);
+ } else {
+ curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
+ chanPtr->instanceData, Tcl_WideAsLong(offset), mode,
+ &result));
+ if (curPos == Tcl_LongAsWide(-1)) {
+ Tcl_SetErrno(result);
+ }
+ }
}
/*
statePtr->flags |= CHANNEL_NONBLOCKING;
result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING);
if (result != 0) {
- return -1;
+ return Tcl_LongAsWide(-1);
}
}
*----------------------------------------------------------------------
*/
-int
+Tcl_WideInt
Tcl_Tell(chan)
Tcl_Channel chan; /* The channel to return pos for. */
{
Channel *chanPtr = (Channel *) chan; /* The real IO channel. */
ChannelState *statePtr = chanPtr->state; /* state info for channel */
- ChannelBuffer *bufPtr;
- int inputBuffered, outputBuffered;
+ int inputBuffered, outputBuffered; /* # bytes held in buffers. */
int result; /* Of calling device driver. */
- int curPos; /* Position on device. */
+ Tcl_WideInt curPos; /* Position on device. */
if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) {
- return -1;
+ return Tcl_LongAsWide(-1);
}
/*
*/
if (CheckForDeadChannel(NULL, statePtr)) {
- return -1;
+ return Tcl_LongAsWide(-1);
}
/*
if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) {
Tcl_SetErrno(EINVAL);
- return -1;
+ return Tcl_LongAsWide(-1);
}
/*
* output is buffered, cannot compute the current position.
*/
- for (bufPtr = statePtr->inQueueHead, inputBuffered = 0;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
- }
- for (bufPtr = statePtr->outQueueHead, outputBuffered = 0;
- bufPtr != (ChannelBuffer *) NULL;
- bufPtr = bufPtr->nextPtr) {
- outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
- }
- if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
- (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
- statePtr->flags |= BUFFER_READY;
- outputBuffered +=
- (statePtr->curOutPtr->nextAdded - statePtr->curOutPtr->nextRemoved);
- }
+ inputBuffered = Tcl_InputBuffered(chan);
+ outputBuffered = Tcl_OutputBuffered(chan);
if ((inputBuffered != 0) && (outputBuffered != 0)) {
Tcl_SetErrno(EFAULT);
- return -1;
+ return Tcl_LongAsWide(-1);
}
/*
* Get the current position in the device and compute the position
- * where the next character will be read or written.
+ * where the next character will be read or written. Note that we
+ * prefer the wideSeekProc if that is available and non-NULL...
*/
- curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData,
- (long) 0, SEEK_CUR, &result);
- if (curPos == -1) {
+ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
+ chanPtr->typePtr->wideSeekProc != NULL) {
+ curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
+ Tcl_LongAsWide(0), SEEK_CUR, &result);
+ } else {
+ curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
+ chanPtr->instanceData, 0, SEEK_CUR, &result));
+ }
+ if (curPos == Tcl_LongAsWide(-1)) {
Tcl_SetErrno(result);
- return -1;
+ return Tcl_LongAsWide(-1);
}
if (inputBuffered != 0) {
- return (curPos - inputBuffered);
+ return curPos - inputBuffered;
}
- return (curPos + outputBuffered);
+ return curPos + outputBuffered;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_SeekOld, Tcl_TellOld --
+ *
+ * Backward-compatability versions of the seek/tell interface that
+ * do not support 64-bit offsets. This interface is not documented
+ * or expected to be supported indefinitely.
+ *
+ * Results:
+ * As for Tcl_Seek and Tcl_Tell respectively, except truncated to
+ * whatever value will fit in an 'int'.
+ *
+ * Side effects:
+ * As for Tcl_Seek and Tcl_Tell respectively.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_SeekOld(chan, offset, mode)
+ Tcl_Channel chan; /* The channel on which to seek. */
+ int offset; /* Offset to seek to. */
+ int mode; /* Relative to which location to seek? */
+{
+ Tcl_WideInt wOffset, wResult;
+
+ wOffset = Tcl_LongAsWide((long)offset);
+ wResult = Tcl_Seek(chan, wOffset, mode);
+ return (int)Tcl_WideAsLong(wResult);
+}
+
+int
+Tcl_TellOld(chan)
+ Tcl_Channel chan; /* The channel to return pos for. */
+{
+ Tcl_WideInt wResult;
+
+ wResult = Tcl_Tell(chan);
+ return (int)Tcl_WideAsLong(wResult);
}
\f
/*
* reading beyond the eofChar). Also, always clear the BLOCKED bit.
* We want to discover these conditions anew in each operation.
*/
-
+
if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) {
statePtr->flags &= ~CHANNEL_EOF;
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_OutputBuffered --
+ *
+ * Returns the number of bytes of output currently buffered in the
+ * common internal buffer of a channel.
+ *
+ * Results:
+ * The number of output bytes buffered, or zero if the channel is not
+ * open for writing.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_OutputBuffered(chan)
+ Tcl_Channel chan; /* The channel to query. */
+{
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of real channel structure. */
+ ChannelBuffer *bufPtr;
+ int bytesBuffered;
+
+ for (bytesBuffered = 0, bufPtr = statePtr->outQueueHead;
+ bufPtr != (ChannelBuffer *) NULL;
+ bufPtr = bufPtr->nextPtr) {
+ bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved);
+ }
+ if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
+ (statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
+ statePtr->flags |= BUFFER_READY;
+ bytesBuffered +=
+ (statePtr->curOutPtr->nextAdded - statePtr->curOutPtr->nextRemoved);
+ }
+
+ return bytesBuffered;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ChannelBuffered --
*
* Returns the number of bytes of input currently buffered in the
int
Tcl_BadChannelOption(interp, optionName, optionList)
Tcl_Interp *interp; /* Current interpreter. (can be NULL)*/
- char *optionName; /* 'bad option' name */
- char *optionList; /* Specific options list to append
+ CONST char *optionName; /* 'bad option' name */
+ CONST char *optionList; /* Specific options list to append
* to the standard generic options.
* can be NULL for generic options
* only.
if (interp) {
CONST char *genericopt =
"blocking buffering buffersize encoding eofchar translation";
- char **argv;
+ CONST char **argv;
int argc, i;
Tcl_DString ds;
Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, (char *) genericopt, -1);
+ Tcl_DStringAppend(&ds, genericopt, -1);
if (optionList && (*optionList)) {
Tcl_DStringAppend(&ds, " ", 1);
Tcl_DStringAppend(&ds, optionList, -1);
Tcl_GetChannelOption(interp, chan, optionName, dsPtr)
Tcl_Interp *interp; /* For error reporting - can be NULL. */
Tcl_Channel chan; /* Channel on which to get option. */
- char *optionName; /* Option to get. */
+ CONST char *optionName; /* Option to get. */
Tcl_DString *dsPtr; /* Where to store value(s). */
{
size_t len; /* Length of optionName string. */
Tcl_DStringAppendElement(dsPtr, buf);
}
}
+ if ( !(flags & (TCL_READABLE|TCL_WRITABLE))) {
+ /* Not readable or writable (server socket) */
+ Tcl_DStringAppendElement(dsPtr, "");
+ }
if (((flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
Tcl_DStringAppendElement(dsPtr, "lf");
}
}
+ if ( !(flags & (TCL_READABLE|TCL_WRITABLE))) {
+ /* Not readable or writable (server socket) */
+ Tcl_DStringAppendElement(dsPtr, "auto");
+ }
if (((flags & (TCL_READABLE|TCL_WRITABLE)) ==
(TCL_READABLE|TCL_WRITABLE)) && (len == 0)) {
Tcl_DStringEndSublist(dsPtr);
Tcl_SetChannelOption(interp, chan, optionName, newValue)
Tcl_Interp *interp; /* For error reporting - can be NULL. */
Tcl_Channel chan; /* Channel on which to set mode. */
- char *optionName; /* Which option to set? */
- char *newValue; /* New value for option. */
+ CONST char *optionName; /* Which option to set? */
+ CONST char *newValue; /* New value for option. */
{
- int newMode; /* New (numeric) mode to sert. */
Channel *chanPtr = (Channel *) chan; /* The real IO channel. */
ChannelState *statePtr = chanPtr->state; /* state info for channel */
size_t len; /* Length of optionName string. */
int argc;
- char **argv;
+ CONST char **argv;
/*
* If the channel is in the middle of a background copy, fail.
if ((len > 2) && (optionName[1] == 'b') &&
(strncmp(optionName, "-blocking", len) == 0)) {
+ int newMode;
if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) {
return TCL_ERROR;
}
return TCL_ERROR;
}
}
+ /*
+ * When the channel has an escape sequence driven encoding such as
+ * iso2022, the terminated escape sequence must write to the buffer.
+ */
+ if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
+ && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
+ statePtr->outputEncodingFlags |= TCL_ENCODING_END;
+ WriteChars(chanPtr, "", 0);
+ }
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = encoding;
statePtr->inputEncodingState = NULL;
} else if (argc != 2) {
if (interp) {
Tcl_AppendResult(interp,
- "bad value for -eofchar: should be a list of one or",
- " two elements", (char *) NULL);
+ "bad value for -eofchar: should be a list of zero,",
+ " one, or two elements", (char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
statePtr->outEofChar = (int) argv[1][0];
}
}
- if (argv != (char **) NULL) {
+ if (argv != NULL) {
ckfree((char *) argv);
}
return TCL_OK;
} else if ((len > 1) && (optionName[1] == 't') &&
(strncmp(optionName, "-translation", len) == 0)) {
- char *readMode, *writeMode;
+ CONST char *readMode, *writeMode;
if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if (readMode) {
+ TclEolTranslation translation;
if (*readMode == '\0') {
- newMode = statePtr->inputTranslation;
+ translation = statePtr->inputTranslation;
} else if (strcmp(readMode, "auto") == 0) {
- newMode = TCL_TRANSLATE_AUTO;
+ translation = TCL_TRANSLATE_AUTO;
} else if (strcmp(readMode, "binary") == 0) {
- newMode = TCL_TRANSLATE_LF;
+ translation = TCL_TRANSLATE_LF;
statePtr->inEofChar = 0;
Tcl_FreeEncoding(statePtr->encoding);
statePtr->encoding = NULL;
} else if (strcmp(readMode, "lf") == 0) {
- newMode = TCL_TRANSLATE_LF;
+ translation = TCL_TRANSLATE_LF;
} else if (strcmp(readMode, "cr") == 0) {
- newMode = TCL_TRANSLATE_CR;
+ translation = TCL_TRANSLATE_CR;
} else if (strcmp(readMode, "crlf") == 0) {
- newMode = TCL_TRANSLATE_CRLF;
+ translation = TCL_TRANSLATE_CRLF;
} else if (strcmp(readMode, "platform") == 0) {
- newMode = TCL_PLATFORM_TRANSLATION;
+ translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_AppendResult(interp,
* complete the line.
*/
- if (newMode != statePtr->inputTranslation) {
- statePtr->inputTranslation = (Tcl_EolTranslation) newMode;
+ if (translation != statePtr->inputTranslation) {
+ statePtr->inputTranslation = translation;
statePtr->flags &= ~(INPUT_SAW_CR);
statePtr->flags &= ~(CHANNEL_NEED_MORE_DATA);
UpdateInterest(chanPtr);
* coded later.
*/
- if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) {
+ if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) {
statePtr->outputTranslation = TCL_TRANSLATE_CRLF;
} else {
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
ChannelHandler *chPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler nh;
-#ifdef TCL_CHANNEL_VERSION_2
Channel* upChanPtr;
Tcl_ChannelType* upTypePtr;
*/
while (mask && (chanPtr->upChanPtr != ((Channel*) NULL))) {
+ Tcl_DriverHandlerProc* upHandlerProc;
+
upChanPtr = chanPtr->upChanPtr;
upTypePtr = upChanPtr->typePtr;
-
- if ((Tcl_ChannelVersion(upTypePtr) == TCL_CHANNEL_VERSION_2) &&
- (Tcl_ChannelHandlerProc(upTypePtr) !=
- ((Tcl_DriverHandlerProc *) NULL))) {
-
- Tcl_DriverHandlerProc* handlerProc =
- Tcl_ChannelHandlerProc(upTypePtr);
-
- mask = (*handlerProc) (upChanPtr->instanceData, mask);
+ upHandlerProc = Tcl_ChannelHandlerProc(upTypePtr);
+ if (upHandlerProc != NULL) {
+ mask = (*upHandlerProc) (upChanPtr->instanceData, mask);
}
/* ELSE:
*/
Tcl_Preserve((ClientData) channel);
+ Tcl_Preserve((ClientData) statePtr);
/*
* If we are flushing in the background, be sure to call FlushChannel
*/
if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
- FlushChannel(NULL, chanPtr, 1);
- mask &= ~TCL_WRITABLE;
+ FlushChannel(NULL, chanPtr, 1);
+ mask &= ~TCL_WRITABLE;
}
/*
tsdPtr->nestedHandlerPtr = &nh;
for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; ) {
+ /*
+ * If this channel handler is interested in any of the events that
+ * have occurred on the channel, invoke its procedure.
+ */
- /*
- * If this channel handler is interested in any of the events that
- * have occurred on the channel, invoke its procedure.
- */
-
- if ((chPtr->mask & mask) != 0) {
- nh.nextHandlerPtr = chPtr->nextPtr;
- (*(chPtr->proc))(chPtr->clientData, mask);
- chPtr = nh.nextHandlerPtr;
- } else {
- chPtr = chPtr->nextPtr;
- }
+ if ((chPtr->mask & mask) != 0) {
+ nh.nextHandlerPtr = chPtr->nextPtr;
+ (*(chPtr->proc))(chPtr->clientData, mask);
+ chPtr = nh.nextHandlerPtr;
+ } else {
+ chPtr = chPtr->nextPtr;
+ }
}
/*
UpdateInterest(chanPtr);
}
+ Tcl_Release((ClientData) statePtr);
Tcl_Release((ClientData) channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
-#else
- /* Walk all channels in a stack ! and notify them in order.
- */
-
- while (chanPtr != (Channel *) NULL) {
- /*
- * Preserve the channel struct in case the script closes it.
- */
-
- Tcl_Preserve((ClientData) channel);
-
- /*
- * If we are flushing in the background, be sure to call FlushChannel
- * for writable events. Note that we have to discard the writable
- * event so we don't call any write handlers before the flush is
- * complete.
- */
-
- if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) {
- FlushChannel(NULL, chanPtr, 1);
- mask &= ~TCL_WRITABLE;
- }
-
- /*
- * Add this invocation to the list of recursive invocations of
- * ChannelHandlerEventProc.
- */
-
- nh.nextHandlerPtr = (ChannelHandler *) NULL;
- nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr;
- tsdPtr->nestedHandlerPtr = &nh;
-
- for (chPtr = statePtr->chPtr; chPtr != (ChannelHandler *) NULL; ) {
-
- /*
- * If this channel handler is interested in any of the events that
- * have occurred on the channel, invoke its procedure.
- */
-
- if ((chPtr->mask & mask) != 0) {
- nh.nextHandlerPtr = chPtr->nextPtr;
- (*(chPtr->proc))(chPtr->clientData, mask);
- chPtr = nh.nextHandlerPtr;
- } else {
- chPtr = chPtr->nextPtr;
- }
- }
-
- /*
- * Update the notifier interest, since it may have changed after
- * invoking event handlers. Skip that if the channel was deleted
- * in the call to the channel handler.
- */
-
- if (chanPtr->typePtr != NULL) {
- UpdateInterest(chanPtr);
-
- /* Walk down the stack.
- */
- chanPtr = chanPtr->downChanPtr;
- } else {
- /* Stop walking the chain, the whole stack was destroyed!
- */
- chanPtr = (Channel *) NULL;
- }
-
- Tcl_Release((ClientData) channel);
-
- tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
-
- channel = (Tcl_Channel) chanPtr;
- }
-#endif
}
\f
/*
statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
(ClientData) chanPtr);
+
+ /* Set the TIMER flag to notify the higher levels that the
+ * driver might have no data for us. We do this only if we are
+ * in non-blocking mode and the driver has no BlockModeProc
+ * because only then we really don't know if the driver will
+ * block or not. A similar test is done in "PeekAhead".
+ */
+
+ if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
+ (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
+ statePtr->flags |= CHANNEL_TIMER_FEV;
+ }
+ Tcl_Preserve((ClientData) statePtr);
Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE);
-
+
+ statePtr->flags &= ~CHANNEL_TIMER_FEV;
+ Tcl_Release((ClientData) statePtr);
} else {
statePtr->timer = NULL;
UpdateInterest(chanPtr);
char *chanName;
int modeIndex; /* Index of mode argument. */
int mask;
- static char *modeOptions[] = {"readable", "writable", NULL};
+ static CONST char *modeOptions[] = {"readable", "writable", NULL};
static int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
if ((objc != 3) && (objc != 4)) {
if (inPtr != outPtr) {
if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) {
if (SetBlockMode(NULL, outPtr,
- nonBlocking ? TCL_MODE_BLOCKING : TCL_MODE_NONBLOCKING)
+ nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING)
!= TCL_OK) {
if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, inPtr,
int mask; /* Current channel event flags. */
{
Tcl_Interp *interp;
- Tcl_Obj *cmdPtr, *errObj = NULL;
+ Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL;
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
- int result = TCL_OK;
- int size;
- int total;
+ int result = TCL_OK, size, total, sizeb;
+ char* buffer;
+
+ int inBinary, outBinary, sameEncoding; /* Encoding control */
+ int underflow; /* input underflow */
inChan = (Tcl_Channel) csPtr->readPtr;
outChan = (Tcl_Channel) csPtr->writePtr;
* thus gets the bottom of the stack.
*/
- while (csPtr->toRead != 0) {
+ inBinary = (inStatePtr->encoding == NULL);
+ outBinary = (outStatePtr->encoding == NULL);
+ sameEncoding = (inStatePtr->encoding == outStatePtr->encoding);
+ if (!(inBinary || sameEncoding)) {
+ bufObj = Tcl_NewObj ();
+ Tcl_IncrRefCount (bufObj);
+ }
+
+ while (csPtr->toRead != 0) {
/*
* Check for unreported background errors.
*/
*/
if ((csPtr->toRead == -1) || (csPtr->toRead > csPtr->bufSize)) {
- size = csPtr->bufSize;
+ sizeb = csPtr->bufSize;
+ } else {
+ sizeb = csPtr->toRead;
+ }
+
+ if (inBinary || sameEncoding) {
+ size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb);
} else {
- size = csPtr->toRead;
+ size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb, 0 /* No append */);
}
- size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, size);
+ underflow = (size >= 0) && (size < sizeb); /* input underflow */
if (size < 0) {
readError:
Tcl_GetChannelName(inChan), "\": ",
Tcl_PosixError(interp), (char *) NULL);
break;
- } else if (size == 0) {
+ } else if (underflow) {
/*
* We had an underflow on the read side. If we are at EOF,
* then the copying is done, otherwise set up a channel
* handler to detect when the channel becomes readable again.
*/
- if (Tcl_Eof(inChan)) {
+ if ((size == 0) && Tcl_Eof(inChan)) {
break;
- } else if (!(mask & TCL_READABLE)) {
+ }
+ if (! Tcl_Eof(inChan) && !(mask & TCL_READABLE)) {
if (mask & TCL_WRITABLE) {
Tcl_DeleteChannelHandler(outChan, CopyEventProc,
(ClientData) csPtr);
Tcl_CreateChannelHandler(inChan, TCL_READABLE,
CopyEventProc, (ClientData) csPtr);
}
- return TCL_OK;
+ if (size == 0) {
+ if (bufObj != (Tcl_Obj*) NULL) {
+ Tcl_DecrRefCount (bufObj);
+ bufObj = (Tcl_Obj*) NULL;
+ }
+ return TCL_OK;
+ }
}
/*
* Now write the buffer out.
*/
- size = DoWrite(outStatePtr->topChanPtr, csPtr->buffer, size);
- if (size < 0) {
+ if (inBinary || sameEncoding) {
+ buffer = csPtr->buffer;
+ sizeb = size;
+ } else {
+ buffer = Tcl_GetStringFromObj (bufObj, &sizeb);
+ }
+
+ if (outBinary || sameEncoding) {
+ sizeb = DoWrite(outStatePtr->topChanPtr, buffer, sizeb);
+ } else {
+ sizeb = DoWriteChars(outStatePtr->topChanPtr, buffer, sizeb);
+ }
+
+ if (inBinary || sameEncoding) {
+ /* Both read and write counted bytes */
+ size = sizeb;
+ } /* else : Read counted characters, write counted bytes, i.e. size != sizeb */
+
+ if (sizeb < 0) {
writeError:
errObj = Tcl_NewObj();
Tcl_AppendStringsToObj(errObj, "error writing \"",
}
/*
+ * Update the current byte count. Do it now so the count is
+ * valid before a return or break takes us out of the loop.
+ * The invariant at the top of the loop should be that
+ * csPtr->toRead holds the number of bytes left to copy.
+ */
+
+ if (csPtr->toRead != -1) {
+ csPtr->toRead -= size;
+ }
+ csPtr->total += size;
+
+ /*
+ * Break loop if EOF && (size>0)
+ */
+
+ if (Tcl_Eof(inChan)) {
+ break;
+ }
+
+ /*
* Check to see if the write is happening in the background. If so,
* stop copying and wait for the channel to become writable again.
+ * After input underflow we already installed a readable handler
+ * therefore we don't need a writable handler.
*/
- if (outStatePtr->flags & BG_FLUSH_SCHEDULED) {
+ if ( ! underflow && (outStatePtr->flags & BG_FLUSH_SCHEDULED) ) {
if (!(mask & TCL_WRITABLE)) {
if (mask & TCL_READABLE) {
- Tcl_DeleteChannelHandler(outChan, CopyEventProc,
+ Tcl_DeleteChannelHandler(inChan, CopyEventProc,
(ClientData) csPtr);
}
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
CopyEventProc, (ClientData) csPtr);
}
+ if (bufObj != (Tcl_Obj*) NULL) {
+ Tcl_DecrRefCount (bufObj);
+ bufObj = (Tcl_Obj*) NULL;
+ }
return TCL_OK;
}
/*
- * Update the current byte count if we care.
- */
-
- if (csPtr->toRead != -1) {
- csPtr->toRead -= size;
- }
- csPtr->total += size;
-
- /*
* For background copies, we only do one buffer per invocation so
* we don't starve the rest of the system.
*/
Tcl_CreateChannelHandler(outChan, TCL_WRITABLE,
CopyEventProc, (ClientData) csPtr);
}
+ if (bufObj != (Tcl_Obj*) NULL) {
+ Tcl_DecrRefCount (bufObj);
+ bufObj = (Tcl_Obj*) NULL;
+ }
return TCL_OK;
}
+ } /* while */
+
+ if (bufObj != (Tcl_Obj*) NULL) {
+ Tcl_DecrRefCount (bufObj);
+ bufObj = (Tcl_Obj*) NULL;
}
/*
*
* Reads a given number of bytes from a channel.
*
+ * No encoding conversions are applied to the bytes being read.
+ *
* Results:
* The number of characters read, or -1 on error. Use Tcl_GetErrno()
* to retrieve the error code for the error that occurred.
static int
DoWrite(chanPtr, src, srcLen)
Channel *chanPtr; /* The channel to buffer output for. */
- char *src; /* Data to write. */
+ CONST char *src; /* Data to write. */
int srcLen; /* Number of bytes to write. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *outBufPtr; /* Current output buffer. */
int foundNewline; /* Did we find a newline in output? */
char *dPtr;
- char *sPtr; /* Search variables for newline. */
+ CONST char *sPtr; /* Search variables for newline. */
int crsent; /* In CRLF eol translation mode,
* remember the fact that a CR was
* output to the channel without
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
}
if (csPtr->readPtr != csPtr->writePtr) {
+ nonBlocking = (csPtr->writeFlags & CHANNEL_NONBLOCKING);
if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) {
SetBlockMode(NULL, csPtr->writePtr,
nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING);
int
Tcl_GetChannelNamesEx(interp, pattern)
Tcl_Interp *interp; /* Interp for error reporting. */
- char *pattern; /* pattern to filter on. */
+ CONST char *pattern; /* pattern to filter on. */
{
- ChannelState *statePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- char *name;
- Tcl_Obj *resultPtr;
+ ChannelState *statePtr;
+ CONST char *name; /* name for channel */
+ Tcl_Obj *resultPtr; /* pointer to result object */
+ Tcl_HashTable *hTblPtr; /* Hash table of channels. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Tcl_HashSearch hSearch; /* Search variable. */
- resultPtr = Tcl_GetObjResult(interp);
- for (statePtr = tsdPtr->firstCSPtr;
- statePtr != NULL;
- statePtr = statePtr->nextCSPtr) {
+ if (interp == (Tcl_Interp *) NULL) {
+ return TCL_OK;
+ }
+
+ /*
+ * Get the channel table that stores the channels registered
+ * for this interpreter.
+ */
+ hTblPtr = GetChannelTable(interp);
+ resultPtr = Tcl_GetObjResult(interp);
+
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != (Tcl_HashEntry *) NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+
+ statePtr = ((Channel *) Tcl_GetHashValue(hPtr))->state;
if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
name = "stdin";
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
+ /*
+ * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr),
+ * but it's simpler to just grab the name from the statePtr.
+ */
name = statePtr->channelName;
}
+
if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) &&
(Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, -1)) != TCL_OK)) {
/*
*----------------------------------------------------------------------
*
+ * Tcl_IsChannelRegistered --
+ *
+ * Checks whether the channel is associated with the interp.
+ * See also Tcl_RegisterChannel and Tcl_UnregisterChannel.
+ *
+ * Results:
+ * 0 if the channel is not registered in the interpreter, 1 else.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_IsChannelRegistered (interp, chan)
+ Tcl_Interp* interp; /* The interp to query of the channel */
+ Tcl_Channel chan; /* The channel to check */
+{
+ Tcl_HashTable *hTblPtr; /* Hash table of channels. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Channel *chanPtr; /* The real IO channel. */
+ ChannelState *statePtr; /* State of the real channel. */
+
+ /*
+ * Always check bottom-most channel in the stack. This is the one
+ * that gets registered.
+ */
+ chanPtr = ((Channel *) chan)->state->bottomChanPtr;
+ statePtr = chanPtr->state;
+
+ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
+ if (hTblPtr == (Tcl_HashTable *) NULL) {
+ return 0;
+ }
+ hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
+ if (hPtr == (Tcl_HashEntry *) NULL) {
+ return 0;
+ }
+ if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) {
+ return 0;
+ }
+
+ return 1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IsChannelShared --
+ *
+ * Checks whether the channel is shared by multiple interpreters.
+ *
+ * Results:
+ * A boolean value (0 = Not shared, 1 = Shared).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_IsChannelShared (chan)
+ Tcl_Channel chan; /* The channel to query */
+{
+ ChannelState *statePtr = ((Channel *) chan)->state;
+ /* State of real channel structure. */
+
+ return ((statePtr->refCount > 1) ? 1 : 0);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_IsChannelExisting --
+ *
+ * Checks whether a channel of the given name exists in the
+ * (thread)-global list of all channels.
+ * See Tcl_GetChannelNamesEx for function exposed at the Tcl level.
+ *
+ * Results:
+ * A boolean value (0 = Does not exist, 1 = Does exist).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_IsChannelExisting(chanName)
+ CONST char* chanName; /* The name of the channel to look for. */
+{
+ ChannelState *statePtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ CONST char *name;
+ int chanNameLen;
+
+ chanNameLen = strlen(chanName);
+ for (statePtr = tsdPtr->firstCSPtr;
+ statePtr != NULL;
+ statePtr = statePtr->nextCSPtr) {
+ if (statePtr->topChanPtr == (Channel *) tsdPtr->stdinChannel) {
+ name = "stdin";
+ } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stdoutChannel) {
+ name = "stdout";
+ } else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
+ name = "stderr";
+ } else {
+ name = statePtr->channelName;
+ }
+
+ if ((*chanName == *name) &&
+ (memcmp(name, chanName, (size_t) chanNameLen) == 0)) {
+ return 1;
+ }
+ }
+
+ return 0;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ChannelName --
*
* Return the name of the channel type.
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_ChannelName(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->typeName);
+ return chanTypePtr->typeName;
}
\f
/*
* Return the of version of the channel type.
*
* Results:
- * TCL_CHANNEL_VERSION_2 or TCL_CHANNEL_VERSION_1.
+ * One of the TCL_CHANNEL_VERSION_* constants from tcl.h
*
* Side effects:
* None.
{
if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) {
return TCL_CHANNEL_VERSION_2;
+ } else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) {
+ return TCL_CHANNEL_VERSION_3;
} else {
/*
* In <v2 channel versions, the version field is occupied
/*
*----------------------------------------------------------------------
*
+ * HaveVersion --
+ *
+ * Return whether a channel type is (at least) of a given version.
+ *
+ * Results:
+ * True if the minimum version is exceeded by the version actually
+ * present.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+HaveVersion(chanTypePtr, minimumVersion)
+ Tcl_ChannelType *chanTypePtr;
+ Tcl_ChannelTypeVersion minimumVersion;
+{
+ Tcl_ChannelTypeVersion actualVersion = Tcl_ChannelVersion(chanTypePtr);
+
+ return ((int)actualVersion) >= ((int)minimumVersion);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ChannelBlockModeProc --
*
* Return the Tcl_DriverBlockModeProc of the channel type.
* Side effects:
* None.
*
- *----------------------------------------------------------------------
- */
+ *---------------------------------------------------------------------- */
Tcl_DriverBlockModeProc *
Tcl_ChannelBlockModeProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) {
- return (chanTypePtr->blockModeProc);
+ if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
+ return chanTypePtr->blockModeProc;
} else {
+ /*
+ * The v1 structure had the blockModeProc in a different place.
+ */
return (Tcl_DriverBlockModeProc *) (chanTypePtr->version);
}
}
Tcl_ChannelCloseProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->closeProc);
+ return chanTypePtr->closeProc;
}
\f
/*
Tcl_ChannelClose2Proc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->close2Proc);
+ return chanTypePtr->close2Proc;
}
\f
/*
Tcl_ChannelInputProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->inputProc);
+ return chanTypePtr->inputProc;
}
\f
/*
Tcl_ChannelOutputProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->outputProc);
+ return chanTypePtr->outputProc;
}
\f
/*
Tcl_ChannelSeekProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->seekProc);
+ return chanTypePtr->seekProc;
}
\f
/*
Tcl_ChannelSetOptionProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->setOptionProc);
+ return chanTypePtr->setOptionProc;
}
\f
/*
Tcl_ChannelGetOptionProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->getOptionProc);
+ return chanTypePtr->getOptionProc;
}
\f
/*
Tcl_ChannelWatchProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->watchProc);
+ return chanTypePtr->watchProc;
}
\f
/*
Tcl_ChannelGetHandleProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->getHandleProc);
+ return chanTypePtr->getHandleProc;
}
\f
/*
Tcl_ChannelFlushProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->flushProc);
+ if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
+ return chanTypePtr->flushProc;
+ } else {
+ return NULL;
+ }
}
\f
/*
Tcl_ChannelHandlerProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
- return (chanTypePtr->handlerProc);
+ if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_2)) {
+ return chanTypePtr->handlerProc;
+ } else {
+ return NULL;
+ }
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ChannelWideSeekProc --
+ *
+ * Return the Tcl_DriverWideSeekProc of the channel type.
+ *
+ * Results:
+ * A pointer to the proc.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_DriverWideSeekProc *
+Tcl_ChannelWideSeekProc(chanTypePtr)
+ Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
+{
+ if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) {
+ return chanTypePtr->wideSeekProc;
+ } else {
+ return NULL;
+ }
+}
*/
typedef struct ChannelState {
- char *channelName; /* The name of the channel instance in Tcl
+ CONST char *channelName; /* The name of the channel instance in Tcl
* commands. Storage is owned by the generic IO
* code, is dynamically allocated. */
int flags; /* ORed combination of the flags defined
* data bytes. May be TCL_ENCODING_START
* before converting first byte and
* TCL_ENCODING_END when EOF is seen. */
- Tcl_EolTranslation inputTranslation;
+ TclEolTranslation inputTranslation;
/* What translation to apply for end of line
* sequences on input? */
- Tcl_EolTranslation outputTranslation;
+ TclEolTranslation outputTranslation;
/* What translation to use for generating
* end of line sequences in output? */
int inEofChar; /* If nonzero, use this as a signal of EOF
* long as the channel state. Never NULL. */
struct ChannelState *nextCSPtr;
/* Next in list of channels currently open. */
+ Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing
+ * this stack of channels. */
} ChannelState;
/*
* the state of the channel changes. */
#define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is
* being used. */
+#define CHANNEL_TIMER_FEV (1<<17) /* When set the event we are
+ * notified by is a fileevent
+ * generated by a timer. We
+ * don't know if the driver
+ * has more data and should
+ * not try to read from it. If
+ * the system needs more than
+ * is in the buffers out read
+ * routines will simulate a
+ * short read (0 characters
+ * read) */
/*
* For each channel handler registered in a call to Tcl_CreateChannelHandler,
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to puts on. */
- int i; /* Counter. */
+ Tcl_Obj *string; /* String to write. */
int newline; /* Add a newline at end? */
char *channelId; /* Name of channel for puts. */
int result; /* Result of puts operation. */
int mode; /* Mode in which channel is opened. */
- char *arg;
- int length;
- i = 1;
- newline = 1;
- if ((objc >= 2) && (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0)) {
- newline = 0;
- i++;
- }
- if ((i < (objc-3)) || (i >= objc)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
- return TCL_ERROR;
- }
+ switch (objc) {
+ case 2: /* puts $x */
+ string = objv[1];
+ newline = 1;
+ channelId = "stdout";
+ break;
- /*
- * The code below provides backwards compatibility with an old
- * form of the command that is no longer recommended or documented.
- */
+ case 3: /* puts -nonewline $x or puts $chan $x */
+ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
+ newline = 0;
+ channelId = "stdout";
+ } else {
+ newline = 1;
+ channelId = Tcl_GetString(objv[1]);
+ }
+ string = objv[2];
+ break;
- if (i == (objc-3)) {
- arg = Tcl_GetStringFromObj(objv[i + 2], &length);
- if (strncmp(arg, "nonewline", (size_t) length) != 0) {
- Tcl_AppendResult(interp, "bad argument \"", arg,
- "\": should be \"nonewline\"", (char *) NULL);
- return TCL_ERROR;
+ case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */
+ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
+ channelId = Tcl_GetString(objv[2]);
+ string = objv[3];
+ } else {
+ /*
+ * The code below provides backwards compatibility with an
+ * old form of the command that is no longer recommended
+ * or documented.
+ */
+
+ char *arg;
+ int length;
+
+ arg = Tcl_GetStringFromObj(objv[3], &length);
+ if (strncmp(arg, "nonewline", (size_t) length) != 0) {
+ Tcl_AppendResult(interp, "bad argument \"", arg,
+ "\": should be \"nonewline\"",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ channelId = Tcl_GetString(objv[1]);
+ string = objv[2];
}
newline = 0;
+ break;
+
+ default: /* puts or puts some bad number of arguments... */
+ Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
+ return TCL_ERROR;
}
- if (i == (objc - 1)) {
- channelId = "stdout";
- } else {
- channelId = Tcl_GetString(objv[i]);
- i++;
- }
+
chan = Tcl_GetChannel(interp, channelId, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
return TCL_ERROR;
}
- result = Tcl_WriteObj(chan, objv[i]);
+ result = Tcl_WriteObj(chan, string);
if (result < 0) {
goto error;
}
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
- linePtr = resultPtr;
- if (objc == 3) {
- /*
- * Variable gets line, interp get bytecount.
- */
-
- linePtr = Tcl_NewObj();
- }
+ linePtr = Tcl_NewObj();
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
- if (linePtr != resultPtr) {
- Tcl_DecrRefCount(linePtr);
- }
+ Tcl_DecrRefCount(linePtr);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"", name, "\": ",
Tcl_PosixError(interp), (char *) NULL);
Tcl_DecrRefCount(linePtr);
return TCL_ERROR;
}
+ resultPtr = Tcl_GetObjResult(interp);
Tcl_SetIntObj(resultPtr, lineLen);
return TCL_OK;
+ } else {
+ Tcl_SetObjResult(interp, linePtr);
}
return TCL_OK;
}
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
- int offset, mode; /* Where to seek? */
- int result; /* Of calling Tcl_Seek. */
+ Tcl_WideInt offset; /* Where to seek? */
+ int mode; /* How to seek? */
+ Tcl_WideInt result; /* Of calling Tcl_Seek. */
char *chanName;
int optionIndex;
- static char *originOptions[] = {"start", "current", "end", (char *) NULL};
+ static CONST char *originOptions[] = {
+ "start", "current", "end", (char *) NULL
+ };
static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- if (Tcl_GetIntFromObj(interp, objv[2], &offset) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
return TCL_ERROR;
}
mode = SEEK_SET;
}
result = Tcl_Seek(chan, offset, mode);
- if (result == -1) {
+ if (result == Tcl_LongAsWide(-1)) {
Tcl_AppendResult(interp, "error during seek on \"",
chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan));
+ Tcl_SetWideIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan));
return TCL_OK;
}
\f
#define NUM_ARGS 20
Tcl_Obj *resultPtr;
- char **argv;
+ CONST char **argv;
char *string;
Tcl_Channel chan;
- char *argStorage[NUM_ARGS];
+ CONST char *argStorage[NUM_ARGS];
int argc, background, i, index, keepNewline, result, skip, length;
- static char *options[] = {
+ static CONST char *options[] = {
"-keepnewline", "--", NULL
};
enum options {
argv = argStorage;
argc = objc - skip;
if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
- argv = (char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
+ argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
}
/*
*/
if (!pipeline) {
- chan = Tcl_OpenFileChannel(interp, what, modeString, prot);
+ chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot);
} else {
#ifdef MAC_TCL
Tcl_AppendResult(interp,
return TCL_ERROR;
#else
int mode, seekFlag, cmdObjc;
- char **cmdArgv;
+ CONST char **cmdArgv;
if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
return TCL_ERROR;
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- static char *socketOptions[] = {
+ static CONST char *socketOptions[] = {
"-async", "-myaddr", "-myport","-server", (char *) NULL
};
enum socketOptions {
int mode, i;
int toRead, index;
Tcl_Obj *cmdPtr;
- static char* switches[] = { "-size", "-command", NULL };
+ static CONST char* switches[] = { "-size", "-command", NULL };
enum { FcopySize, FcopyCommand };
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
ClientData instanceData,
char* buf, int toRead, int* errorCodePtr));
static int TransformOutputProc _ANSI_ARGS_ ((
- ClientData instanceData,
- char* buf, int toWrite, int* errorCodePtr));
+ ClientData instanceData, CONST char *buf,
+ int toWrite, int* errorCodePtr));
static int TransformSeekProc _ANSI_ARGS_ ((
ClientData instanceData, long offset,
int mode, int* errorCodePtr));
static int TransformSetOptionProc _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
- char *optionName, char *value));
+ CONST char *optionName, CONST char *value));
static int TransformGetOptionProc _ANSI_ARGS_((
ClientData instanceData, Tcl_Interp *interp,
- char *optionName, Tcl_DString *dsPtr));
+ CONST char *optionName, Tcl_DString *dsPtr));
static void TransformWatchProc _ANSI_ARGS_ ((
ClientData instanceData, int mask));
static int TransformGetFileHandleProc _ANSI_ARGS_ ((
ClientData* handlePtr));
static int TransformNotifyProc _ANSI_ARGS_ ((
ClientData instanceData, int mask));
+static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_ ((
+ ClientData instanceData, Tcl_WideInt offset,
+ int mode, int* errorCodePtr));
/*
* Forward declarations of internal procedures.
TransformBlockModeProc, /* Set blocking/nonblocking mode.*/
NULL, /* Flush proc. */
TransformNotifyProc, /* Handling of events bubbling up */
+ TransformWideSeekProc, /* Wide seek proc */
};
/*
struct ResultBuffer {
unsigned char* buf; /* Reference to the buffer area */
- int allocated; /* Allocated size of the buffer area */
- int used; /* Number of bytes in the buffer, <= allocated */
+ int allocated; /* Allocated size of the buffer area */
+ int used; /* Number of bytes in the buffer, <= allocated */
};
/*
* out information waiting in buffers (fileevent support).
*/
-#define DELAY (5)
+#define FLUSH_DELAY (5)
/*
* Convenience macro to make some casts easier to use.
static int
ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve)
- TransformChannelData* dataPtr; /* Transformation with the callback */
+ TransformChannelData* dataPtr; /* Transformation with the callback */
Tcl_Interp* interp; /* Current interpreter, possibly NULL */
unsigned char* op; /* Operation invoking the callback */
unsigned char* buf; /* Buffer to give to the script. */
- int bufLen; /* Ands its length */
+ int bufLen; /* Ands its length */
int transmit; /* Flag, determines whether the result
* of the callback is sent to the
* underlying channel or not. */
* arguments. Feather's curried commands would come in handy here.
*/
- Tcl_Obj* resObj; /* See below, switch (transmit) */
- int resLen;
- unsigned char* resBuf;
+ Tcl_Obj* resObj; /* See below, switch (transmit) */
+ int resLen;
+ unsigned char* resBuf;
Tcl_SavedResult ciSave;
-
int res = TCL_OK;
Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command);
Tcl_Obj* temp;
-
if (preserve) {
Tcl_SaveResult (dataPtr->interp, &ciSave);
}
TransformInputProc (instanceData, buf, toRead, errorCodePtr)
ClientData instanceData;
char* buf;
- int toRead;
+ int toRead;
int* errorCodePtr;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
*/
res = ExecuteCallback (dataPtr, NO_INTERP, A_READ,
- UCHARP (buf), read, TRANSMIT_IBUF,
- P_PRESERVE);
+ UCHARP (buf), read, TRANSMIT_IBUF, P_PRESERVE);
if (res != TCL_OK) {
*errorCodePtr = EINVAL;
static int
TransformOutputProc (instanceData, buf, toWrite, errorCodePtr)
ClientData instanceData;
- char* buf;
+ CONST char* buf;
int toWrite;
int* errorCodePtr;
{
static int
TransformSeekProc (instanceData, offset, mode, errorCodePtr)
- ClientData instanceData; /* The channel to manipulate */
- long offset; /* Size of movement. */
- int mode; /* How to move */
- int* errorCodePtr; /* Location of error flag. */
+ ClientData instanceData; /* The channel to manipulate */
+ long offset; /* Size of movement. */
+ int mode; /* How to move */
+ int* errorCodePtr; /* Location of error flag. */
{
- int result;
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
Tcl_ChannelType* parentType = Tcl_GetChannelType(parent);
* location. Simply pass the request down.
*/
- result = (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
+ return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
offset, mode, errorCodePtr);
- return result;
}
/*
dataPtr->readIsFlushed = 0;
}
- result = (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
+ return (*parentSeekProc) (Tcl_GetChannelInstanceData(parent),
offset, mode, errorCodePtr);
- return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TransformWideSeekProc --
+ *
+ * This procedure is called by the generic IO level to move the
+ * access point in a channel, with a (potentially) 64-bit offset.
+ *
+ * Side effects:
+ * Moves the location at which the channel will be accessed in
+ * future operations. Flushes all transformation buffers, then
+ * forwards it to the underlying channel.
+ *
+ * Result:
+ * -1 if failed, the new position if successful. An output
+ * argument contains the POSIX error code if an error occurred,
+ * or zero.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+TransformWideSeekProc (instanceData, offset, mode, errorCodePtr)
+ ClientData instanceData; /* The channel to manipulate */
+ Tcl_WideInt offset; /* Size of movement. */
+ int mode; /* How to move */
+ int* errorCodePtr; /* Location of error flag. */
+{
+ TransformChannelData* dataPtr =
+ (TransformChannelData*) instanceData;
+ Tcl_Channel parent =
+ Tcl_GetStackedChannel(dataPtr->self);
+ Tcl_ChannelType* parentType =
+ Tcl_GetChannelType(parent);
+ Tcl_DriverSeekProc* parentSeekProc =
+ Tcl_ChannelSeekProc(parentType);
+ Tcl_DriverWideSeekProc* parentWideSeekProc =
+ Tcl_ChannelWideSeekProc(parentType);
+ ClientData parentData =
+ Tcl_GetChannelInstanceData(parent);
+
+ if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) {
+ /*
+ * This is no seek but a request to tell the caller the current
+ * location. Simply pass the request down.
+ */
+
+ if (parentWideSeekProc != NULL) {
+ return (*parentWideSeekProc) (parentData, offset, mode,
+ errorCodePtr);
+ }
+
+ return Tcl_LongAsWide((*parentSeekProc) (parentData, 0, mode,
+ errorCodePtr));
+ }
+
+ /*
+ * It is a real request to change the position. Flush all data waiting
+ * for output and discard everything in the input buffers. Then pass
+ * the request down, unchanged.
+ */
+
+ if (dataPtr->mode & TCL_WRITABLE) {
+ ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE,
+ NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE);
+ }
+
+ if (dataPtr->mode & TCL_READABLE) {
+ ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ,
+ NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE);
+ ResultClear(&dataPtr->result);
+ dataPtr->readIsFlushed = 0;
+ }
+
+ /*
+ * If we have a wide seek capability, we should stick with that.
+ */
+ if (parentWideSeekProc != NULL) {
+ return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr);
+ }
+
+ /*
+ * We're transferring to narrow seeks at this point; this is a bit
+ * complex because we have to check whether the seek is possible
+ * first (i.e. whether we are losing information in truncating the
+ * bits of the offset.) Luckily, there's a defined error for what
+ * happens when trying to go out of the representable range.
+ */
+ if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) {
+ *errorCodePtr = EOVERFLOW;
+ return Tcl_LongAsWide(-1);
+ }
+ return Tcl_LongAsWide((*parentSeekProc) (parentData,
+ Tcl_WideAsLong(offset), mode, errorCodePtr));
}
\f
/*
TransformSetOptionProc (instanceData, interp, optionName, value)
ClientData instanceData;
Tcl_Interp *interp;
- char *optionName;
- char *value;
+ CONST char *optionName;
+ CONST char *value;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
TransformGetOptionProc (instanceData, interp, optionName, dsPtr)
ClientData instanceData;
Tcl_Interp* interp;
- char* optionName;
+ CONST char* optionName;
Tcl_DString* dsPtr;
{
TransformChannelData* dataPtr = (TransformChannelData*) instanceData;
if (getOptionProc != NULL) {
return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan),
interp, optionName, dsPtr);
- } else if (optionName == (char*) NULL) {
+ } else if (optionName == (CONST char*) NULL) {
/*
* Request is query for all options, this is ok.
*/
* to flush that.
*/
- dataPtr->timer = Tcl_CreateTimerHandler (DELAY,
+ dataPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY,
TransformChannelHandlerTimer, (ClientData) dataPtr);
}
}
ResultCopy (r, buf, toRead)
ResultBuffer* r; /* The buffer to read from */
unsigned char* buf; /* The buffer to copy into */
- int toRead; /* Number of requested bytes */
+ int toRead; /* Number of requested bytes */
{
if (r->used == 0) {
/* Nothing to copy in the case of an empty buffer.
ResultAdd (r, buf, toWrite)
ResultBuffer* r; /* The buffer to extend */
unsigned char* buf; /* The buffer to read from */
- int toWrite; /* The number of bytes in 'buf' */
+ int toWrite; /* The number of bytes in 'buf' */
{
if ((r->used + toWrite) > r->allocated) {
/* Extension of the internal buffer is required.
{
struct servent *sp; /* Protocol info for named services */
Tcl_DString ds;
- char *native;
+ CONST char *native;
if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
/*
int size; /* Minimum buffer size */
{
int current;
- /*
- * Should be socklen_t, but HP10.20 (g)cc chokes
- */
- size_t len;
+ socklen_t len;
len = sizeof(int);
getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len);
}
return TCL_OK;
}
-
/*
* tclIOUtil.c --
*
- * This file contains a collection of utility procedures that
- * are shared by the platform specific IO drivers.
+ * This file contains the implementation of Tcl's generic
+ * filesystem code, which supports a pluggable filesystem
+ * architecture allowing both platform specific filesystems and
+ * 'virtual filesystems'. All filesystem access should go through
+ * the functions defined in this file. Most of this code was
+ * contributed by Vince Darley.
*
* Parts of this file are based on code contributed by Karl
* Lehenbauer, Mark Diekhans and Peter da Silva.
#include "tclInt.h"
#include "tclPort.h"
+#ifdef MAC_TCL
+#include "tclMacInt.h"
+#endif
+#ifdef __WIN32__
+/* for tclWinProcs->useWide */
+#include "tclWinInt.h"
+#endif
+
+/*
+ * Prototypes for procedures defined later in this file.
+ */
+
+static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
+static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static Tcl_Obj* FSNormalizeAbsolutePath
+ _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));
+static int TclNormalizeToUniquePath
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr));
+static int SetFsPathFromAbsoluteNormalized
+ _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr));
+static int FindSplitPos _ANSI_ARGS_((char *path, char *separator));
+static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+ Tcl_Filesystem **filesystemPtrPtr,
+ int *driveNameLengthPtr));
+static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+ Tcl_Filesystem **filesystemPtrPtr,
+ int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
+
+/*
+ * Define the 'path' object type, which Tcl uses to represent
+ * file paths internally.
+ */
+Tcl_ObjType tclFsPathType = {
+ "path", /* name */
+ FreeFsPathInternalRep, /* freeIntRepProc */
+ DupFsPathInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetFsPathFromAny /* setFromAnyProc */
+};
+
+/*
+ * These form part of the native filesystem support. They are needed
+ * here because we have a few native filesystem functions (which are
+ * the same for mac/win/unix) in this file. There is no need to place
+ * them in tclInt.h, because they are not (and should not be) used
+ * anywhere else.
+ */
+extern CONST char * tclpFileAttrStrings[];
+extern CONST TclFileAttrProcs tclpFileAttrProcs[];
+
+/*
+ * The following functions are obsolete string based APIs, and should
+ * be removed in a future release (Tcl 9 would be a good time).
+ */
+\f
+/* Obsolete */
+int
+Tcl_Stat(path, oldStyleBuf)
+ CONST char *path; /* Path of file to stat (in current CP). */
+ struct stat *oldStyleBuf; /* Filled with results of stat call. */
+{
+ int ret;
+ Tcl_StatBuf buf;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSStat(pathPtr, &buf);
+ Tcl_DecrRefCount(pathPtr);
+ if (ret != -1) {
+#ifndef TCL_WIDE_INT_IS_LONG
+# define OUT_OF_RANGE(x) \
+ (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
+ ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
+# define OUT_OF_URANGE(x) \
+ (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
+
+ /*
+ * Perform the result-buffer overflow check manually.
+ *
+ * Note that ino_t/ino64_t is unsigned...
+ */
+
+ if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size)
+#ifdef HAVE_ST_BLOCKS
+ || OUT_OF_RANGE(buf.st_blocks)
+#endif
+ ) {
+#ifdef EFBIG
+ errno = EFBIG;
+#else
+# ifdef EOVERFLOW
+ errno = EOVERFLOW;
+# else
+# error "What status should be returned for file size out of range?"
+# endif
+#endif
+ return -1;
+ }
+
+# undef OUT_OF_RANGE
+# undef OUT_OF_URANGE
+#endif /* !TCL_WIDE_INT_IS_LONG */
+
+ /*
+ * Copy across all supported fields, with possible type
+ * coercions on those fields that change between the normal
+ * and lf64 versions of the stat structure (on Solaris at
+ * least.) This is slow when the structure sizes coincide,
+ * but that's what you get for using an obsolete interface.
+ */
+
+ oldStyleBuf->st_mode = buf.st_mode;
+ oldStyleBuf->st_ino = (ino_t) buf.st_ino;
+ oldStyleBuf->st_dev = buf.st_dev;
+ oldStyleBuf->st_rdev = buf.st_rdev;
+ oldStyleBuf->st_nlink = buf.st_nlink;
+ oldStyleBuf->st_uid = buf.st_uid;
+ oldStyleBuf->st_gid = buf.st_gid;
+ oldStyleBuf->st_size = (off_t) buf.st_size;
+ oldStyleBuf->st_atime = buf.st_atime;
+ oldStyleBuf->st_mtime = buf.st_mtime;
+ oldStyleBuf->st_ctime = buf.st_ctime;
+#ifdef HAVE_ST_BLOCKS
+ oldStyleBuf->st_blksize = buf.st_blksize;
+ oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks;
+#endif
+ }
+ return ret;
+}
+\f
+/* Obsolete */
+int
+Tcl_Access(path, mode)
+ CONST char *path; /* Path of file to access (in current CP). */
+ int mode; /* Permission setting. */
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSAccess(pathPtr,mode);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
+\f
+/* Obsolete */
+Tcl_Channel
+Tcl_OpenFileChannel(interp, path, modeString, permissions)
+ Tcl_Interp *interp; /* Interpreter for error reporting;
+ * can be NULL. */
+ CONST char *path; /* Name of file to open. */
+ CONST char *modeString; /* A list of POSIX open modes or
+ * a string such as "rw". */
+ int permissions; /* If the open involves creating a
+ * file, with what modes to create
+ * it? */
+{
+ Tcl_Channel ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+
+}
+\f
+/* Obsolete */
+int
+Tcl_Chdir(dirName)
+ CONST char *dirName;
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSChdir(pathPtr);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
+\f
+/* Obsolete */
+char *
+Tcl_GetCwd(interp, cwdPtr)
+ Tcl_Interp *interp;
+ Tcl_DString *cwdPtr;
+{
+ Tcl_Obj *cwd;
+ cwd = Tcl_FSGetCwd(interp);
+ if (cwd == NULL) {
+ return NULL;
+ } else {
+ Tcl_DStringInit(cwdPtr);
+ Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
+ Tcl_DecrRefCount(cwd);
+ return Tcl_DStringValue(cwdPtr);
+ }
+}
+\f
+/* Obsolete */
+int
+Tcl_EvalFile(interp, fileName)
+ Tcl_Interp *interp; /* Interpreter in which to process file. */
+ CONST char *fileName; /* Name of file to process. Tilde-substitution
+ * will be performed on this name. */
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = Tcl_FSEvalFile(interp, pathPtr);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
+\f
+
+/*
+ * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The
+ * complete, general hooked filesystem APIs should be used instead.
+ * This define decides whether to include the obsolete hooks and
+ * related code. If these are removed, we'll also want to remove them
+ * from stubs/tclInt. The only known users of these APIs are prowrap
+ * and mktclapp. New code/extensions should not use them, since they
+ * do not provide as full support as the full filesystem API.
+ *
+ * As soon as prowrap and mktclapp are updated to use the full
+ * filesystem support, I suggest all these hooks are removed.
+ */
+#define USE_OBSOLETE_FS_HOOKS
+
\f
+#ifdef USE_OBSOLETE_FS_HOOKS
/*
* The following typedef declarations allow for hooking into the chain
* of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
} OpenFileChannelProc;
/*
- * For each type of hookable function, a static node is declared to
- * hold the function pointer for the "built-in" routine (e.g.
- * 'TclpStat(...)') and the respective list is initialized as a pointer
- * to that node.
+ * For each type of (obsolete) hookable function, a static node is
+ * declared to hold the function pointer for the "built-in" routine
+ * (e.g. 'TclpStat(...)') and the respective list is initialized as a
+ * pointer to that node.
*
* The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
* these statically declared list entry cannot be inadvertently removed.
* This method avoids the need to call any sort of "initialization"
* function.
*
- * All three lists are protected by a global hookMutex.
+ * All three lists are protected by a global obsoleteFsHookMutex.
*/
-static StatProc defaultStatProc = {
- &TclpStat, NULL
-};
-static StatProc *statProcList = &defaultStatProc;
+static StatProc *statProcList = NULL;
+static AccessProc *accessProcList = NULL;
+static OpenFileChannelProc *openFileChannelProcList = NULL;
+
+TCL_DECLARE_MUTEX(obsoleteFsHookMutex)
+
+#endif /* USE_OBSOLETE_FS_HOOKS */
+
+/*
+ * A filesystem record is used to keep track of each
+ * filesystem currently registered with the core,
+ * in a linked list.
+ */
+typedef struct FilesystemRecord {
+ ClientData clientData; /* Client specific data for the new
+ * filesystem (can be NULL) */
+ Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch
+ * table. */
+ int fileRefCount; /* How many Tcl_Obj's use this
+ * filesystem. */
+ struct FilesystemRecord *nextPtr;
+ /* The next filesystem registered
+ * to Tcl, or NULL if no more. */
+} FilesystemRecord;
+
+static FilesystemRecord* GetFilesystemRecord
+ _ANSI_ARGS_((Tcl_Filesystem *fromFilesystem, int *epoch));
-static AccessProc defaultAccessProc = {
- &TclpAccess, NULL
+/*
+ * Declare the native filesystem support. These functions should
+ * be considered private to Tcl, and should really not be called
+ * directly by any code other than this file (i.e. neither by
+ * Tcl's core nor by extensions). Similarly, the old string-based
+ * Tclp... native filesystem functions should not be called.
+ *
+ * The correct API to use now is the Tcl_FS... set of functions,
+ * which ensure correct and complete virtual filesystem support.
+ *
+ * We cannot make all of these static, since some of them
+ * are implemented in the platform-specific directories.
+ */
+static Tcl_FSPathInFilesystemProc NativePathInFilesystem;
+static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
+static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
+static Tcl_FSDupInternalRepProc NativeDupInternalRep;
+static Tcl_FSCreateInternalRepProc NativeCreateNativeRep;
+static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
+static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
+static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
+static Tcl_FSUtimeProc NativeUtime;
+
+/*
+ * The only reason these functions are not static is that they
+ * are either called by code in the native (win/unix/mac) directories
+ * or they are actually implemented in those directories. They
+ * should simply not be called by code outside Tcl's native
+ * filesystem core. i.e. they should be considered 'static' to
+ * Tcl's filesystem code (if we ever built the native filesystem
+ * support into a separate code library, this could actually be
+ * enforced).
+ */
+Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
+Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
+Tcl_FSStatProc TclpObjStat;
+Tcl_FSAccessProc TclpObjAccess;
+Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
+Tcl_FSGetCwdProc TclpObjGetCwd;
+Tcl_FSChdirProc TclpObjChdir;
+Tcl_FSLstatProc TclpObjLstat;
+Tcl_FSCopyFileProc TclpObjCopyFile;
+Tcl_FSDeleteFileProc TclpObjDeleteFile;
+Tcl_FSRenameFileProc TclpObjRenameFile;
+Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
+Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
+Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
+Tcl_FSUnloadFileProc TclpUnloadFile;
+Tcl_FSLinkProc TclpObjLink;
+Tcl_FSListVolumesProc TclpObjListVolumes;
+
+/*
+ * Define the native filesystem dispatch table. If necessary, it
+ * is ok to make this non-static, but it should only be accessed
+ * by the functions actually listed within it (or perhaps other
+ * helper functions of them). Anything which is not part of this
+ * 'native filesystem implementation' should not be delving inside
+ * here!
+ */
+static Tcl_Filesystem tclNativeFilesystem = {
+ "native",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_1,
+ &NativePathInFilesystem,
+ &NativeDupInternalRep,
+ &NativeFreeInternalRep,
+ &TclpNativeToNormalized,
+ &NativeCreateNativeRep,
+ &TclpObjNormalizePath,
+ &TclpFilesystemPathType,
+ &NativeFilesystemSeparator,
+ &TclpObjStat,
+ &TclpObjAccess,
+ &TclpOpenFileChannel,
+ &TclpMatchInDirectory,
+ &NativeUtime,
+#ifndef S_IFLNK
+ NULL,
+#else
+ &TclpObjLink,
+#endif /* S_IFLNK */
+ &TclpObjListVolumes,
+ &NativeFileAttrStrings,
+ &NativeFileAttrsGet,
+ &NativeFileAttrsSet,
+ &TclpObjCreateDirectory,
+ &TclpObjRemoveDirectory,
+ &TclpObjDeleteFile,
+ &TclpObjCopyFile,
+ &TclpObjRenameFile,
+ &TclpObjCopyDirectory,
+ &TclpObjLstat,
+ &TclpDlopen,
+ &TclpObjGetCwd,
+ &TclpObjChdir
};
-static AccessProc *accessProcList = &defaultAccessProc;
-static OpenFileChannelProc defaultOpenFileChannelProc = {
- &TclpOpenFileChannel, NULL
+/*
+ * Define the tail of the linked list. Note that for unconventional
+ * uses of Tcl without a native filesystem, we may in the future wish
+ * to modify the current approach of hard-coding the native filesystem
+ * in the lookup list 'filesystemList' below.
+ *
+ * We initialize the record so that it thinks one file uses it. This
+ * means it will never be freed.
+ */
+static FilesystemRecord nativeFilesystemRecord = {
+ NULL,
+ &tclNativeFilesystem,
+ 1,
+ NULL
};
-static OpenFileChannelProc *openFileChannelProcList =
- &defaultOpenFileChannelProc;
-TCL_DECLARE_MUTEX(hookMutex)
+/*
+ * The following few variables are protected by the
+ * filesystemMutex just below.
+ */
+
+/*
+ * This is incremented each time we modify the linked list of
+ * filesystems. Any time it changes, all cached filesystem
+ * representations are suspect and must be freed.
+ */
+static int theFilesystemEpoch = 0;
+
+/*
+ * Stores the linked list of filesystems.
+ */
+static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
+
+/*
+ * The number of loops which are currently iterating over the linked
+ * list. If this is greater than zero, we can't modify the list.
+ */
+static int filesystemIteratorsInProgress = 0;
+
+/*
+ * Someone wants to modify the list of filesystems if this is set.
+ */
+static int filesystemWantToModify = 0;
+
+#ifdef TCL_THREADS
+static Tcl_Condition filesystemOkToModify = NULL;
+#endif
+
+TCL_DECLARE_MUTEX(filesystemMutex)
+
+/*
+ * struct FsPath --
+ *
+ * Internal representation of a Tcl_Obj of "path" type. This
+ * can be used to represent relative or absolute paths, and has
+ * certain optimisations when used to represent paths which are
+ * already normalized and absolute.
+ *
+ * Note that 'normPathPtr' can be a circular reference to the
+ * container Tcl_Obj of this FsPath.
+ */
+typedef struct FsPath {
+ Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
+ * If this is NULL, then this is a
+ * pure normalized, absolute path
+ * object, in which the parent Tcl_Obj's
+ * string rep is already both translated
+ * and normalized. */
+ Tcl_Obj *normPathPtr; /* Normalized absolute path, without
+ * ., .. or ~user sequences. If the
+ * Tcl_Obj containing
+ * this FsPath is already normalized,
+ * this may be a circular reference back
+ * to the container. If that is NOT the
+ * case, we have a refCount on the object. */
+ Tcl_Obj *cwdPtr; /* If null, path is absolute, else
+ * this points to the cwd object used
+ * for this path. We have a refCount
+ * on the object. */
+ ClientData nativePathPtr; /* Native representation of this path,
+ * which is filesystem dependent. */
+ int filesystemEpoch; /* Used to ensure the path representation
+ * was generated during the correct
+ * filesystem epoch. The epoch changes
+ * when filesystem-mounts are changed. */
+ struct FilesystemRecord *fsRecPtr;
+ /* Pointer to the filesystem record
+ * entry to use for this path. */
+} FsPath;
+
+/*
+ * Used to implement Tcl_FSGetCwd in a file-system independent way.
+ * This is protected by the cwdMutex below.
+ */
+static Tcl_Obj* cwdPathPtr = NULL;
+TCL_DECLARE_MUTEX(cwdMutex)
+
+/*
+ * Declare fallback support function and
+ * information for Tcl_FSLoadFile
+ */
+static Tcl_FSUnloadFileProc FSUnloadTempFile;
+
+/*
+ * One of these structures is used each time we successfully load a
+ * file from a file system by way of making a temporary copy of the
+ * file on the native filesystem. We need to store both the actual
+ * unloadProc/clientData combination which was used, and the original
+ * and modified filenames, so that we can correctly undo the entire
+ * operation when we want to unload the code.
+ */
+typedef struct FsDivertLoad {
+ Tcl_LoadHandle loadHandle;
+ Tcl_FSUnloadFileProc *unloadProcPtr;
+ Tcl_Obj *divertedFile;
+ Tcl_Filesystem *divertedFilesystem;
+ ClientData divertedFileNativeRep;
+} FsDivertLoad;
+
+/* Now move on to the basic filesystem implementation */
+
+\f
+static int
+FsCwdPointerEquals(objPtr)
+ Tcl_Obj* objPtr;
+{
+ Tcl_MutexLock(&cwdMutex);
+ if (cwdPathPtr == objPtr) {
+ Tcl_MutexUnlock(&cwdMutex);
+ return 1;
+ } else {
+ Tcl_MutexUnlock(&cwdMutex);
+ return 0;
+ }
+}
+
+\f
+static FilesystemRecord*
+FsGetIterator(void) {
+ Tcl_MutexLock(&filesystemMutex);
+ filesystemIteratorsInProgress++;
+ Tcl_MutexUnlock(&filesystemMutex);
+ /* Now we know the list of filesystems cannot be modified */
+ return filesystemList;
+}
+\f
+static void
+FsReleaseIterator(void) {
+ Tcl_MutexLock(&filesystemMutex);
+ filesystemIteratorsInProgress--;
+ if (filesystemIteratorsInProgress == 0) {
+ /* Notify any waiting threads that things are ok now */
+ if (filesystemWantToModify > 0) {
+ Tcl_ConditionNotify(&filesystemOkToModify);
+ }
+ }
+ Tcl_MutexUnlock(&filesystemMutex);
+}
\f
/*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
- * TclGetOpenMode --
+ * TclFinalizeFilesystem --
*
- * Description:
- * Computes a POSIX mode mask for opening a file, from a given string,
- * and also sets a flag to indicate whether the caller should seek to
- * EOF after opening the file.
+ * Clean up the filesystem. After this, calls to all Tcl_FS...
+ * functions will fail.
+ *
+ * Note that, since 'TclFinalizeLoad' may unload extensions
+ * which implement other filesystems, and which may therefore
+ * contain a 'freeProc' for those filesystems, at this stage
+ * we _must_ have freed all objects of "path" type, or we may
+ * end up with segfaults if we try to free them later.
*
* Results:
- * On success, returns mode to pass to "open". If an error occurs, the
- * return value is -1 and if interp is not NULL, sets interp's result
- * object to an error message.
+ * None.
*
* Side effects:
- * Sets the integer referenced by seekFlagPtr to 1 to tell the caller
- * to seek to EOF after opening the file.
- *
- * Special note:
- * This code is based on a prototype implementation contributed
- * by Mark Diekhans.
+ * Frees any memory allocated by the filesystem. Unloads any
+ * extensions which have been loaded.
*
- *---------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-int
-TclGetOpenMode(interp, string, seekFlagPtr)
- Tcl_Interp *interp; /* Interpreter to use for error
- * reporting - may be NULL. */
- char *string; /* Mode string, e.g. "r+" or
- * "RDONLY CREAT". */
- int *seekFlagPtr; /* Set this to 1 if the caller
- * should seek to EOF during the
- * opening of the file. */
-{
- int mode, modeArgc, c, i, gotRW;
- char **modeArgv, *flag;
-#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
-
- /*
- * Check for the simpler fopen-like access modes (e.g. "r"). They
- * are distinguished from the POSIX access modes by the presence
- * of a lower-case first letter.
+void
+TclFinalizeFilesystem() {
+ /*
+ * Assumption that only one thread is active now. Otherwise
+ * we would need to put various mutexes around this code.
*/
-
- *seekFlagPtr = 0;
- mode = 0;
+
+ if (cwdPathPtr != NULL) {
+ Tcl_DecrRefCount(cwdPathPtr);
+ cwdPathPtr = NULL;
+ }
/*
- * Guard against international characters before using byte oriented
- * routines.
+ * We defer unloading of packages until very late
+ * to avoid memory access issues. Both exit callbacks and
+ * synchronization variables may be stored in packages.
+ *
+ * Note that TclFinalizeLoad unloads packages in the reverse
+ * of the order they were loaded in (i.e. last to be loaded
+ * is the first to be unloaded). This can be important for
+ * correct unloading when dependencies exist.
*/
- if (!(string[0] & 0x80)
- && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
- switch (string[0]) {
- case 'r':
- mode = O_RDONLY;
- break;
- case 'w':
- mode = O_WRONLY|O_CREAT|O_TRUNC;
- break;
- case 'a':
- mode = O_WRONLY|O_CREAT;
- *seekFlagPtr = 1;
- break;
- default:
- error:
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp,
- "illegal access mode \"", string, "\"",
- (char *) NULL);
- }
- return -1;
+ TclFinalizeLoad();
+
+ /* Remove all filesystems, freeing any allocated memory */
+ while (filesystemList != NULL) {
+ FilesystemRecord *tmpFsRecPtr = filesystemList->nextPtr;
+ if (filesystemList->fileRefCount > 1) {
+ /*
+ * We are freeing a filesystem which actually has
+ * path objects still around which belong to it.
+ * This is probably bad, but since we are exiting,
+ * we don't do anything about it.
+ */
}
- if (string[1] == '+') {
- mode &= ~(O_RDONLY|O_WRONLY);
- mode |= O_RDWR;
- if (string[2] != 0) {
- goto error;
- }
- } else if (string[1] != 0) {
- goto error;
+ /* The native filesystem is static, so we don't free it */
+ if (filesystemList != &nativeFilesystemRecord) {
+ ckfree((char *)filesystemList);
}
- return mode;
+ filesystemList = tmpFsRecPtr;
+ }
+ /* Now filesystemList is NULL */
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSRegister --
+ *
+ * Insert the filesystem function table at the head of the list of
+ * functions which are used during calls to all file-system
+ * operations. The filesystem will be added even if it is
+ * already in the list. (You can use Tcl_FSData to
+ * check if it is in the list, provided the ClientData used was
+ * not NULL).
+ *
+ * Note that the filesystem handling is head-to-tail of the list.
+ * Each filesystem is asked in turn whether it can handle a
+ * particular request, _until_ one of them says 'yes'. At that
+ * point no further filesystems are asked.
+ *
+ * In particular this means if you want to add a diagnostic
+ * filesystem (which simply reports all fs activity), it must be
+ * at the head of the list: i.e. it must be the last registered.
+ *
+ * Results:
+ * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
+ * could not be allocated.
+ *
+ * Side effects:
+ * Memory allocated and modifies the link list for filesystems.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSRegister(clientData, fsPtr)
+ ClientData clientData; /* Client specific data for this fs */
+ Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */
+{
+ FilesystemRecord *newFilesystemPtr;
+
+ if (fsPtr == NULL) {
+ return TCL_ERROR;
}
- /*
- * The access modes are specified using a list of POSIX modes
- * such as O_CREAT.
- *
- * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
- * a NULL interpreter is passed in.
+ newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
+
+ newFilesystemPtr->clientData = clientData;
+ newFilesystemPtr->fsPtr = fsPtr;
+ /*
+ * We start with a refCount of 1. If this drops to zero, then
+ * anyone is welcome to ckfree us.
*/
+ newFilesystemPtr->fileRefCount = 1;
- if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AddErrorInfo(interp,
- "\n while processing open access modes \"");
- Tcl_AddErrorInfo(interp, string);
- Tcl_AddErrorInfo(interp, "\"");
- }
- return -1;
+ /*
+ * Is this lock and wait strictly speaking necessary? Since any
+ * iterators out there will have grabbed a copy of the head of
+ * the list and be iterating away from that, if we add a new
+ * element to the head of the list, it can't possibly have any
+ * effect on any of their loops. In fact it could be better not
+ * to wait, since we are adjusting the filesystem epoch, any
+ * cached representations calculated by existing iterators are
+ * going to have to be thrown away anyway.
+ *
+ * However, since registering and unregistering filesystems is
+ * a very rare action, this is not a very important point.
+ */
+ Tcl_MutexLock(&filesystemMutex);
+ if (filesystemIteratorsInProgress) {
+ filesystemWantToModify++;
+ Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL);
+ filesystemWantToModify--;
}
-
- gotRW = 0;
- for (i = 0; i < modeArgc; i++) {
- flag = modeArgv[i];
- c = flag[0];
- if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
- mode = (mode & ~RW_MODES) | O_RDONLY;
- gotRW = 1;
- } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
- mode = (mode & ~RW_MODES) | O_WRONLY;
+
+ newFilesystemPtr->nextPtr = filesystemList;
+ filesystemList = newFilesystemPtr;
+ /*
+ * Increment the filesystem epoch counter, since existing paths
+ * might conceivably now belong to different filesystems.
+ */
+ theFilesystemEpoch++;
+ Tcl_MutexUnlock(&filesystemMutex);
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSUnregister --
+ *
+ * Remove the passed filesystem from the list of filesystem
+ * function tables. It also ensures that the built-in
+ * (native) filesystem is not removable, although we may wish
+ * to change that decision in the future to allow a smaller
+ * Tcl core, in which the native filesystem is not used at
+ * all (we could, say, initialise Tcl completely over a network
+ * connection).
+ *
+ * Results:
+ * TCL_OK if the procedure pointer was successfully removed,
+ * TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * Memory may be deallocated (or will be later, once no "path"
+ * objects refer to this filesystem), but the list of registered
+ * filesystems is updated immediately.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSUnregister(fsPtr)
+ Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */
+{
+ int retVal = TCL_ERROR;
+ FilesystemRecord *tmpFsRecPtr;
+ FilesystemRecord *prevFsRecPtr = NULL;
+
+ Tcl_MutexLock(&filesystemMutex);
+ if (filesystemIteratorsInProgress) {
+ filesystemWantToModify++;
+ Tcl_ConditionWait(&filesystemOkToModify, &filesystemMutex, NULL);
+ filesystemWantToModify--;
+ }
+ tmpFsRecPtr = filesystemList;
+ /*
+ * Traverse the 'filesystemList' looking for the particular node
+ * whose 'fsPtr' member matches 'fsPtr' and remove that one from
+ * the list. Ensure that the "default" node cannot be removed.
+ */
+
+ while ((retVal == TCL_ERROR) && (tmpFsRecPtr != &nativeFilesystemRecord)) {
+ if (tmpFsRecPtr->fsPtr == fsPtr) {
+ if (prevFsRecPtr == NULL) {
+ filesystemList = filesystemList->nextPtr;
+ } else {
+ prevFsRecPtr->nextPtr = tmpFsRecPtr->nextPtr;
+ }
+ /*
+ * Increment the filesystem epoch counter, since existing
+ * paths might conceivably now belong to different
+ * filesystems. This should also ensure that paths which
+ * have cached the filesystem which is about to be deleted
+ * do not reference that filesystem (which would of course
+ * lead to memory exceptions).
+ */
+ theFilesystemEpoch++;
+
+ tmpFsRecPtr->fileRefCount--;
+ if (tmpFsRecPtr->fileRefCount <= 0) {
+ ckfree((char *)tmpFsRecPtr);
+ }
+
+ retVal = TCL_OK;
+ } else {
+ prevFsRecPtr = tmpFsRecPtr;
+ tmpFsRecPtr = tmpFsRecPtr->nextPtr;
+ }
+ }
+
+ Tcl_MutexUnlock(&filesystemMutex);
+ return (retVal);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSMountsChanged --
+ *
+ * Notify the filesystem that the available mounted filesystems
+ * (or within any one filesystem type, the number or location of
+ * mount points) have changed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The global filesystem variable 'theFilesystemEpoch' is
+ * incremented. The effect of this is to make all cached
+ * path representations invalid. Clearly it should only therefore
+ * be called when it is really required! There are a few
+ * circumstances when it should be called:
+ *
+ * (1) when a new filesystem is registered or unregistered.
+ * Strictly speaking this is only necessary if the new filesystem
+ * accepts file paths as is (normally the filesystem itself is
+ * really a shell which hasn't yet had any mount points established
+ * and so its 'pathInFilesystem' proc will always fail). However,
+ * for safety, Tcl always calls this for you in these circumstances.
+ *
+ * (2) when additional mount points are established inside any
+ * existing filesystem (except the native fs)
+ *
+ * (3) when any filesystem (except the native fs) changes the list
+ * of available volumes.
+ *
+ * (4) when the mapping from a string representation of a file to
+ * a full, normalized path changes. For example, if 'env(HOME)'
+ * is modified, then any path containing '~' will map to a different
+ * filesystem location. Therefore all such paths need to have
+ * their internal representation invalidated.
+ *
+ * Tcl has no control over (2) and (3), so any registered filesystem
+ * must make sure it calls this function when those situations
+ * occur.
+ *
+ * (Note: the reason for the exception in 2,3 for the native
+ * filesystem is that the native filesystem by default claims all
+ * unknown files even if it really doesn't understand them or if
+ * they don't exist).
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FSMountsChanged(fsPtr)
+ Tcl_Filesystem *fsPtr;
+{
+ /*
+ * We currently don't do anything with this parameter. We
+ * could in the future only invalidate files for this filesystem
+ * or otherwise take more advanced action.
+ */
+ (void)fsPtr;
+ /*
+ * Increment the filesystem epoch counter, since existing paths
+ * might now belong to different filesystems.
+ */
+ Tcl_MutexLock(&filesystemMutex);
+ theFilesystemEpoch++;
+ Tcl_MutexUnlock(&filesystemMutex);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSData --
+ *
+ * Retrieve the clientData field for the filesystem given,
+ * or NULL if that filesystem is not registered.
+ *
+ * Results:
+ * A clientData value, or NULL. Note that if the filesystem
+ * was registered with a NULL clientData field, this function
+ * will return that NULL value.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_FSData(fsPtr)
+ Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
+{
+ ClientData retVal = NULL;
+ FilesystemRecord *tmpFsRecPtr;
+
+ tmpFsRecPtr = FsGetIterator();
+ /*
+ * Traverse the 'filesystemList' looking for the particular node
+ * whose 'fsPtr' member matches 'fsPtr' and remove that one from
+ * the list. Ensure that the "default" node cannot be removed.
+ */
+
+ while ((retVal == NULL) && (tmpFsRecPtr != NULL)) {
+ if (tmpFsRecPtr->fsPtr == fsPtr) {
+ retVal = tmpFsRecPtr->clientData;
+ }
+ tmpFsRecPtr = tmpFsRecPtr->nextPtr;
+ }
+
+ FsReleaseIterator();
+ return (retVal);
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * FSNormalizeAbsolutePath --
+ *
+ * Description:
+ * Takes an absolute path specification and computes a 'normalized'
+ * path from it.
+ *
+ * A normalized path is one which has all '../', './' removed.
+ * Also it is one which is in the 'standard' format for the native
+ * platform. On MacOS, Unix, this means the path must be free of
+ * symbolic links/aliases, and on Windows it means we want the
+ * long form, with that long form's case-dependence (which gives
+ * us a unique, case-dependent path).
+ *
+ * The behaviour of this function if passed a non-absolute path
+ * is NOT defined.
+ *
+ * Results:
+ * The result is returned in a Tcl_Obj with a refCount of 1,
+ * which is therefore owned by the caller. It must be
+ * freed (with Tcl_DecrRefCount) by the caller when no longer needed.
+ *
+ * Side effects:
+ * None (beyond the memory allocation for the result).
+ *
+ * Special note:
+ * This code is based on code from Matt Newman and Jean-Claude
+ * Wippler, with additions from Vince Darley and is copyright
+ * those respective authors.
+ *
+ *---------------------------------------------------------------------------
+ */
+static Tcl_Obj*
+FSNormalizeAbsolutePath(interp, pathPtr)
+ Tcl_Interp* interp; /* Interpreter to use */
+ Tcl_Obj *pathPtr; /* Absolute path to normalize */
+{
+ int splen = 0, nplen, i;
+ Tcl_Obj *retVal;
+ Tcl_Obj *split;
+
+ /* Split has refCount zero */
+ split = Tcl_FSSplitPath(pathPtr, &splen);
+
+ /*
+ * Modify the list of entries in place, by removing '.', and
+ * removing '..' and the entry before -- unless that entry before
+ * is the top-level entry, i.e. the name of a volume.
+ */
+ nplen = 0;
+ for (i = 0;i < splen;i++) {
+ Tcl_Obj *elt;
+ Tcl_ListObjIndex(NULL, split, nplen, &elt);
+
+ if (strcmp(Tcl_GetString(elt), ".") == 0) {
+ Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
+ } else if (strcmp(Tcl_GetString(elt), "..") == 0) {
+ if (nplen > 1) {
+ nplen--;
+ Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL);
+ } else {
+ Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
+ }
+ } else {
+ nplen++;
+ }
+ }
+ if (nplen > 0) {
+ retVal = Tcl_FSJoinPath(split, nplen);
+ /*
+ * Now we have an absolute path, with no '..', '.' sequences,
+ * but it still may not be in 'unique' form, depending on the
+ * platform. For instance, Unix is case-sensitive, so the
+ * path is ok. Windows is case-insensitive, and also has the
+ * weird 'longname/shortname' thing (e.g. C:/Program Files/ and
+ * C:/Progra~1/ are equivalent). MacOS is case-insensitive.
+ *
+ * Virtual file systems which may be registered may have
+ * other criteria for normalizing a path.
+ */
+ Tcl_IncrRefCount(retVal);
+ TclNormalizeToUniquePath(interp, retVal);
+ /*
+ * Since we know it is a normalized path, we can
+ * actually convert this object into an FsPath for
+ * greater efficiency
+ */
+ SetFsPathFromAbsoluteNormalized(interp, retVal);
+ } else {
+ /* Init to an empty string */
+ retVal = Tcl_NewStringObj("",0);
+ Tcl_IncrRefCount(retVal);
+ }
+ /*
+ * We increment and then decrement the refCount of split to free
+ * it. We do this right at the end, in case there are
+ * optimisations in Tcl_FSJoinPath(split, nplen) above which would
+ * let it make use of split more effectively if it has a refCount
+ * of zero. Also we can't just decrement the ref count, in case
+ * 'split' was actually returned by the join call above, in a
+ * single-element optimisation when nplen == 1.
+ */
+ Tcl_IncrRefCount(split);
+ Tcl_DecrRefCount(split);
+
+ /* This has a refCount of 1 for the caller */
+ return retVal;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclNormalizeToUniquePath --
+ *
+ * Description:
+ * Takes a path specification containing no ../, ./ sequences,
+ * and converts it into a unique path for the given platform.
+ * On MacOS, Unix, this means the path must be free of
+ * symbolic links/aliases, and on Windows it means we want the
+ * long form, with that long form's case-dependence (which gives
+ * us a unique, case-dependent path).
+ *
+ * Results:
+ * The result is returned in a Tcl_Obj with a refCount of 1,
+ * which is therefore owned by the caller. It must be
+ * freed (with Tcl_DecrRefCount) by the caller when no longer needed.
+ *
+ * Side effects:
+ * None (beyond the memory allocation for the result).
+ *
+ * Special note:
+ * This is only used by the above function. Also if the
+ * filesystem-specific normalizePathProcs can re-introduce
+ * ../, ./ sequences into the path, then this function will
+ * not return the correct result. This may be possible with
+ * symbolic links on unix/macos.
+ *
+ *---------------------------------------------------------------------------
+ */
+static int
+TclNormalizeToUniquePath(interp, pathPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+{
+ FilesystemRecord *fsRecPtr;
+ int retVal = 0;
+
+ /*
+ * Call each of the "normalise path" functions in succession. This is
+ * a special case, in which if we have a native filesystem handler,
+ * we call it first. This is because the root of Tcl's filesystem
+ * is always a native filesystem (i.e. '/' on unix is native).
+ */
+
+ fsRecPtr = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ if (fsRecPtr == &nativeFilesystemRecord) {
+ Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
+ if (proc != NULL) {
+ retVal = (*proc)(interp, pathPtr, retVal);
+ }
+ break;
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+
+ fsRecPtr = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ /* Skip the native system next time through */
+ if (fsRecPtr != &nativeFilesystemRecord) {
+ Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
+ if (proc != NULL) {
+ retVal = (*proc)(interp, pathPtr, retVal);
+ }
+ /*
+ * We could add an efficiency check like this:
+ *
+ * if (retVal == length-of(pathPtr)) {break;}
+ *
+ * but there's not much benefit.
+ */
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+
+ return (retVal);
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclGetOpenMode --
+ *
+ * Description:
+ * Computes a POSIX mode mask for opening a file, from a given string,
+ * and also sets a flag to indicate whether the caller should seek to
+ * EOF after opening the file.
+ *
+ * Results:
+ * On success, returns mode to pass to "open". If an error occurs, the
+ * return value is -1 and if interp is not NULL, sets interp's result
+ * object to an error message.
+ *
+ * Side effects:
+ * Sets the integer referenced by seekFlagPtr to 1 to tell the caller
+ * to seek to EOF after opening the file.
+ *
+ * Special note:
+ * This code is based on a prototype implementation contributed
+ * by Mark Diekhans.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclGetOpenMode(interp, string, seekFlagPtr)
+ Tcl_Interp *interp; /* Interpreter to use for error
+ * reporting - may be NULL. */
+ CONST char *string; /* Mode string, e.g. "r+" or
+ * "RDONLY CREAT". */
+ int *seekFlagPtr; /* Set this to 1 if the caller
+ * should seek to EOF during the
+ * opening of the file. */
+{
+ int mode, modeArgc, c, i, gotRW;
+ CONST char **modeArgv, *flag;
+#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
+
+ /*
+ * Check for the simpler fopen-like access modes (e.g. "r"). They
+ * are distinguished from the POSIX access modes by the presence
+ * of a lower-case first letter.
+ */
+
+ *seekFlagPtr = 0;
+ mode = 0;
+
+ /*
+ * Guard against international characters before using byte oriented
+ * routines.
+ */
+
+ if (!(string[0] & 0x80)
+ && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
+ switch (string[0]) {
+ case 'r':
+ mode = O_RDONLY;
+ break;
+ case 'w':
+ mode = O_WRONLY|O_CREAT|O_TRUNC;
+ break;
+ case 'a':
+ mode = O_WRONLY|O_CREAT;
+ *seekFlagPtr = 1;
+ break;
+ default:
+ error:
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp,
+ "illegal access mode \"", string, "\"",
+ (char *) NULL);
+ }
+ return -1;
+ }
+ if (string[1] == '+') {
+ mode &= ~(O_RDONLY|O_WRONLY);
+ mode |= O_RDWR;
+ if (string[2] != 0) {
+ goto error;
+ }
+ } else if (string[1] != 0) {
+ goto error;
+ }
+ return mode;
+ }
+
+ /*
+ * The access modes are specified using a list of POSIX modes
+ * such as O_CREAT.
+ *
+ * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
+ * a NULL interpreter is passed in.
+ */
+
+ if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AddErrorInfo(interp,
+ "\n while processing open access modes \"");
+ Tcl_AddErrorInfo(interp, string);
+ Tcl_AddErrorInfo(interp, "\"");
+ }
+ return -1;
+ }
+
+ gotRW = 0;
+ for (i = 0; i < modeArgc; i++) {
+ flag = modeArgv[i];
+ c = flag[0];
+ if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
+ mode = (mode & ~RW_MODES) | O_RDONLY;
+ gotRW = 1;
+ } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
+ mode = (mode & ~RW_MODES) | O_WRONLY;
gotRW = 1;
} else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
mode = (mode & ~RW_MODES) | O_RDWR;
}
return -1;
}
- return mode;
+ return mode;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSEvalFile --
+ *
+ * Read in a file and process the entire file as one gigantic
+ * Tcl command.
+ *
+ * Results:
+ * A standard Tcl result, which is either the result of executing
+ * the file or an error indicating why the file couldn't be read.
+ *
+ * Side effects:
+ * Depends on the commands in the file. During the evaluation
+ * of the contents of the file, iPtr->scriptFile is made to
+ * point to pathPtr (the old value is cached and replaced when
+ * this function returns).
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSEvalFile(interp, pathPtr)
+ Tcl_Interp *interp; /* Interpreter in which to process file. */
+ Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution
+ * will be performed on this name. */
+{
+ int result, length;
+ Tcl_StatBuf statBuf;
+ Tcl_Obj *oldScriptFile;
+ Interp *iPtr;
+ char *string;
+ Tcl_Channel chan;
+ Tcl_Obj *objPtr;
+
+ if (Tcl_FSGetTranslatedPath(interp, pathPtr) == NULL) {
+ return TCL_ERROR;
+ }
+
+ result = TCL_ERROR;
+ objPtr = Tcl_NewObj();
+
+ if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
+ Tcl_SetErrno(errno);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr),
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+ goto end;
+ }
+ chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
+ if (chan == (Tcl_Channel) NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr),
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+ goto end;
+ }
+ /*
+ * The eofchar is \32 (^Z). This is the usual on Windows, but we
+ * effect this cross-platform to allow for scripted documents.
+ * [Bug: 2040]
+ */
+ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+ if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
+ Tcl_Close(interp, chan);
+ Tcl_AppendResult(interp, "couldn't read file \"",
+ Tcl_GetString(pathPtr),
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+ goto end;
+ }
+ if (Tcl_Close(interp, chan) != TCL_OK) {
+ goto end;
+ }
+
+ iPtr = (Interp *) interp;
+ oldScriptFile = iPtr->scriptFile;
+ iPtr->scriptFile = pathPtr;
+ Tcl_IncrRefCount(iPtr->scriptFile);
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ result = Tcl_EvalEx(interp, string, length, 0);
+ /*
+ * Now we have to be careful; the script may have changed the
+ * iPtr->scriptFile value, so we must reset it without
+ * assuming it still points to 'pathPtr'.
+ */
+ if (iPtr->scriptFile != NULL) {
+ Tcl_DecrRefCount(iPtr->scriptFile);
+ }
+ iPtr->scriptFile = oldScriptFile;
+
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo(iPtr);
+ } else if (result == TCL_ERROR) {
+ char msg[200 + TCL_INTEGER_SPACE];
+
+ /*
+ * Record information telling where the error occurred.
+ */
+
+ sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr),
+ interp->errorLine);
+ Tcl_AddErrorInfo(interp, msg);
+ }
+
+ end:
+ Tcl_DecrRefCount(objPtr);
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetErrno --
+ *
+ * Gets the current value of the Tcl error code variable. This is
+ * currently the global variable "errno" but could in the future
+ * change to something else.
+ *
+ * Results:
+ * The value of the Tcl error code variable.
+ *
+ * Side effects:
+ * None. Note that the value of the Tcl error code variable is
+ * UNDEFINED if a call to Tcl_SetErrno did not precede this call.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetErrno()
+{
+ return errno;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetErrno --
+ *
+ * Sets the Tcl error code variable to the supplied value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Modifies the value of the Tcl error code variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetErrno(err)
+ int err; /* The new value. */
+{
+ errno = err;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PosixError --
+ *
+ * This procedure is typically called after UNIX kernel calls
+ * return errors. It stores machine-readable information about
+ * the error in $errorCode returns an information string for
+ * the caller's use.
+ *
+ * Results:
+ * The return value is a human-readable string describing the
+ * error.
+ *
+ * Side effects:
+ * The global variable $errorCode is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+CONST char *
+Tcl_PosixError(interp)
+ Tcl_Interp *interp; /* Interpreter whose $errorCode variable
+ * is to be changed. */
+{
+ CONST char *id, *msg;
+
+ msg = Tcl_ErrnoMsg(errno);
+ id = Tcl_ErrnoId();
+ Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
+ return msg;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSStat --
+ *
+ * This procedure replaces the library version of stat and lsat.
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSStat(pathPtr, buf)
+ Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf; /* Filled with results of stat call. */
+{
+ Tcl_Filesystem *fsPtr;
+#ifdef USE_OBSOLETE_FS_HOOKS
+ StatProc *statProcPtr;
+ struct stat oldStyleStatBuffer;
+ int retVal = -1;
+ char *path;
+ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
+ if (transPtr == NULL) {
+ path = NULL;
+ } else {
+ path = Tcl_GetString(transPtr);
+ }
+
+ /*
+ * Call each of the "stat" function in succession. A non-return
+ * value of -1 indicates the particular function has succeeded.
+ */
+
+ Tcl_MutexLock(&obsoleteFsHookMutex);
+ statProcPtr = statProcList;
+ while ((retVal == -1) && (statProcPtr != NULL)) {
+ retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
+ statProcPtr = statProcPtr->nextPtr;
+ }
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
+ if (retVal != -1) {
+ /*
+ * Note that EOVERFLOW is not a problem here, and these
+ * assignments should all be widening (if not identity.)
+ */
+ buf->st_mode = oldStyleStatBuffer.st_mode;
+ buf->st_ino = oldStyleStatBuffer.st_ino;
+ buf->st_dev = oldStyleStatBuffer.st_dev;
+ buf->st_rdev = oldStyleStatBuffer.st_rdev;
+ buf->st_nlink = oldStyleStatBuffer.st_nlink;
+ buf->st_uid = oldStyleStatBuffer.st_uid;
+ buf->st_gid = oldStyleStatBuffer.st_gid;
+ buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
+ buf->st_atime = oldStyleStatBuffer.st_atime;
+ buf->st_mtime = oldStyleStatBuffer.st_mtime;
+ buf->st_ctime = oldStyleStatBuffer.st_ctime;
+#ifdef HAVE_ST_BLOCKS
+ buf->st_blksize = oldStyleStatBuffer.st_blksize;
+ buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
+#endif
+ return retVal;
+ }
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSStatProc *proc = fsPtr->statProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, buf);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSLstat --
+ *
+ * This procedure replaces the library version of lstat.
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called. If no 'lstat' function is listed,
+ * but a 'stat' function is, then Tcl will fall back on the
+ * stat function.
+ *
+ * Results:
+ * See lstat documentation.
+ *
+ * Side effects:
+ * See lstat documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSLstat(pathPtr, buf)
+ Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf; /* Filled with results of stat call. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSLstatProc *proc = fsPtr->lstatProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, buf);
+ } else {
+ Tcl_FSStatProc *sproc = fsPtr->statProc;
+ if (sproc != NULL) {
+ return (*sproc)(pathPtr, buf);
+ }
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSAccess --
+ *
+ * This procedure replaces the library version of access.
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSAccess(pathPtr, mode)
+ Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
+ int mode; /* Permission setting. */
+{
+ Tcl_Filesystem *fsPtr;
+#ifdef USE_OBSOLETE_FS_HOOKS
+ AccessProc *accessProcPtr;
+ int retVal = -1;
+ char *path;
+ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
+ if (transPtr == NULL) {
+ path = NULL;
+ } else {
+ path = Tcl_GetString(transPtr);
+ }
+
+ /*
+ * Call each of the "access" function in succession. A non-return
+ * value of -1 indicates the particular function has succeeded.
+ */
+
+ Tcl_MutexLock(&obsoleteFsHookMutex);
+ accessProcPtr = accessProcList;
+ while ((retVal == -1) && (accessProcPtr != NULL)) {
+ retVal = (*accessProcPtr->proc)(path, mode);
+ accessProcPtr = accessProcPtr->nextPtr;
+ }
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
+ if (retVal != -1) {
+ return retVal;
+ }
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSAccessProc *proc = fsPtr->accessProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, mode);
+ }
+ }
+
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSOpenFileChannel --
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * The new channel or NULL, if the named file could not be opened.
+ *
+ * Side effects:
+ * May open the channel and may cause creation of a file on the
+ * file system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
+ Tcl_Interp *interp; /* Interpreter for error reporting;
+ * can be NULL. */
+ Tcl_Obj *pathPtr; /* Name of file to open. */
+ CONST char *modeString; /* A list of POSIX open modes or
+ * a string such as "rw". */
+ int permissions; /* If the open involves creating a
+ * file, with what modes to create
+ * it? */
+{
+ Tcl_Filesystem *fsPtr;
+#ifdef USE_OBSOLETE_FS_HOOKS
+ OpenFileChannelProc *openFileChannelProcPtr;
+ Tcl_Channel retVal = NULL;
+ char *path;
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (transPtr == NULL) {
+ return NULL;
+ }
+#ifdef USE_OBSOLETE_FS_HOOKS
+ if (transPtr == NULL) {
+ path = NULL;
+ } else {
+ path = Tcl_GetString(transPtr);
+ }
+
+ /*
+ * Call each of the "Tcl_OpenFileChannel" function in succession.
+ * A non-NULL return value indicates the particular function has
+ * succeeded.
+ */
+
+ Tcl_MutexLock(&obsoleteFsHookMutex);
+ openFileChannelProcPtr = openFileChannelProcList;
+ while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
+ retVal = (*openFileChannelProcPtr->proc)(interp, path,
+ modeString, permissions);
+ openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
+ }
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
+ if (retVal != NULL) {
+ return retVal;
+ }
+#endif /* USE_OBSOLETE_FS_HOOKS */
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
+ if (proc != NULL) {
+ int mode, seekFlag;
+ mode = TclGetOpenMode(interp, modeString, &seekFlag);
+ if (mode == -1) {
+ return NULL;
+ }
+ retVal = (*proc)(interp, pathPtr, mode, permissions);
+ if (retVal != NULL) {
+ if (seekFlag) {
+ if (Tcl_Seek(retVal, (Tcl_WideInt)0,
+ SEEK_END) < (Tcl_WideInt)0) {
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp,
+ "could not seek to end of file while opening \"",
+ Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ Tcl_Close(NULL, retVal);
+ return NULL;
+ }
+ }
+ }
+ return retVal;
+ }
+ }
+ /* File doesn't belong to any filesystem that can open it */
+ Tcl_SetErrno(ENOENT);
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "couldn't open \"",
+ Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSMatchInDirectory --
+ *
+ * This routine is used by the globbing code to search a directory
+ * for all files which match a given pattern. The appropriate
+ * function for the filesystem to which pathPtr belongs will be
+ * called. If pathPtr does not belong to any filesystem and if it
+ * is NULL or the empty string, then we assume the pattern is to
+ * be matched in the current working directory. To avoid each
+ * filesystem's Tcl_FSMatchInDirectoryProc having to deal with
+ * this issue, we create a pathPtr on the fly, and then remove it
+ * from the results returned. This makes filesystems easy to
+ * write, since they can assume the pathPtr passed to them
+ * is an ordinary path. In fact this means we could remove such
+ * special case handling from Tcl's native filesystems.
+ *
+ * If 'pattern' is NULL, then pathPtr is assumed to be a fully
+ * specified path of a single file/directory which must be
+ * checked for existence and correct type.
+ *
+ * Results:
+ *
+ * The return value is a standard Tcl result indicating whether an
+ * error occurred in globbing. Error messages are placed in
+ * interp, but good results are placed in the resultPtr given.
+ *
+ * Recursive searches, e.g.
+ *
+ * glob -dir $dir -join * pkgIndex.tcl
+ *
+ * which must recurse through each directory matching '*' are
+ * handled internally by Tcl, by passing specific flags in a
+ * modified 'types' parameter.
+ *
+ * Side effects:
+ * The interpreter may have an error message inserted into it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
+ Tcl_Interp *interp; /* Interpreter to receive error messages. */
+ Tcl_Obj *result; /* List object to receive results. */
+ Tcl_Obj *pathPtr; /* Contains path to directory to search. */
+ CONST char *pattern; /* Pattern to match against. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. In particular the directory
+ * flag is very important. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
+ if (proc != NULL) {
+ return (*proc)(interp, result, pathPtr, pattern, types);
+ }
+ } else {
+ Tcl_Obj* cwd;
+ int ret = -1;
+ if (pathPtr != NULL) {
+ int len;
+ Tcl_GetStringFromObj(pathPtr,&len);
+ if (len != 0) {
+ /*
+ * We have no idea how to match files in a directory
+ * which belongs to no known filesystem
+ */
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
+ }
+ /*
+ * We have an empty or NULL path. This is defined to mean we
+ * must search for files within the current 'cwd'. We
+ * therefore use that, but then since the proc we call will
+ * return results which include the cwd we must then trim it
+ * off the front of each path in the result. We choose to deal
+ * with this here (in the generic code), since if we don't,
+ * every single filesystem's implementation of
+ * Tcl_FSMatchInDirectory will have to deal with it for us.
+ */
+ cwd = Tcl_FSGetCwd(NULL);
+ if (cwd == NULL) {
+ if (interp != NULL) {
+ Tcl_SetResult(interp, "glob couldn't determine "
+ "the current working directory", TCL_STATIC);
+ }
+ return TCL_ERROR;
+ }
+ fsPtr = Tcl_FSGetFileSystemForPath(cwd);
+ if (fsPtr != NULL) {
+ Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
+ if (proc != NULL) {
+ int cwdLen;
+ Tcl_Obj *cwdDir;
+ char *cwdStr;
+ char sep = 0;
+ Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL);
+ /*
+ * We know the cwd is a normalised object which does
+ * not end in a directory delimiter, unless the cwd
+ * is the name of a volume, in which case it will
+ * end in a delimiter! We handle this situation here.
+ * A better test than the '!= sep' might be to simply
+ * check if 'cwd' is a root volume.
+ *
+ * Note that if we get this wrong, we will strip off
+ * either too much or too little below, leading to
+ * wrong answers returned by glob.
+ */
+ cwdDir = Tcl_DuplicateObj(cwd);
+ Tcl_IncrRefCount(cwdDir);
+ cwdStr = Tcl_GetStringFromObj(cwdDir, &cwdLen);
+ /*
+ * Should we perhaps use 'Tcl_FSPathSeparator'?
+ * But then what about the Windows special case?
+ * Perhaps we should just check if cwd is a root
+ * volume.
+ */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ if (cwdStr[cwdLen-1] != '/') {
+ sep = '/';
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ if (cwdStr[cwdLen-1] != '/' && cwdStr[cwdLen-1] != '\\') {
+ sep = '/';
+ }
+ break;
+ case TCL_PLATFORM_MAC:
+ if (cwdStr[cwdLen-1] != ':') {
+ sep = ':';
+ }
+ break;
+ }
+ if (sep != 0) {
+ Tcl_AppendToObj(cwdDir, &sep, 1);
+ cwdLen++;
+ /* Note: cwdStr may no longer be a valid pointer now */
+ }
+ ret = (*proc)(interp, tmpResultPtr, cwdDir, pattern, types);
+ Tcl_DecrRefCount(cwdDir);
+ if (ret == TCL_OK) {
+ int resLength;
+
+ ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength);
+ if (ret == TCL_OK) {
+ Tcl_Obj *elt, *cutElt;
+ char *eltStr;
+ int eltLen, i;
+
+ for (i = 0; i < resLength; i++) {
+ Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt);
+ eltStr = Tcl_GetStringFromObj(elt,&eltLen);
+ cutElt = Tcl_NewStringObj(eltStr + cwdLen,
+ eltLen - cwdLen);
+ Tcl_ListObjAppendElement(interp, result, cutElt);
+ }
+ }
+ }
+ Tcl_DecrRefCount(tmpResultPtr);
+ }
+ }
+ Tcl_DecrRefCount(cwd);
+ return ret;
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSGetCwd --
+ *
+ * This function replaces the library version of getcwd().
+ *
+ * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains
+ * its own record (in a Tcl_Obj) of the cwd, and an attempt
+ * is made to synchronise this with the cwd's containing filesystem,
+ * if that filesystem provides a cwdProc (e.g. the native filesystem).
+ *
+ * Note that if Tcl's cwd is not in the native filesystem, then of
+ * course Tcl's cwd and the native cwd are different: extensions
+ * should therefore ensure they only access the cwd through this
+ * function to avoid confusion.
+ *
+ * If a global cwdPathPtr already exists, it is returned, subject
+ * to a synchronisation attempt in that cwdPathPtr's fs.
+ * Otherwise, the chain of functions that have been "inserted"
+ * into the filesystem will be called in succession until either a
+ * value other than NULL is returned, or the entire list is
+ * visited.
+ *
+ * Results:
+ * The result is a pointer to a Tcl_Obj specifying the current
+ * directory, or NULL if the current directory could not be
+ * determined. If NULL is returned, an error message is left in the
+ * interp's result.
+ *
+ * The result already has its refCount incremented for the caller.
+ * When it is no longer needed, that refCount should be decremented.
+ * This is needed for thread-safety purposes, to allow multiple
+ * threads to access this and related functions, while ensuring the
+ * results are always valid.
+ *
+ * Of course it is probably a bad idea for multiple threads to
+ * be *setting* the cwd anyway, but we can at least try to
+ * help the case of multiple reads with occasional sets.
+ *
+ * Side effects:
+ * Various objects may be freed and allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSGetCwd(interp)
+ Tcl_Interp *interp;
+{
+ Tcl_Obj *cwdToReturn;
+
+ if (FsCwdPointerEquals(NULL)) {
+ FilesystemRecord *fsRecPtr;
+ Tcl_Obj *retVal = NULL;
+
+ /*
+ * We've never been called before, try to find a cwd. Call
+ * each of the "Tcl_GetCwd" function in succession. A non-NULL
+ * return value indicates the particular function has
+ * succeeded.
+ */
+
+ fsRecPtr = FsGetIterator();
+ while ((retVal == NULL) && (fsRecPtr != NULL)) {
+ Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
+ if (proc != NULL) {
+ retVal = (*proc)(interp);
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+ /*
+ * Now the 'cwd' may NOT be normalized, at least on some
+ * platforms. For the sake of efficiency, we want a completely
+ * normalized cwd at all times.
+ *
+ * Finally, if retVal is NULL, we do not have a cwd, which
+ * could be problematic.
+ */
+ if (retVal != NULL) {
+ Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, retVal);
+ if (norm != NULL) {
+ /*
+ * We found a cwd, which is now in our global storage.
+ * We must make a copy. Norm already has a refCount of
+ * 1.
+ *
+ * Threading issue: note that multiple threads at system
+ * startup could in principle call this procedure
+ * simultaneously. They will therefore each set the
+ * cwdPathPtr independently. That behaviour is a bit
+ * peculiar, but should be fine. Once we have a cwd,
+ * we'll always be in the 'else' branch below which
+ * is simpler.
+ */
+ Tcl_MutexLock(&cwdMutex);
+ /* Just in case the pointer has been set by another
+ * thread between now and the test above */
+ if (cwdPathPtr != NULL) {
+ Tcl_DecrRefCount(cwdPathPtr);
+ }
+ cwdPathPtr = norm;
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ Tcl_DecrRefCount(retVal);
+ }
+ } else {
+ /*
+ * We already have a cwd cached, but we want to give the
+ * filesystem it is in a chance to check whether that cwd
+ * has changed, or is perhaps no longer accessible. This
+ * allows an error to be thrown if, say, the permissions on
+ * that directory have changed.
+ */
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(cwdPathPtr);
+ /*
+ * If the filesystem couldn't be found, or if no cwd function
+ * exists for this filesystem, then we simply assume the cached
+ * cwd is ok. If we do call a cwd, we must watch for errors
+ * (if the cwd returns NULL). This ensures that, say, on Unix
+ * if the permissions of the cwd change, 'pwd' does actually
+ * throw the correct error in Tcl. (This is tested for in the
+ * test suite on unix).
+ */
+ if (fsPtr != NULL) {
+ Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
+ if (proc != NULL) {
+ Tcl_Obj *retVal = (*proc)(interp);
+ if (retVal != NULL) {
+ Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, retVal);
+ /*
+ * Check whether cwd has changed from the value
+ * previously stored in cwdPathPtr. Really 'norm'
+ * shouldn't be null, but we are careful.
+ */
+ if (norm == NULL) {
+ /* Do nothing */
+ } else if (Tcl_FSEqualPaths(cwdPathPtr, norm)) {
+ /*
+ * If the paths were equal, we can be more
+ * efficient and retain the old path object
+ * which will probably already be shared. In
+ * this case we can simply free the normalized
+ * path we just calculated.
+ */
+ Tcl_DecrRefCount(norm);
+ } else {
+ /* The cwd has in fact changed, so we must
+ * lock down the cwdMutex to modify. */
+ Tcl_MutexLock(&cwdMutex);
+ Tcl_DecrRefCount(cwdPathPtr);
+ cwdPathPtr = norm;
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ Tcl_DecrRefCount(retVal);
+ } else {
+ /* The 'cwd' function returned an error, so we
+ * reset the cwd after locking down the mutex. */
+ Tcl_MutexLock(&cwdMutex);
+ Tcl_DecrRefCount(cwdPathPtr);
+ cwdPathPtr = NULL;
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ }
+ }
+ }
+
+ /*
+ * The paths all eventually fall through to here. Note that
+ * we use a bunch of separate mutex locks throughout this
+ * code to help prevent deadlocks between threads. Really
+ * the only weirdness will arise if multiple threads are setting
+ * and reading the cwd, and that behaviour is always going to be
+ * a little suspect.
+ */
+ Tcl_MutexLock(&cwdMutex);
+ cwdToReturn = cwdPathPtr;
+ if (cwdToReturn != NULL) {
+ Tcl_IncrRefCount(cwdToReturn);
+ }
+ Tcl_MutexUnlock(&cwdMutex);
+
+ return (cwdToReturn);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSUtime --
+ *
+ * This procedure replaces the library version of utime.
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * See utime documentation.
+ *
+ * Side effects:
+ * See utime documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSUtime (pathPtr, tval)
+ Tcl_Obj *pathPtr; /* File to change access/modification times */
+ struct utimbuf *tval; /* Structure containing access/modification
+ * times to use. Should not be modified. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, tval);
+ }
+ }
+ return -1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * NativeFileAttrStrings --
+ *
+ * This procedure implements the platform dependent 'file
+ * attributes' subcommand, for the native filesystem, for listing
+ * the set of possible attribute strings. This function is part
+ * of Tcl's native filesystem support, and is placed here because
+ * it is shared by Unix, MacOS and Windows code.
+ *
+ * Results:
+ * An array of strings
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static CONST char**
+NativeFileAttrStrings(pathPtr, objPtrRef)
+ Tcl_Obj *pathPtr;
+ Tcl_Obj** objPtrRef;
+{
+ return tclpFileAttrStrings;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * NativeFileAttrsGet --
+ *
+ * This procedure implements the platform dependent
+ * 'file attributes' subcommand, for the native
+ * filesystem, for 'get' operations. This function is part
+ * of Tcl's native filesystem support, and is placed here
+ * because it is shared by Unix, MacOS and Windows code.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef
+ * (if TCL_OK was returned) is likely to have a refCount of zero.
+ * Either way we must either store it somewhere (e.g. the Tcl
+ * result), or Incr/Decr its refCount to ensure it is properly
+ * freed.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NativeFileAttrsGet(interp, index, pathPtr, objPtrRef)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *pathPtr; /* path of file we are operating on. */
+ Tcl_Obj **objPtrRef; /* for output. */
+{
+ return (*tclpFileAttrProcs[index].getProc)(interp, index,
+ pathPtr, objPtrRef);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * NativeFileAttrsSet --
+ *
+ * This procedure implements the platform dependent
+ * 'file attributes' subcommand, for the native
+ * filesystem, for 'set' operations. This function is part
+ * of Tcl's native filesystem support, and is placed here
+ * because it is shared by Unix, MacOS and Windows code.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NativeFileAttrsSet(interp, index, pathPtr, objPtr)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *pathPtr; /* path of file we are operating on. */
+ Tcl_Obj *objPtr; /* set to this value. */
+{
+ return (*tclpFileAttrProcs[index].setProc)(interp, index,
+ pathPtr, objPtr);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSFileAttrStrings --
+ *
+ * This procedure implements part of the hookable 'file
+ * attributes' subcommand. The appropriate function for the
+ * filesystem to which pathPtr belongs will be called.
+ *
+ * Results:
+ * The called procedure may either return an array of strings,
+ * or may instead return NULL and place a Tcl list into the
+ * given objPtrRef. Tcl will take that list and first increment
+ * its refCount before using it. On completion of that use, Tcl
+ * will decrement its refCount. Hence if the list should be
+ * disposed of by Tcl when done, it should have a refCount of zero,
+ * and if the list should not be disposed of, the filesystem
+ * should ensure it retains a refCount on the object.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+CONST char **
+Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
+ Tcl_Obj* pathPtr;
+ Tcl_Obj** objPtrRef;
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, objPtrRef);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSFileAttrsGet --
+ *
+ * This procedure implements read access for the hookable 'file
+ * attributes' subcommand. The appropriate function for the
+ * filesystem to which pathPtr belongs will be called.
+ *
+ * Results:
+ * Standard Tcl return code. The object placed in objPtrRef
+ * (if TCL_OK was returned) is likely to have a refCount of zero.
+ * Either way we must either store it somewhere (e.g. the Tcl
+ * result), or Incr/Decr its refCount to ensure it is properly
+ * freed.
+
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *pathPtr; /* filename we are operating on. */
+ Tcl_Obj **objPtrRef; /* for output. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
+ if (proc != NULL) {
+ return (*proc)(interp, index, pathPtr, objPtrRef);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSFileAttrsSet --
+ *
+ * This procedure implements write access for the hookable 'file
+ * attributes' subcommand. The appropriate function for the
+ * filesystem to which pathPtr belongs will be called.
+ *
+ * Results:
+ * Standard Tcl return code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *pathPtr; /* filename we are operating on. */
+ Tcl_Obj *objPtr; /* Input value. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
+ if (proc != NULL) {
+ return (*proc)(interp, index, pathPtr, objPtr);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSChdir --
+ *
+ * This function replaces the library version of chdir().
+ *
+ * The path is normalized and then passed to the filesystem
+ * which claims it.
+ *
+ * Results:
+ * See chdir() documentation. If successful, we keep a
+ * record of the successful path in cwdPathPtr for subsequent
+ * calls to getcwd.
+ *
+ * Side effects:
+ * See chdir() documentation. The global cwdPathPtr may
+ * change value.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+Tcl_FSChdir(pathPtr)
+ Tcl_Obj *pathPtr;
+{
+ Tcl_Filesystem *fsPtr;
+ int retVal = -1;
+
+ if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
+ return TCL_ERROR;
+ }
+
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSChdirProc *proc = fsPtr->chdirProc;
+ if (proc != NULL) {
+ retVal = (*proc)(pathPtr);
+ } else {
+ /* Fallback on stat-based implementation */
+ Tcl_StatBuf buf;
+ /* If the file can be stat'ed and is a directory and
+ * is readable, then we can chdir. */
+ if ((Tcl_FSStat(pathPtr, &buf) == 0)
+ && (S_ISDIR(buf.st_mode))
+ && (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
+ /* We allow the chdir */
+ retVal = 0;
+ }
+ }
+ }
+
+ if (retVal != -1) {
+ /*
+ * The cwd changed, or an error was thrown. If an error was
+ * thrown, we can just continue (and that will report the error
+ * to the user). If there was no error we must assume that the
+ * cwd was actually changed to the normalized value we
+ * calculated above, and we must therefore cache that
+ * information.
+ */
+ if (retVal == TCL_OK) {
+ /*
+ * Note that this normalized path may be different to what
+ * we found above (or at least a different object), if the
+ * filesystem epoch changed recently. This can actually
+ * happen with scripted documents very easily. Therefore
+ * we ask for the normalized path again (the correct value
+ * will have been cached as a result of the
+ * Tcl_FSGetFileSystemForPath call above anyway).
+ */
+ Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (normDirName == NULL) {
+ return TCL_ERROR;
+ }
+ /*
+ * We will be adding a reference to this object when
+ * we store it in the cwdPathPtr.
+ */
+ Tcl_IncrRefCount(normDirName);
+ /* Get a lock on the cwd while we modify it */
+ Tcl_MutexLock(&cwdMutex);
+ /* Free up the previous cwd we stored */
+ if (cwdPathPtr != NULL) {
+ Tcl_DecrRefCount(cwdPathPtr);
+ }
+ /* Now remember the current cwd */
+ cwdPathPtr = normDirName;
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ }
+
+ return (retVal);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSLoadFile --
+ *
+ * Dynamically loads a binary code file into memory and returns
+ * the addresses of two procedures within that file, if they are
+ * defined. The appropriate function for the filesystem to which
+ * pathPtr belongs will be called.
+ *
+ * Note that the native filesystem doesn't actually assume
+ * 'pathPtr' is a path. Rather it assumes filename is either
+ * a path or just the name of a file which can be found somewhere
+ * in the environment's loadable path. This behaviour is not
+ * very compatible with virtual filesystems (and has other problems
+ * documented in the load man-page), so it is advised that full
+ * paths are always used.
+ *
+ * Results:
+ * A standard Tcl completion code. If an error occurs, an error
+ * message is left in the interp's result.
+ *
+ * Side effects:
+ * New code suddenly appears in memory. This may later be
+ * unloaded by passing the clientData to the unloadProc.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ handlePtr, unloadProcPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code. */
+ CONST char *sym1, *sym2; /* Names of two procedures to look up in
+ * the file's symbol table. */
+ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
+ /* Where to return the addresses corresponding
+ * to sym1 and sym2. */
+ Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
+ * file which will be passed back to
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
+ if (proc != NULL) {
+ int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
+ if (retVal != TCL_OK) {
+ return retVal;
+ }
+ if (*handlePtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (sym1 != NULL) {
+ *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
+ }
+ if (sym2 != NULL) {
+ *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
+ }
+ return retVal;
+ } else {
+ Tcl_Filesystem *copyFsPtr;
+ Tcl_Obj *copyToPtr;
+
+ /* First check if it is readable -- and exists! */
+ if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
+ Tcl_AppendResult(interp, "couldn't load library \"",
+ Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get a temporary filename to use, first to
+ * copy the file into, and then to load.
+ */
+ copyToPtr = TclpTempFileName();
+ if (copyToPtr == NULL) {
+ return -1;
+ }
+ Tcl_IncrRefCount(copyToPtr);
+
+ copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
+ if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
+ /*
+ * We already know we can't use Tcl_FSLoadFile from
+ * this filesystem, and we must avoid a possible
+ * infinite loop. Try to delete the file we
+ * probably created, and then exit.
+ */
+ Tcl_FSDeleteFile(copyToPtr);
+ Tcl_DecrRefCount(copyToPtr);
+ return -1;
+ }
+
+ if (TclCrossFilesystemCopy(interp, pathPtr,
+ copyToPtr) == TCL_OK) {
+ /*
+ * Do we need to set appropriate permissions
+ * on the file? This may be required on some
+ * systems. On Unix we could loop over
+ * the file attributes, and set any that are
+ * called "-permissions" to 0777. Or directly:
+ *
+ * Tcl_Obj* perm = Tcl_NewStringObj("0777",-1);
+ * Tcl_IncrRefCount(perm);
+ * Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
+ * Tcl_DecrRefCount(perm);
+ *
+ */
+ Tcl_LoadHandle newLoadHandle = NULL;
+ Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
+ FsDivertLoad *tvdlPtr;
+ int retVal;
+
+ retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2,
+ proc1Ptr, proc2Ptr,
+ &newLoadHandle,
+ &newUnloadProcPtr);
+ if (retVal != TCL_OK) {
+ /* The file didn't load successfully */
+ Tcl_FSDeleteFile(copyToPtr);
+ Tcl_DecrRefCount(copyToPtr);
+ return retVal;
+ }
+ /*
+ * Try to delete the file immediately -- this is
+ * possible in some OSes, and avoids any worries
+ * about leaving the copy laying around on exit.
+ */
+ if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
+ Tcl_DecrRefCount(copyToPtr);
+ (*handlePtr) = NULL;
+ (*unloadProcPtr) = NULL;
+ return TCL_OK;
+ }
+ /*
+ * When we unload this file, we need to divert the
+ * unloading so we can unload and cleanup the
+ * temporary file correctly.
+ */
+ tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));
+
+ /*
+ * Remember three pieces of information. This allows
+ * us to cleanup the diverted load completely, on
+ * platforms which allow proper unloading of code.
+ */
+ tvdlPtr->loadHandle = newLoadHandle;
+ tvdlPtr->unloadProcPtr = newUnloadProcPtr;
+ /* copyToPtr is already incremented for this reference */
+ tvdlPtr->divertedFile = copyToPtr;
+ /*
+ * This is the filesystem we loaded it into. It is
+ * almost certainly the tclNativeFilesystem, but we don't
+ * want to make that assumption. Since we have a
+ * reference to 'copyToPtr', we already have a refCount
+ * on this filesystem, so we don't need to worry about it
+ * disappearing on us.
+ */
+ tvdlPtr->divertedFilesystem = copyFsPtr;
+ /* Get the native representation of the file path */
+ tvdlPtr->divertedFileNativeRep = Tcl_FSGetInternalRep(copyToPtr,
+ copyFsPtr);
+ copyToPtr = NULL;
+ (*handlePtr) = (Tcl_LoadHandle) tvdlPtr;
+ (*unloadProcPtr) = &FSUnloadTempFile;
+
+ return retVal;
+ } else {
+ /* Cross-platform copy failed */
+ Tcl_FSDeleteFile(copyToPtr);
+ Tcl_DecrRefCount(copyToPtr);
+ return TCL_ERROR;
+ }
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+/*
+ * This function used to be in the platform specific directories, but it
+ * has now been made to work cross-platform
+ */
+int
+TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
+ clientDataPtr, unloadProcPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ CONST char *sym1, *sym2; /* Names of two procedures to look up in
+ * the file's symbol table. */
+ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
+ /* Where to return the addresses corresponding
+ * to sym1 and sym2. */
+ ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ * file which will be passed back to
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
+{
+ Tcl_LoadHandle handle = NULL;
+ int res;
+
+ res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);
+
+ if (res != TCL_OK) {
+ return res;
+ }
+
+ if (handle == NULL) {
+ return TCL_ERROR;
+ }
+
+ *clientDataPtr = (ClientData)handle;
+
+ *proc1Ptr = TclpFindSymbol(interp, handle, sym1);
+ *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
+ return TCL_OK;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * FSUnloadTempFile --
+ *
+ * This function is called when we loaded a library of code via
+ * an intermediate temporary file. This function ensures
+ * the library is correctly unloaded and the temporary file
+ * is correctly deleted.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The effects of the 'unload' function called, and of course
+ * the temporary file will be deleted.
+ *
+ *---------------------------------------------------------------------------
+ */
+static void
+FSUnloadTempFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to Tcl_FSLoadFile(). The loadHandle is
+ * a token that represents the loaded
+ * file. */
+{
+ FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;
+ /*
+ * This test should never trigger, since we give
+ * the client data in the function above.
+ */
+ if (tvdlPtr == NULL) { return; }
+
+ /*
+ * Call the real 'unloadfile' proc we actually used. It is very
+ * important that we call this first, so that the shared library
+ * is actually unloaded by the OS. Otherwise, the following
+ * 'delete' may well fail because the shared library is still in
+ * use.
+ */
+ if (tvdlPtr->unloadProcPtr != NULL) {
+ (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
+ }
+
+ /* Remove the temporary file we created. */
+ if (Tcl_FSDeleteFile(tvdlPtr->divertedFile) != TCL_OK) {
+ /*
+ * The above may have failed because the filesystem, or something
+ * it depends upon (e.g. encodings) are being taken down because
+ * Tcl is exiting.
+ *
+ * Therefore we try to call the filesystem's 'delete file proc'
+ * directly. Note that this call may still cause problems, because
+ * it will ask for the native representation of the divertedFile,
+ * and that may need to be _recalculated_, in which case this
+ * call isn't very different to the above. What we could do
+ * instead is generate a new Tcl_Obj (pure native) by calling:
+ *
+ * Tcl_Obj *tmp = Tcl_FSNewNativePath(tvdlPtr->divertedFile,
+ * tvdlPtr->divertedFileNativeRep);
+ * Tcl_IncrRefCount(tmp);
+ * tvdlPtr->divertedFilesystem->deleteFileProc(tmp);
+ * Tcl_DecrRefCount(tmp);
+ *
+ * and then use that in this call. This approach would potentially
+ * work even if the encodings and everything else have been
+ * deconstructed. For the moment, however, we simply assume
+ * Tcl_FSDeleteFile has worked correctly.
+ */
+ }
+
+ /*
+ * And free up the allocations. This will also of course remove
+ * a refCount from the Tcl_Filesystem to which this file belongs,
+ * which could then free up the filesystem if we are exiting.
+ */
+ Tcl_DecrRefCount(tvdlPtr->divertedFile);
+ ckfree((char*)tvdlPtr);
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSLink --
+ *
+ * This function replaces the library version of readlink() and
+ * can also be used to make links. The appropriate function for
+ * the filesystem to which pathPtr belongs will be called.
+ *
+ * Results:
+ * If toPtr is NULL, then the result is a Tcl_Obj specifying the
+ * contents of the symbolic link given by 'pathPtr', or NULL if
+ * the symbolic link could not be read. The result is owned by
+ * the caller, which should call Tcl_DecrRefCount when the result
+ * is no longer needed.
+ *
+ * If toPtr is non-NULL, then the result is toPtr if the link action
+ * was successful, or NULL if not. In this case the result has no
+ * additional reference count, and need not be freed. The actual
+ * action to perform is given by the 'linkAction' flags, which is
+ * an or'd combination of:
+ *
+ * TCL_CREATE_SYMBOLIC_LINK
+ * TCL_CREATE_HARD_LINK
+ *
+ * Note that most filesystems will not support linking across
+ * to different filesystems, so this function will usually
+ * fail unless toPtr is in the same FS as pathPtr.
+ *
+ * Side effects:
+ * See readlink() documentation. A new filesystem link
+ * object may appear
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_FSLink(pathPtr, toPtr, linkAction)
+ Tcl_Obj *pathPtr; /* Path of file to readlink or link */
+ Tcl_Obj *toPtr; /* NULL or path to be linked to */
+ int linkAction; /* Action to perform */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSLinkProc *proc = fsPtr->linkProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr, toPtr, linkAction);
+ }
+ }
+ /*
+ * If S_IFLNK isn't defined it means that the machine doesn't
+ * support symbolic links, so the file can't possibly be a
+ * symbolic link. Generate an EINVAL error, which is what
+ * happens on machines that do support symbolic links when
+ * you invoke readlink on a file that isn't a symbolic link.
+ */
+#ifndef S_IFLNK
+ errno = EINVAL;
+#else
+ Tcl_SetErrno(ENOENT);
+#endif /* S_IFLNK */
+ return NULL;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSListVolumes --
+ *
+ * Lists the currently mounted volumes. The chain of functions
+ * that have been "inserted" into the filesystem will be called in
+ * succession; each may return a list of volumes, all of which are
+ * added to the result until all mounted file systems are listed.
+ *
+ * Notice that we assume the lists returned by each filesystem
+ * (if non NULL) have been given a refCount for us already.
+ * However, we are NOT allowed to hang on to the list itself
+ * (it belongs to the filesystem we called). Therefore we
+ * quite naturally add its contents to the result we are
+ * building, and then decrement the refCount.
+ *
+ * Results:
+ * The list of volumes, in an object which has refCount 0.
+ *
+ * Side effects:
+ * None
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSListVolumes(void)
+{
+ FilesystemRecord *fsRecPtr;
+ Tcl_Obj *resultPtr = Tcl_NewObj();
+
+ /*
+ * Call each of the "listVolumes" function in succession.
+ * A non-NULL return value indicates the particular function has
+ * succeeded. We call all the functions registered, since we want
+ * a list of all drives from all filesystems.
+ */
+
+ fsRecPtr = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
+ if (proc != NULL) {
+ Tcl_Obj *thisFsVolumes = (*proc)();
+ if (thisFsVolumes != NULL) {
+ Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
+ Tcl_DecrRefCount(thisFsVolumes);
+ }
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+
+ return resultPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSGetPathType --
+ *
+ * Determines whether a given path is relative to the current
+ * directory, relative to the current volume, or absolute.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+Tcl_FSGetPathType(pathObjPtr)
+ Tcl_Obj *pathObjPtr;
+{
+ return FSGetPathType(pathObjPtr, NULL, NULL);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FSGetPathType --
+ *
+ * Determines whether a given path is relative to the current
+ * directory, relative to the current volume, or absolute. If the
+ * caller wishes to know which filesystem claimed the path (in the
+ * case for which the path is absolute), then a reference to a
+ * filesystem pointer can be passed in (but passing NULL is
+ * acceptable).
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
+ * be set if and only if it is non-NULL and the function's
+ * return value is TCL_PATH_ABSOLUTE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_PathType
+FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
+ Tcl_Obj *pathObjPtr;
+ Tcl_Filesystem **filesystemPtrPtr;
+ int *driveNameLengthPtr;
+{
+ if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
+ return GetPathType(pathObjPtr, filesystemPtrPtr,
+ driveNameLengthPtr, NULL);
+ } else {
+ FsPath *fsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+ if (fsPathPtr->cwdPtr != NULL) {
+ return TCL_PATH_RELATIVE;
+ } else {
+ return GetPathType(pathObjPtr, filesystemPtrPtr,
+ driveNameLengthPtr, NULL);
+ }
+ }
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSSplitPath --
+ *
+ * This function takes the given Tcl_Obj, which should be a valid
+ * path, and returns a Tcl List object containing each segment of
+ * that path as an element.
+ *
+ * Results:
+ * Returns list object with refCount of zero. If the passed in
+ * lenPtr is non-NULL, we use it to return the number of elements
+ * in the returned list.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSSplitPath(pathPtr, lenPtr)
+ Tcl_Obj *pathPtr; /* Path to split. */
+ int *lenPtr; /* int to store number of path elements. */
+{
+ Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
+ Tcl_Filesystem *fsPtr;
+ char separator = '/';
+ int driveNameLength;
+ char *p;
+
+ /*
+ * Perform platform specific splitting.
+ */
+
+ if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
+ == TCL_PATH_ABSOLUTE) {
+ if (fsPtr == &tclNativeFilesystem) {
+ return TclpNativeSplitPath(pathPtr, lenPtr);
+ }
+ } else {
+ return TclpNativeSplitPath(pathPtr, lenPtr);
+ }
+
+ /* We assume separators are single characters */
+ if (fsPtr->filesystemSeparatorProc != NULL) {
+ Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
+ if (sep != NULL) {
+ separator = Tcl_GetString(sep)[0];
+ }
+ }
+
+ /*
+ * Place the drive name as first element of the
+ * result list. The drive name may contain strange
+ * characters, like colons and multiple forward slashes
+ * (for example 'ftp://' is a valid vfs drive name)
+ */
+ result = Tcl_NewObj();
+ p = Tcl_GetString(pathPtr);
+ Tcl_ListObjAppendElement(NULL, result,
+ Tcl_NewStringObj(p, driveNameLength));
+ p+= driveNameLength;
+
+ /* Add the remaining path elements to the list */
+ for (;;) {
+ char *elementStart = p;
+ int length;
+ while ((*p != '\0') && (*p != separator)) {
+ p++;
+ }
+ length = p - elementStart;
+ if (length > 0) {
+ Tcl_Obj *nextElt;
+ if (elementStart[0] == '~') {
+ nextElt = Tcl_NewStringObj("./",2);
+ Tcl_AppendToObj(nextElt, elementStart, length);
+ } else {
+ nextElt = Tcl_NewStringObj(elementStart, length);
+ }
+ Tcl_ListObjAppendElement(NULL, result, nextElt);
+ }
+ if (*p++ == '\0') {
+ break;
+ }
+ }
+
+ /*
+ * Compute the number of elements in the result.
+ */
+
+ if (lenPtr != NULL) {
+ Tcl_ListObjLength(NULL, result, lenPtr);
+ }
+ return result;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSJoinPath --
+ *
+ * This function takes the given Tcl_Obj, which should be a valid
+ * list, and returns the path object given by considering the
+ * first 'elements' elements as valid path segments. If elements < 0,
+ * we use the entire list.
+ *
+ * Results:
+ * Returns object with refCount of zero.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+Tcl_FSJoinPath(listObj, elements)
+ Tcl_Obj *listObj;
+ int elements;
+{
+ Tcl_Obj *res;
+ int i;
+ Tcl_Filesystem *fsPtr = NULL;
+
+ if (elements < 0) {
+ if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
+ return NULL;
+ }
+ } else {
+ /* Just make sure it is a valid list */
+ int listTest;
+ if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
+ return NULL;
+ }
+ /*
+ * Correct this if it is too large, otherwise we will
+ * waste our timing joining null elements to the path
+ */
+ if (elements > listTest) {
+ elements = listTest;
+ }
+ }
+
+ res = Tcl_NewObj();
+
+ for (i = 0; i < elements; i++) {
+ Tcl_Obj *elt;
+ int driveNameLength;
+ Tcl_PathType type;
+ char *strElt;
+ int strEltLen;
+ int length;
+ char *ptr;
+ Tcl_Obj *driveName = NULL;
+
+ Tcl_ListObjIndex(NULL, listObj, i, &elt);
+ strElt = Tcl_GetStringFromObj(elt, &strEltLen);
+ type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName);
+ if (type != TCL_PATH_RELATIVE) {
+ /* Zero out the current result */
+ Tcl_DecrRefCount(res);
+ if (driveName != NULL) {
+ res = Tcl_DuplicateObj(driveName);
+ Tcl_DecrRefCount(driveName);
+ } else {
+ res = Tcl_NewStringObj(strElt, driveNameLength);
+ }
+ strElt += driveNameLength;
+ }
+
+ ptr = Tcl_GetStringFromObj(res, &length);
+
+ /*
+ * Strip off any './' before a tilde, unless this is the
+ * beginning of the path.
+ */
+ if (length > 0 && strEltLen > 0) {
+ if ((strElt[0] == '.') && (strElt[1] == '/')
+ && (strElt[2] == '~')) {
+ strElt += 2;
+ }
+ }
+
+ /*
+ * A NULL value for fsPtr at this stage basically means
+ * we're trying to join a relative path onto something
+ * which is also relative (or empty). There's nothing
+ * particularly wrong with that.
+ */
+ if (*strElt == '\0') continue;
+
+ if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
+ TclpNativeJoinPath(res, strElt);
+ } else {
+ char separator = '/';
+ int needsSep = 0;
+
+ if (fsPtr->filesystemSeparatorProc != NULL) {
+ Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
+ if (sep != NULL) {
+ separator = Tcl_GetString(sep)[0];
+ }
+ }
+
+ if (length > 0 && ptr[length -1] != '/') {
+ Tcl_AppendToObj(res, &separator, 1);
+ length++;
+ }
+ Tcl_SetObjLength(res, length + (int) strlen(strElt));
+
+ ptr = Tcl_GetString(res) + length;
+ for (; *strElt != '\0'; strElt++) {
+ if (*strElt == separator) {
+ while (strElt[1] == separator) {
+ strElt++;
+ }
+ if (strElt[1] != '\0') {
+ if (needsSep) {
+ *ptr++ = separator;
+ }
+ }
+ } else {
+ *ptr++ = *strElt;
+ needsSep = 1;
+ }
+ }
+ length = ptr - Tcl_GetString(res);
+ Tcl_SetObjLength(res, length);
+ }
+ }
+ return res;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetPathType --
+ *
+ * Helper function used by FSGetPathType.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
+ * be set if and only if it is non-NULL and the function's
+ * return value is TCL_PATH_ABSOLUTE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_PathType
+GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
+ Tcl_Obj *pathObjPtr;
+ Tcl_Filesystem **filesystemPtrPtr;
+ int *driveNameLengthPtr;
+ Tcl_Obj **driveNameRef;
+{
+ FilesystemRecord *fsRecPtr;
+ int pathLen;
+ char *path;
+ Tcl_PathType type = TCL_PATH_RELATIVE;
+
+ path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
+
+ /*
+ * Call each of the "listVolumes" function in succession, checking
+ * whether the given path is an absolute path on any of the volumes
+ * returned (this is done by checking whether the path's prefix
+ * matches).
+ */
+
+ fsRecPtr = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
+ /*
+ * We want to skip the native filesystem in this loop because
+ * otherwise we won't necessarily pass all the Tcl testsuite --
+ * this is because some of the tests artificially change the
+ * current platform (between mac, win, unix) but the list
+ * of volumes we get by calling (*proc) will reflect the current
+ * (real) platform only and this may cause some tests to fail.
+ * In particular, on unix '/' will match the beginning of
+ * certain absolute Windows paths starting '//' and those tests
+ * will go wrong.
+ *
+ * Besides these test-suite issues, there is one other reason
+ * to skip the native filesystem --- since the tclFilename.c
+ * code has nice fast 'absolute path' checkers, we don't want
+ * to waste time repeating that effort here, and this
+ * function is actually called quite often, so if we can
+ * save the overhead of the native filesystem returning us
+ * a list of volumes all the time, it is better.
+ */
+ if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
+ int numVolumes;
+ Tcl_Obj *thisFsVolumes = (*proc)();
+ if (thisFsVolumes != NULL) {
+ if (Tcl_ListObjLength(NULL, thisFsVolumes,
+ &numVolumes) != TCL_OK) {
+ /*
+ * This is VERY bad; the Tcl_FSListVolumesProc
+ * didn't return a valid list. Set numVolumes to
+ * -1 so that we skip the while loop below and just
+ * return with the current value of 'type'.
+ *
+ * It would be better if we could signal an error
+ * here (but panic seems a bit excessive).
+ */
+ numVolumes = -1;
+ }
+ while (numVolumes > 0) {
+ Tcl_Obj *vol;
+ int len;
+ char *strVol;
+
+ numVolumes--;
+ Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
+ strVol = Tcl_GetStringFromObj(vol,&len);
+ if (pathLen < len) {
+ continue;
+ }
+ if (strncmp(strVol, path, (size_t) len) == 0) {
+ type = TCL_PATH_ABSOLUTE;
+ if (filesystemPtrPtr != NULL) {
+ *filesystemPtrPtr = fsRecPtr->fsPtr;
+ }
+ if (driveNameLengthPtr != NULL) {
+ *driveNameLengthPtr = len;
+ }
+ if (driveNameRef != NULL) {
+ *driveNameRef = vol;
+ Tcl_IncrRefCount(vol);
+ }
+ break;
+ }
+ }
+ Tcl_DecrRefCount(thisFsVolumes);
+ if (type == TCL_PATH_ABSOLUTE) {
+ /* We don't need to examine any more filesystems */
+ break;
+ }
+ }
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+
+ if (type != TCL_PATH_ABSOLUTE) {
+ type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
+ driveNameRef);
+ if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
+ *filesystemPtrPtr = &tclNativeFilesystem;
+ }
+ }
+ return type;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSRenameFile --
+ *
+ * If the two paths given belong to the same filesystem, we call
+ * that filesystems rename function. Otherwise we simply
+ * return the posix error 'EXDEV', and -1.
+ *
+ * Results:
+ * Standard Tcl error code if a function was called.
+ *
+ * Side effects:
+ * A file may be renamed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSRenameFile(srcPathPtr, destPathPtr)
+ Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed
+ * (UTF-8). */
+ Tcl_Obj *destPathPtr; /* New pathname of file or directory
+ * (UTF-8). */
+{
+ int retVal = -1;
+ Tcl_Filesystem *fsPtr, *fsPtr2;
+ fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
+ fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
+
+ if (fsPtr == fsPtr2 && fsPtr != NULL) {
+ Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;
+ if (proc != NULL) {
+ retVal = (*proc)(srcPathPtr, destPathPtr);
+ }
+ }
+ if (retVal == -1) {
+ Tcl_SetErrno(EXDEV);
+ }
+ return retVal;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSCopyFile --
+ *
+ * If the two paths given belong to the same filesystem, we call
+ * that filesystem's copy function. Otherwise we simply
+ * return the posix error 'EXDEV', and -1.
+ *
+ * Note that in the native filesystems, 'copyFileProc' is defined
+ * to copy soft links (i.e. it copies the links themselves, not
+ * the things they point to).
+ *
+ * Results:
+ * Standard Tcl error code if a function was called.
+ *
+ * Side effects:
+ * A file may be copied.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSCopyFile(srcPathPtr, destPathPtr)
+ Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */
+{
+ int retVal = -1;
+ Tcl_Filesystem *fsPtr, *fsPtr2;
+ fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
+ fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
+
+ if (fsPtr == fsPtr2 && fsPtr != NULL) {
+ Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc;
+ if (proc != NULL) {
+ retVal = (*proc)(srcPathPtr, destPathPtr);
+ }
+ }
+ if (retVal == -1) {
+ Tcl_SetErrno(EXDEV);
+ }
+ return retVal;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclCrossFilesystemCopy --
+ *
+ * Helper for above function, and for Tcl_FSLoadFile, to copy
+ * files from one filesystem to another. This function will
+ * overwrite the target file if it already exists.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A file may be created.
+ *
+ *---------------------------------------------------------------------------
+ */
+int
+TclCrossFilesystemCopy(interp, source, target)
+ Tcl_Interp *interp; /* For error messages */
+ Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */
+{
+ int result = TCL_ERROR;
+ int prot = 0666;
+
+ Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot);
+ if (out != NULL) {
+ /* It looks like we can copy it over */
+ Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source,
+ "r", prot);
+ if (in == NULL) {
+ /* This is very strange, we checked this above */
+ Tcl_Close(interp, out);
+ } else {
+ Tcl_StatBuf sourceStatBuf;
+ struct utimbuf tval;
+ /*
+ * Copy it synchronously. We might wish to add an
+ * asynchronous option to support vfs's which are
+ * slow (e.g. network sockets).
+ */
+ Tcl_SetChannelOption(interp, in, "-translation", "binary");
+ Tcl_SetChannelOption(interp, out, "-translation", "binary");
+
+ if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
+ result = TCL_OK;
+ }
+ /*
+ * If the copy failed, assume that copy channel left
+ * a good error message.
+ */
+ Tcl_Close(interp, in);
+ Tcl_Close(interp, out);
+
+ /* Set modification date of copied file */
+ if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
+ tval.actime = sourceStatBuf.st_atime;
+ tval.modtime = sourceStatBuf.st_mtime;
+ Tcl_FSUtime(source, &tval);
+ }
+ }
+ }
+ return result;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSDeleteFile --
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A file may be deleted.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSDeleteFile(pathPtr)
+ Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSCreateDirectory --
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A directory may be created.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSCreateDirectory(pathPtr)
+ Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
+ if (proc != NULL) {
+ return (*proc)(pathPtr);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSCopyDirectory --
+ *
+ * If the two paths given belong to the same filesystem, we call
+ * that filesystems copy-directory function. Otherwise we simply
+ * return the posix error 'EXDEV', and -1.
+ *
+ * Results:
+ * Standard Tcl error code if a function was called.
+ *
+ * Side effects:
+ * A directory may be copied.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
+ Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied
+ * (UTF-8). */
+ Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */
+ Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
+ * new object containing name of file
+ * causing error, with refCount 1. */
+{
+ int retVal = -1;
+ Tcl_Filesystem *fsPtr, *fsPtr2;
+ fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
+ fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
+
+ if (fsPtr == fsPtr2 && fsPtr != NULL) {
+ Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc;
+ if (proc != NULL) {
+ retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr);
+ }
+ }
+ if (retVal == -1) {
+ Tcl_SetErrno(EXDEV);
+ }
+ return retVal;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSRemoveDirectory --
+ *
+ * The appropriate function for the filesystem to which pathPtr
+ * belongs will be called.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * A directory may be deleted.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
+ Tcl_Obj *pathPtr; /* Pathname of directory to be removed
+ * (UTF-8). */
+ int recursive; /* If non-zero, removes directories that
+ * are nonempty. Otherwise, will only remove
+ * empty directories. */
+ Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
+ * new object containing name of file
+ * causing error, with refCount 1. */
+{
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ if (fsPtr != NULL) {
+ Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
+ if (proc != NULL) {
+ if (recursive) {
+ /*
+ * We check whether the cwd lies inside this directory
+ * and move it if it does.
+ */
+ Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
+ if (cwdPtr != NULL) {
+ char *cwdStr, *normPathStr;
+ int cwdLen, normLen;
+ Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (normPath != NULL) {
+ normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
+ cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
+ if ((cwdLen >= normLen) && (strncmp(normPathStr,
+ cwdStr, (size_t) normLen) == 0)) {
+ /*
+ * the cwd is inside the directory, so we
+ * perform a 'cd [file dirname $path]'
+ */
+ Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr);
+ Tcl_FSChdir(dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ }
+ }
+ Tcl_DecrRefCount(cwdPtr);
+ }
+ }
+ return (*proc)(pathPtr, recursive, errorPtr);
+ }
+ }
+ Tcl_SetErrno(ENOENT);
+ return -1;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSConvertToPathType --
+ *
+ * This function tries to convert the given Tcl_Obj to a valid
+ * Tcl path type, taking account of the fact that the cwd may
+ * have changed even if this object is already supposedly of
+ * the correct type.
+ *
+ * The filename may begin with "~" (to indicate current user's
+ * home directory) or "~<user>" (to indicate any user's home
+ * directory).
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * The old representation may be freed, and new memory allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_FSConvertToPathType(interp, objPtr)
+ Tcl_Interp *interp; /* Interpreter in which to store error
+ * message (if necessary). */
+ Tcl_Obj *objPtr; /* Object to convert to a valid, current
+ * path type. */
+{
+ /*
+ * While it is bad practice to examine an object's type directly,
+ * this is actually the best thing to do here. The reason is that
+ * if we are converting this object to FsPath type for the first
+ * time, we don't need to worry whether the 'cwd' has changed.
+ * On the other hand, if this object is already of FsPath type,
+ * and is a relative path, we do have to worry about the cwd.
+ * If the cwd has changed, we must recompute the path.
+ */
+ if (objPtr->typePtr == &tclFsPathType) {
+ FsPath *fsPathPtr = (FsPath*) objPtr->internalRep.otherValuePtr;
+ if (fsPathPtr->filesystemEpoch != theFilesystemEpoch) {
+ FreeFsPathInternalRep(objPtr);
+ objPtr->typePtr = NULL;
+ return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ }
+ if (fsPathPtr->cwdPtr == NULL) {
+ return TCL_OK;
+ } else {
+ if (FsCwdPointerEquals(fsPathPtr->cwdPtr)) {
+ return TCL_OK;
+ } else {
+ FreeFsPathInternalRep(objPtr);
+ objPtr->typePtr = NULL;
+ return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ }
+ }
+ } else {
+ return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ }
+}
+
+\f
+/*
+ * Helper function for SetFsPathFromAny. Returns position of first
+ * directory delimiter in the path.
+ */
+static int
+FindSplitPos(path, separator)
+ char *path;
+ char *separator;
+{
+ int count = 0;
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ case TCL_PLATFORM_MAC:
+ while (path[count] != 0) {
+ if (path[count] == *separator) {
+ return count;
+ }
+ count++;
+ }
+ break;
+
+ case TCL_PLATFORM_WINDOWS:
+ while (path[count] != 0) {
+ if (path[count] == *separator || path[count] == '\\') {
+ return count;
+ }
+ count++;
+ }
+ break;
+ }
+ return count;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * SetFsPathFromAbsoluteNormalized --
+ *
+ * Like SetFsPathFromAny, but assumes the given object is an
+ * absolute normalized path. Only for internal use.
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * The old representation may be freed, and new memory allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+SetFsPathFromAbsoluteNormalized(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ FsPath *fsPathPtr;
+
+ if (objPtr->typePtr == &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ /* Free old representation */
+ if (objPtr->typePtr != NULL) {
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "can't find object",
+ "string representation", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ }
+ if ((objPtr->typePtr->freeIntRepProc) != NULL) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ }
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+ /* It's a pure normalized absolute path */
+ fsPathPtr->translatedPathPtr = NULL;
+ fsPathPtr->normPathPtr = objPtr;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsRecPtr = NULL;
+ fsPathPtr->filesystemEpoch = theFilesystemEpoch;
+
+ objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
+ objPtr->typePtr = &tclFsPathType;
+
+ return TCL_OK;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * SetFsPathFromAny --
+ *
+ * This function tries to convert the given Tcl_Obj to a valid
+ * Tcl path type.
+ *
+ * The filename may begin with "~" (to indicate current user's
+ * home directory) or "~<user>" (to indicate any user's home
+ * directory).
+ *
+ * Results:
+ * Standard Tcl error code.
+ *
+ * Side effects:
+ * The old representation may be freed, and new memory allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+SetFsPathFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ int len;
+ FsPath *fsPathPtr;
+ Tcl_Obj *transPtr;
+ char *name;
+
+ if (objPtr->typePtr == &tclFsPathType) {
+ return TCL_OK;
+ }
+
+ /*
+ * First step is to translate the filename. This is similar to
+ * Tcl_TranslateFilename, but shouldn't convert everything to
+ * windows backslashes on that platform. The current
+ * implementation of this piece is a slightly optimised version
+ * of the various Tilde/Split/Join stuff to avoid multiple
+ * split/join operations.
+ *
+ * We remove any trailing directory separator.
+ *
+ * However, the split/join routines are quite complex, and
+ * one has to make sure not to break anything on Unix, Win
+ * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise
+ * most of the code).
+ */
+ name = Tcl_GetStringFromObj(objPtr,&len);
+
+ /*
+ * Handle tilde substitutions, if needed.
+ */
+ if (name[0] == '~') {
+ char *expandedUser;
+ Tcl_DString temp;
+ int split;
+ char separator='/';
+
+ if (tclPlatform==TCL_PLATFORM_MAC) {
+ if (strchr(name, ':') != NULL) separator = ':';
+ }
+
+ split = FindSplitPos(name, &separator);
+ if (split != len) {
+ /* We have multiple pieces '~user/foo/bar...' */
+ name[split] = '\0';
+ }
+ /* Do some tilde substitution */
+ if (name[1] == '\0') {
+ /* We have just '~' */
+ CONST char *dir;
+ Tcl_DString dirString;
+ if (split != len) { name[split] = separator; }
+
+ dir = TclGetEnv("HOME", &dirString);
+ if (dir == NULL) {
+ if (interp) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't find HOME environment ",
+ "variable to expand path", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_DStringInit(&temp);
+ Tcl_JoinPath(1, &dir, &temp);
+ Tcl_DStringFree(&dirString);
+ } else {
+ /* We have a user name '~user' */
+ Tcl_DStringInit(&temp);
+ if (TclpGetUserHome(name+1, &temp) == NULL) {
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "user \"", (name+1),
+ "\" doesn't exist", (char *) NULL);
+ }
+ Tcl_DStringFree(&temp);
+ if (split != len) { name[split] = separator; }
+ return TCL_ERROR;
+ }
+ if (split != len) { name[split] = separator; }
+ }
+
+ expandedUser = Tcl_DStringValue(&temp);
+ transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
+
+ if (split != len) {
+ /* Join up the tilde substitution with the rest */
+ if (name[split+1] == separator) {
+
+ /*
+ * Somewhat tricky case like ~//foo/bar.
+ * Make use of Split/Join machinery to get it right.
+ * Assumes all paths beginning with ~ are part of the
+ * native filesystem.
+ */
+
+ int objc;
+ Tcl_Obj **objv;
+ Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL);
+ Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
+ /* Skip '~'. It's replaced by its expansion */
+ objc--; objv++;
+ while (objc--) {
+ TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
+ }
+ Tcl_DecrRefCount(parts);
+ } else {
+ /* Simple case. "rest" is relative path. Just join it. */
+ Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1);
+ transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest);
+ }
+ }
+ Tcl_DStringFree(&temp);
+ } else {
+ transPtr = Tcl_FSJoinToPath(objPtr,0,NULL);
+ }
+
+ /*
+ * Now we have a translated filename in 'transPtr'. This will have
+ * forward slashes on Windows, and will not contain any ~user
+ * sequences.
+ */
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+ fsPathPtr->translatedPathPtr = transPtr;
+ Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
+ fsPathPtr->normPathPtr = NULL;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = NULL;
+ fsPathPtr->fsRecPtr = NULL;
+ fsPathPtr->filesystemEpoch = theFilesystemEpoch;
+
+ /*
+ * Free old representation before installing our new one.
+ */
+ if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
+ (objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
+ objPtr->typePtr = &tclFsPathType;
+
+ return TCL_OK;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSNewNativePath --
+ *
+ * This function performs the something like that reverse of the
+ * usual obj->path->nativerep conversions. If some code retrieves
+ * a path in native form (from, e.g. readlink or a native dialog),
+ * and that path is to be used at the Tcl level, then calling
+ * this function is an efficient way of creating the appropriate
+ * path object type.
+ *
+ * Any memory which is allocated for 'clientData' should be retained
+ * until clientData is passed to the filesystem's freeInternalRepProc
+ * when it can be freed. The built in platform-specific filesystems
+ * use 'ckalloc' to allocate clientData, and ckfree to free it.
+ *
+ * Results:
+ * NULL or a valid path object pointer, with refCount zero.
+ *
+ * Side effects:
+ * New memory may be allocated.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_FSNewNativePath(fromFilesystem, clientData)
+ Tcl_Filesystem* fromFilesystem;
+ ClientData clientData;
+{
+ Tcl_Obj *objPtr;
+ FsPath *fsPathPtr;
+ FilesystemRecord *fsFromPtr;
+ Tcl_FSInternalToNormalizedProc *proc;
+ int epoch;
+
+ fsFromPtr = GetFilesystemRecord(fromFilesystem, &epoch);
+
+ if (fsFromPtr == NULL) {
+ return NULL;
+ }
+
+ proc = fsFromPtr->fsPtr->internalToNormalizedProc;
+
+ if (proc == NULL) {
+ return NULL;
+ }
+
+ objPtr = (*proc)(clientData);
+ if (objPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Free old representation; shouldn't normally be any,
+ * but best to be safe.
+ */
+ if (objPtr->typePtr != NULL) {
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ return NULL;
+ }
+ objPtr->typePtr->updateStringProc(objPtr);
+ }
+ if ((objPtr->typePtr->freeIntRepProc) != NULL) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ }
+ }
+
+ fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
+ fsPathPtr->translatedPathPtr = NULL;
+ /* Circular reference, by design */
+ fsPathPtr->normPathPtr = objPtr;
+ fsPathPtr->cwdPtr = NULL;
+ fsPathPtr->nativePathPtr = clientData;
+ fsPathPtr->fsRecPtr = fsFromPtr;
+ /* We must increase the refCount for this filesystem. */
+ fsPathPtr->fsRecPtr->fileRefCount++;
+ fsPathPtr->filesystemEpoch = epoch;
+
+ objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
+ objPtr->typePtr = &tclFsPathType;
+ return objPtr;
+}
+
+static void
+FreeFsPathInternalRep(pathObjPtr)
+ Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
+{
+ register FsPath* fsPathPtr =
+ (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+
+ if (fsPathPtr->translatedPathPtr != NULL) {
+ Tcl_DecrRefCount(fsPathPtr->translatedPathPtr);
+ }
+ if (fsPathPtr->normPathPtr != NULL) {
+ if (fsPathPtr->normPathPtr != pathObjPtr) {
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ }
+ fsPathPtr->normPathPtr = NULL;
+ }
+ if (fsPathPtr->cwdPtr != NULL) {
+ Tcl_DecrRefCount(fsPathPtr->cwdPtr);
+ }
+ if (fsPathPtr->nativePathPtr != NULL) {
+ if (fsPathPtr->fsRecPtr != NULL) {
+ if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) {
+ (*fsPathPtr->fsRecPtr->fsPtr
+ ->freeInternalRepProc)(fsPathPtr->nativePathPtr);
+ fsPathPtr->nativePathPtr = NULL;
+ }
+ }
+ }
+ if (fsPathPtr->fsRecPtr != NULL) {
+ fsPathPtr->fsRecPtr->fileRefCount--;
+ if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
+ /* It has been unregistered already */
+ ckfree((char *)fsPathPtr->fsRecPtr);
+ }
+ }
+
+ ckfree((char*) fsPathPtr);
+}
+
+static void
+DupFsPathInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */
+ Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */
+{
+ register FsPath* srcFsPathPtr =
+ (FsPath*) srcPtr->internalRep.otherValuePtr;
+ register FsPath* copyFsPathPtr =
+ (FsPath*) ckalloc((unsigned)sizeof(FsPath));
+ Tcl_FSDupInternalRepProc *dupProc;
+
+ copyPtr->internalRep.otherValuePtr = (VOID *) copyFsPathPtr;
+
+ if (srcFsPathPtr->translatedPathPtr != NULL) {
+ copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
+ Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
+ } else {
+ copyFsPathPtr->translatedPathPtr = NULL;
+ }
+
+ if (srcFsPathPtr->normPathPtr != NULL) {
+ copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
+ if (copyFsPathPtr->normPathPtr != copyPtr) {
+ Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
+ }
+ } else {
+ copyFsPathPtr->normPathPtr = NULL;
+ }
+
+ if (srcFsPathPtr->cwdPtr != NULL) {
+ copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
+ Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
+ } else {
+ copyFsPathPtr->cwdPtr = NULL;
+ }
+
+ if (srcFsPathPtr->fsRecPtr != NULL
+ && srcFsPathPtr->nativePathPtr != NULL) {
+ dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
+ if (dupProc != NULL) {
+ copyFsPathPtr->nativePathPtr =
+ (*dupProc)(srcFsPathPtr->nativePathPtr);
+ } else {
+ copyFsPathPtr->nativePathPtr = NULL;
+ }
+ } else {
+ copyFsPathPtr->nativePathPtr = NULL;
+ }
+ copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
+ copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
+ if (copyFsPathPtr->fsRecPtr != NULL) {
+ copyFsPathPtr->fsRecPtr->fileRefCount++;
+ }
+
+ copyPtr->typePtr = &tclFsPathType;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetTranslatedPath --
+ *
+ * This function attempts to extract the translated path
+ * from the given Tcl_Obj. If the translation succeeds (i.e. the
+ * object is a valid path), then it is returned. Otherwise NULL
+ * will be returned, and an error message may be left in the
+ * interpreter (if it is non-NULL)
+ *
+ * Results:
+ * NULL or a valid Tcl_Obj pointer.
+ *
+ * Side effects:
+ * Only those of 'Tcl_FSConvertToPathType'
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSGetTranslatedPath(interp, pathPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj* pathPtr;
+{
+ register FsPath* srcFsPathPtr;
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) pathPtr->internalRep.otherValuePtr;
+ if (srcFsPathPtr->translatedPathPtr == NULL) {
+ /*
+ * It is a pure absolute, normalized path object.
+ * This is something like being a 'pure list'. The
+ * object's string, translatedPath and normalizedPath
+ * are all identical.
+ */
+ return srcFsPathPtr->normPathPtr;
+ } else {
+ /* It is an ordinary path object */
+ return srcFsPathPtr->translatedPathPtr;
+ }
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetTranslatedStringPath --
+ *
+ * This function attempts to extract the translated path
+ * from the given Tcl_Obj. If the translation succeeds (i.e. the
+ * object is a valid path), then the path is returned. Otherwise NULL
+ * will be returned, and an error message may be left in the
+ * interpreter (if it is non-NULL)
+ *
+ * Results:
+ * NULL or a valid string.
+ *
+ * Side effects:
+ * Only those of 'Tcl_FSConvertToPathType'
+ *
+ *---------------------------------------------------------------------------
+ */
+CONST char*
+Tcl_FSGetTranslatedStringPath(interp, pathPtr)
+Tcl_Interp *interp;
+Tcl_Obj* pathPtr;
+{
+ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (transPtr == NULL) {
+ return NULL;
+ } else {
+ return Tcl_GetString(transPtr);
+ }
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetNormalizedPath --
+ *
+ * This important function attempts to extract from the given Tcl_Obj
+ * a unique normalised path representation, whose string value can
+ * be used as a unique identifier for the file.
+ *
+ * Results:
+ * NULL or a valid path object pointer.
+ *
+ * Side effects:
+ * New memory may be allocated. The Tcl 'errno' may be modified
+ * in the process of trying to examine various path possibilities.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+Tcl_FSGetNormalizedPath(interp, pathObjPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj* pathObjPtr;
+{
+ register FsPath* srcFsPathPtr;
+ if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+ if (srcFsPathPtr->normPathPtr == NULL) {
+ int relative = 0;
+ /*
+ * Since normPathPtr is NULL, but this is a valid path
+ * object, we know that the translatedPathPtr cannot be NULL.
+ */
+ Tcl_Obj *absolutePath = srcFsPathPtr->translatedPathPtr;
+ char *path = Tcl_GetString(absolutePath);
+
+ /*
+ * We have to be a little bit careful here to avoid infinite loops
+ * we're asking Tcl_FSGetPathType to return the path's type, but
+ * that call can actually result in a lot of other filesystem
+ * action, which might loop back through here.
+ */
+ if ((path[0] != '\0') &&
+ (Tcl_FSGetPathType(pathObjPtr) == TCL_PATH_RELATIVE)) {
+ Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
+
+ if (cwd == NULL) {
+ return NULL;
+ }
+
+ absolutePath = Tcl_FSJoinToPath(cwd, 1, &absolutePath);
+ Tcl_IncrRefCount(absolutePath);
+ Tcl_DecrRefCount(cwd);
+
+ relative = 1;
+ }
+ /* Already has refCount incremented */
+ srcFsPathPtr->normPathPtr = FSNormalizeAbsolutePath(interp, absolutePath);
+ if (!strcmp(Tcl_GetString(srcFsPathPtr->normPathPtr),
+ Tcl_GetString(pathObjPtr))) {
+ /*
+ * The path was already normalized.
+ * Get rid of the duplicate.
+ */
+ Tcl_DecrRefCount(srcFsPathPtr->normPathPtr);
+ /*
+ * We do *not* increment the refCount for
+ * this circular reference
+ */
+ srcFsPathPtr->normPathPtr = pathObjPtr;
+ }
+ if (relative) {
+ /* This was returned by Tcl_FSJoinToPath above */
+ Tcl_DecrRefCount(absolutePath);
+
+ /* Get a quick, temporary lock on the cwd while we copy it */
+ Tcl_MutexLock(&cwdMutex);
+ srcFsPathPtr->cwdPtr = cwdPathPtr;
+ Tcl_IncrRefCount(srcFsPathPtr->cwdPtr);
+ Tcl_MutexUnlock(&cwdMutex);
+ }
+ }
+ return srcFsPathPtr->normPathPtr;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetInternalRep --
+ *
+ * Extract the internal representation of a given path object,
+ * in the given filesystem. If the path object belongs to a
+ * different filesystem, we return NULL.
+ *
+ * If the internal representation is currently NULL, we attempt
+ * to generate it, by calling the filesystem's
+ * 'Tcl_FSCreateInternalRepProc'.
+ *
+ * Results:
+ * NULL or a valid internal representation.
+ *
+ * Side effects:
+ * An attempt may be made to convert the object.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
+ Tcl_Obj* pathObjPtr;
+ Tcl_Filesystem *fsPtr;
+{
+ register FsPath* srcFsPathPtr;
+
+ if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
+ return NULL;
+ }
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+
+ /*
+ * We will only return the native representation for the caller's
+ * filesystem. Otherwise we will simply return NULL. This means
+ * that there must be a unique bi-directional mapping between paths
+ * and filesystems, and that this mapping will not allow 'remapped'
+ * files -- files which are in one filesystem but mapped into
+ * another. Another way of putting this is that 'stacked'
+ * filesystems are not allowed. We recognise that this is a
+ * potentially useful feature for the future.
+ *
+ * Even something simple like a 'pass through' filesystem which
+ * logs all activity and passes the calls onto the native system
+ * would be nice, but not easily achievable with the current
+ * implementation.
+ */
+ if (srcFsPathPtr->fsRecPtr == NULL) {
+ /*
+ * This only usually happens in wrappers like TclpStat which
+ * create a string object and pass it to TclpObjStat. Code
+ * which calls the Tcl_FS.. functions should always have a
+ * filesystem already set. Whether this code path is legal or
+ * not depends on whether we decide to allow external code to
+ * call the native filesystem directly. It is at least safer
+ * to allow this sub-optimal routing.
+ */
+ Tcl_FSGetFileSystemForPath(pathObjPtr);
+
+ /*
+ * If we fail through here, then the path is probably not a
+ * valid path in the filesystsem, and is most likely to be a
+ * use of the empty path "" via a direct call to one of the
+ * objectified interfaces (e.g. from the Tcl testsuite).
+ */
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+ if (srcFsPathPtr->fsRecPtr == NULL) {
+ return NULL;
+ }
+ }
+
+ if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
+ /*
+ * There is still one possibility we should consider; if the
+ * file belongs to a different filesystem, perhaps it is
+ * actually linked through to a file in our own filesystem
+ * which we do care about. The way we can check for this
+ * is we ask what filesystem this path belongs to.
+ */
+ Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
+ if (actualFs == fsPtr) {
+ return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
+ }
+ return NULL;
+ }
+
+ if (srcFsPathPtr->nativePathPtr == NULL) {
+ Tcl_FSCreateInternalRepProc *proc;
+ proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
+
+ if (proc == NULL) {
+ return NULL;
+ }
+ srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr);
+ }
+ return srcFsPathPtr->nativePathPtr;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FSGetNativePath --
+ *
+ * This function is for use by the Win/Unix/MacOS native filesystems,
+ * so that they can easily retrieve the native (char* or TCHAR*)
+ * representation of a path. Other filesystems will probably
+ * want to implement similar functions. They basically act as a
+ * safety net around Tcl_FSGetInternalRep. Normally your file-
+ * system procedures will always be called with path objects
+ * already converted to the correct filesystem, but if for
+ * some reason they are called directly (i.e. by procedures
+ * not in this file), then one cannot necessarily guarantee that
+ * the path object pointer is from the correct filesystem.
+ *
+ * Note: in the future it might be desireable to have separate
+ * versions of this function with different signatures, for
+ * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc.
+ * Right now, since native paths are all string based, we use just
+ * one function. On MacOS we could possibly use an FSSpec or
+ * FSRef as the native representation.
+ *
+ * Results:
+ * NULL or a valid native path.
+ *
+ * Side effects:
+ * See Tcl_FSGetInternalRep.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+CONST char *
+Tcl_FSGetNativePath(pathObjPtr)
+ Tcl_Obj *pathObjPtr;
+{
+ return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem);
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativeCreateNativeRep --
+ *
+ * Create a native representation for the given path.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+static ClientData
+NativeCreateNativeRep(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ char *nativePathPtr;
+ Tcl_DString ds;
+ Tcl_Obj* normPtr;
+ int len;
+ char *str;
+
+ /* Make sure the normalized path is set */
+ normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
+
+ str = Tcl_GetStringFromObj(normPtr,&len);
+#ifdef __WIN32__
+ Tcl_WinUtfToTChar(str, len, &ds);
+ if (tclWinProcs->useWide) {
+ nativePathPtr = ckalloc((unsigned)(sizeof(WCHAR)+Tcl_DStringLength(&ds)));
+ memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
+ (size_t) (sizeof(WCHAR)+Tcl_DStringLength(&ds)));
+ } else {
+ nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds)));
+ memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
+ (size_t) (sizeof(char)+Tcl_DStringLength(&ds)));
+ }
+#else
+ Tcl_UtfToExternalDString(NULL, str, len, &ds);
+ nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds)));
+ memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
+ (size_t) (sizeof(char)+Tcl_DStringLength(&ds)));
+#endif
+
+ Tcl_DStringFree(&ds);
+ return (ClientData)nativePathPtr;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpNativeToNormalized --
+ *
+ * Convert native format to a normalized path object, with refCount
+ * of zero.
+ *
+ * Results:
+ * A valid normalized path.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+TclpNativeToNormalized(clientData)
+ ClientData clientData;
+{
+ Tcl_DString ds;
+ Tcl_Obj *objPtr;
+ CONST char *copy;
+ int len;
+
+#ifdef __WIN32__
+ Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
+#else
+ Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
+#endif
+
+ copy = Tcl_DStringValue(&ds);
+ len = Tcl_DStringLength(&ds);
+
+#ifdef __WIN32__
+ /*
+ * Certain native path representations on Windows have this special
+ * prefix to indicate that they are to be treated specially. For
+ * example extremely long paths, or symlinks
+ */
+ if (*copy == '\\') {
+ if (0 == strncmp(copy,"\\??\\",4)) {
+ copy += 4;
+ len -= 4;
+ } else if (0 == strncmp(copy,"\\\\?\\",4)) {
+ copy += 4;
+ len -= 4;
+ }
+ }
+#endif
+
+ objPtr = Tcl_NewStringObj(copy,len);
+ Tcl_DStringFree(&ds);
+
+ return objPtr;
+}
+
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * NativeDupInternalRep --
+ *
+ * Duplicate the native representation.
+ *
+ * Results:
+ * The copied native representation, or NULL if it is not possible
+ * to copy the representation.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+static ClientData
+NativeDupInternalRep(clientData)
+ ClientData clientData;
+{
+ ClientData copy;
+ size_t len;
+
+ if (clientData == NULL) {
+ return NULL;
+ }
+
+#ifdef __WIN32__
+ if (tclWinProcs->useWide) {
+ /* unicode representation when running on NT/2K/XP */
+ len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));
+ } else {
+ /* ansi representation when running on 95/98/ME */
+ len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
+ }
+#else
+ /* ansi representation when running on Unix/MacOS */
+ len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
+#endif
+
+ copy = (ClientData) ckalloc(len);
+ memcpy((VOID*)copy, (VOID*)clientData, len);
+ return copy;
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_EvalFile --
+ * NativePathInFilesystem --
*
- * Read in a file and process the entire file as one gigantic
- * Tcl command.
+ * Any path object is acceptable to the native filesystem, by
+ * default (we will throw errors when illegal paths are actually
+ * tried to be used).
+ *
+ * However, this behavior means the native filesystem must be
+ * the last filesystem in the lookup list (otherwise it will
+ * claim all files belong to it, and other filesystems will
+ * never get a look in).
*
* Results:
- * A standard Tcl result, which is either the result of executing
- * the file or an error indicating why the file couldn't be read.
+ * TCL_OK, to indicate 'yes', -1 to indicate no.
*
* Side effects:
- * Depends on the commands in the file.
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
-int
-Tcl_EvalFile(interp, fileName)
- Tcl_Interp *interp; /* Interpreter in which to process file. */
- char *fileName; /* Name of file to process. Tilde-substitution
- * will be performed on this name. */
+static int
+NativePathInFilesystem(pathPtr, clientDataPtr)
+ Tcl_Obj *pathPtr;
+ ClientData *clientDataPtr;
{
- int result, length;
- struct stat statBuf;
- char *oldScriptFile;
- Interp *iPtr;
- Tcl_DString nameString;
- char *name, *string;
- Tcl_Channel chan;
- Tcl_Obj *objPtr;
-
- name = Tcl_TranslateFileName(interp, fileName, &nameString);
- if (name == NULL) {
- return TCL_ERROR;
- }
-
- result = TCL_ERROR;
- objPtr = Tcl_NewObj();
-
- if (TclStat(name, &statBuf) == -1) {
- Tcl_SetErrno(errno);
- Tcl_AppendResult(interp, "couldn't read file \"", fileName,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- goto end;
- }
- chan = Tcl_OpenFileChannel(interp, name, "r", 0644);
- if (chan == (Tcl_Channel) NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "couldn't read file \"", fileName,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- goto end;
- }
- if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
- Tcl_Close(interp, chan);
- Tcl_AppendResult(interp, "couldn't read file \"", fileName,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- goto end;
- }
- if (Tcl_Close(interp, chan) != TCL_OK) {
- goto end;
- }
-
- iPtr = (Interp *) interp;
- oldScriptFile = iPtr->scriptFile;
- iPtr->scriptFile = fileName;
- string = Tcl_GetStringFromObj(objPtr, &length);
- result = Tcl_EvalEx(interp, string, length, 0);
- iPtr->scriptFile = oldScriptFile;
-
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo(iPtr);
- } else if (result == TCL_ERROR) {
- char msg[200 + TCL_INTEGER_SPACE];
-
- /*
- * Record information telling where the error occurred.
- */
-
- sprintf(msg, "\n (file \"%.150s\" line %d)", fileName,
- interp->errorLine);
- Tcl_AddErrorInfo(interp, msg);
+ int len;
+ Tcl_GetStringFromObj(pathPtr,&len);
+ if (len == 0) {
+ return -1;
+ } else {
+ /* We accept any path as valid */
+ return TCL_OK;
}
-
- end:
- Tcl_DecrRefCount(objPtr);
- Tcl_DStringFree(&nameString);
- return result;
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_GetErrno --
+ * NativeFreeInternalRep --
*
- * Gets the current value of the Tcl error code variable. This is
- * currently the global variable "errno" but could in the future
- * change to something else.
+ * Free a native internal representation, which will be non-NULL.
*
* Results:
- * The value of the Tcl error code variable.
+ * None.
*
* Side effects:
- * None. Note that the value of the Tcl error code variable is
- * UNDEFINED if a call to Tcl_SetErrno did not precede this call.
+ * Memory is released.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
-int
-Tcl_GetErrno()
+static void
+NativeFreeInternalRep(clientData)
+ ClientData clientData;
{
- return errno;
+ ckfree((char*)clientData);
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_SetErrno --
+ * Tcl_FSFileSystemInfo --
*
- * Sets the Tcl error code variable to the supplied value.
+ * This function returns a list of two elements. The first
+ * element is the name of the filesystem (e.g. "native" or "vfs"),
+ * and the second is the particular type of the given path within
+ * that filesystem.
*
* Results:
- * None.
+ * A list of two elements.
*
* Side effects:
- * Modifies the value of the Tcl error code variable.
+ * The object may be converted to a path type.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
-void
-Tcl_SetErrno(err)
- int err; /* The new value. */
+Tcl_Obj*
+Tcl_FSFileSystemInfo(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
{
- errno = err;
+ Tcl_Obj *resPtr;
+ Tcl_FSFilesystemPathTypeProc *proc;
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
+
+ if (fsPtr == NULL) {
+ return NULL;
+ }
+
+ resPtr = Tcl_NewListObj(0,NULL);
+
+ Tcl_ListObjAppendElement(NULL, resPtr,
+ Tcl_NewStringObj(fsPtr->typeName,-1));
+
+ proc = fsPtr->filesystemPathTypeProc;
+ if (proc != NULL) {
+ Tcl_Obj *typePtr = (*proc)(pathObjPtr);
+ if (typePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
+ }
+ }
+
+ return resPtr;
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_PosixError --
+ * Tcl_FSPathSeparator --
*
- * This procedure is typically called after UNIX kernel calls
- * return errors. It stores machine-readable information about
- * the error in $errorCode returns an information string for
- * the caller's use.
+ * This function returns the separator to be used for a given
+ * path. The object returned should have a refCount of zero
*
* Results:
- * The return value is a human-readable string describing the
- * error.
+ * A Tcl object, with a refCount of zero. If the caller
+ * needs to retain a reference to the object, it should
+ * call Tcl_IncrRefCount.
*
* Side effects:
- * The global variable $errorCode is reset.
+ * The path object may be converted to a path type.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
-char *
-Tcl_PosixError(interp)
- Tcl_Interp *interp; /* Interpreter whose $errorCode variable
- * is to be changed. */
+Tcl_Obj*
+Tcl_FSPathSeparator(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
{
- char *id, *msg;
-
- msg = Tcl_ErrnoMsg(errno);
- id = Tcl_ErrnoId();
- Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
- return msg;
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
+
+ if (fsPtr == NULL) {
+ return NULL;
+ }
+ if (fsPtr->filesystemSeparatorProc != NULL) {
+ return (*fsPtr->filesystemSeparatorProc)(pathObjPtr);
+ }
+
+ return NULL;
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * TclStat --
+ * NativeFilesystemSeparator --
*
- * This procedure replaces the library version of stat and lsat.
- * The chain of functions that have been "inserted" into the
- * 'statProcList' will be called in succession until either
- * a value of zero is returned, or the entire list is visited.
+ * This function is part of the native filesystem support, and
+ * returns the separator for the given path.
*
* Results:
- * See stat documentation.
+ * String object containing the separator character.
*
* Side effects:
- * See stat documentation.
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
-int
-TclStat(path, buf)
- CONST char *path; /* Path of file to stat (in current CP). */
- struct stat *buf; /* Filled with results of stat call. */
+static Tcl_Obj*
+NativeFilesystemSeparator(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
{
- StatProc *statProcPtr;
- int retVal = -1;
-
- /*
- * Call each of the "stat" function in succession. A non-return
- * value of -1 indicates the particular function has succeeded.
- */
-
- Tcl_MutexLock(&hookMutex);
- statProcPtr = statProcList;
- while ((retVal == -1) && (statProcPtr != NULL)) {
- retVal = (*statProcPtr->proc)(path, buf);
- statProcPtr = statProcPtr->nextPtr;
+ char *separator = NULL; /* lint */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separator = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separator = "\\";
+ break;
+ case TCL_PLATFORM_MAC:
+ separator = ":";
+ break;
}
- Tcl_MutexUnlock(&hookMutex);
-
- return (retVal);
+ return Tcl_NewStringObj(separator,1);
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * TclAccess --
+ * Tcl_FSGetFileSystemForPath --
*
- * This procedure replaces the library version of access.
- * The chain of functions that have been "inserted" into the
- * 'accessProcList' will be called in succession until either
- * a value of zero is returned, or the entire list is visited.
+ * This function determines which filesystem to use for a
+ * particular path object, and returns the filesystem which
+ * accepts this file. If no filesystem will accept this object
+ * as a valid file path, then NULL is returned.
*
* Results:
- * See access documentation.
+.* NULL or a filesystem which will accept this path.
*
* Side effects:
- * See access documentation.
+ * The object may be converted to a path type.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-int
-TclAccess(path, mode)
- CONST char *path; /* Path of file to access (in current CP). */
- int mode; /* Permission setting. */
+Tcl_Filesystem*
+Tcl_FSGetFileSystemForPath(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
{
- AccessProc *accessProcPtr;
- int retVal = -1;
+ FilesystemRecord *fsRecPtr;
+ Tcl_Filesystem* retVal = NULL;
+ FsPath* srcFsPathPtr;
+
+ /*
+ * If the object has a refCount of zero, we reject it. This
+ * is to avoid possible segfaults or nondeterministic memory
+ * leaks (i.e. the user doesn't know if they should decrement
+ * the ref count on return or not).
+ */
+
+ if (pathObjPtr->refCount == 0) {
+ return NULL;
+ }
+
+ /*
+ * This will ensure the pathObjPtr can be converted into a
+ * "path" type, and that we are able to generate a complete
+ * normalized path which is used to determine the filesystem
+ * match.
+ */
+ if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Get a lock on theFilesystemEpoch and the filesystemList
+ *
+ * While we don't need the fsRecPtr until the while loop below, we
+ * do want to make sure the theFilesystemEpoch doesn't change
+ * between the 'if' and 'while' blocks, getting this iterator will
+ * ensure that everything is consistent
+ */
+ fsRecPtr = FsGetIterator();
+
+ /* Make sure pathObjPtr is of the correct epoch */
+
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+
+ /*
+ * Check if the filesystem has changed in some way since
+ * this object's internal representation was calculated.
+ */
+ if (srcFsPathPtr->filesystemEpoch != theFilesystemEpoch) {
+ /*
+ * We have to discard the stale representation and
+ * recalculate it
+ */
+ FreeFsPathInternalRep(pathObjPtr);
+ pathObjPtr->typePtr = NULL;
+ if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
+ goto done;
+ }
+ srcFsPathPtr = (FsPath*) pathObjPtr->internalRep.otherValuePtr;
+ }
+
+ /* Check whether the object is already assigned to a fs */
+ if (srcFsPathPtr->fsRecPtr != NULL) {
+ retVal = srcFsPathPtr->fsRecPtr->fsPtr;
+ goto done;
+ }
+
/*
- * Call each of the "access" function in succession. A non-return
- * value of -1 indicates the particular function has succeeded.
+ * Call each of the "pathInFilesystem" functions in succession. A
+ * non-return value of -1 indicates the particular function has
+ * succeeded.
*/
- Tcl_MutexLock(&hookMutex);
- accessProcPtr = accessProcList;
- while ((retVal == -1) && (accessProcPtr != NULL)) {
- retVal = (*accessProcPtr->proc)(path, mode);
- accessProcPtr = accessProcPtr->nextPtr;
+ while ((retVal == NULL) && (fsRecPtr != NULL)) {
+ Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
+ if (proc != NULL) {
+ ClientData clientData = NULL;
+ int ret = (*proc)(pathObjPtr, &clientData);
+ if (ret != -1) {
+ /*
+ * We assume the srcFsPathPtr hasn't been changed
+ * by the above call to the pathInFilesystemProc.
+ */
+ srcFsPathPtr->fsRecPtr = fsRecPtr;
+ srcFsPathPtr->nativePathPtr = clientData;
+ srcFsPathPtr->filesystemEpoch = theFilesystemEpoch;
+ fsRecPtr->fileRefCount++;
+ retVal = fsRecPtr->fsPtr;
+ }
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
}
- Tcl_MutexUnlock(&hookMutex);
- return (retVal);
+ done:
+ FsReleaseIterator();
+ return retVal;
+}
+\f
+/* Simple helper function */
+static FilesystemRecord*
+GetFilesystemRecord(fromFilesystem, epoch)
+ Tcl_Filesystem *fromFilesystem;
+ int *epoch;
+{
+ FilesystemRecord *fsRecPtr = FsGetIterator();
+ while (fsRecPtr != NULL) {
+ if (fsRecPtr->fsPtr == fromFilesystem) {
+ *epoch = theFilesystemEpoch;
+ break;
+ }
+ fsRecPtr = fsRecPtr->nextPtr;
+ }
+ FsReleaseIterator();
+ return fsRecPtr;
}
\f
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_OpenFileChannel --
+ * Tcl_FSEqualPaths --
*
- * The chain of functions that have been "inserted" into the
- * 'openFileChannelProcList' will be called in succession until
- * either a valid file channel is returned, or the entire list is
- * visited.
+ * This function tests whether the two paths given are equal path
+ * objects. If either or both is NULL, 0 is always returned.
*
* Results:
- * The new channel or NULL, if the named file could not be opened.
+ * 1 or 0.
*
* Side effects:
- * May open the channel and may cause creation of a file on the
- * file system.
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
-Tcl_Channel
-Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- char *fileName; /* Name of file to open. */
- char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
+
+int
+Tcl_FSEqualPaths(firstPtr, secondPtr)
+ Tcl_Obj* firstPtr;
+ Tcl_Obj* secondPtr;
{
- OpenFileChannelProc *openFileChannelProcPtr;
- Tcl_Channel retVal = NULL;
+ if (firstPtr == secondPtr) {
+ return 1;
+ } else {
+ int tempErrno;
- /*
- * Call each of the "Tcl_OpenFileChannel" function in succession.
- * A non-NULL return value indicates the particular function has
- * succeeded.
- */
+ if (firstPtr == NULL || secondPtr == NULL) {
+ return 0;
+ }
+ if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) {
+ return 1;
+ }
+ /*
+ * Try the most thorough, correct method of comparing fully
+ * normalized paths
+ */
- Tcl_MutexLock(&hookMutex);
- openFileChannelProcPtr = openFileChannelProcList;
- while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
- retVal = (*openFileChannelProcPtr->proc)(interp, fileName,
- modeString, permissions);
- openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
- }
- Tcl_MutexUnlock(&hookMutex);
+ tempErrno = Tcl_GetErrno();
+ firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
+ secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
+ Tcl_SetErrno(tempErrno);
- return (retVal);
+ if (firstPtr == NULL || secondPtr == NULL) {
+ return 0;
+ }
+ if (!(strcmp(Tcl_GetString(firstPtr), Tcl_GetString(secondPtr)))) {
+ return 1;
+ }
+ }
+ return 0;
+}
+\f
+/*
+ * utime wants a normalized, NOT native path. I assume a native
+ * version of 'utime' doesn't exist (at least under that name) on NT/2000.
+ * If a native function does exist somewhere, then we could use:
+ *
+ * return native_utime(Tcl_FSGetNativePath(pathPtr),tval);
+ *
+ * This seems rather strange when compared with stat, lstat, access, etc.
+ * all of which want a native path.
+ */
+static int
+NativeUtime(pathPtr, tval)
+ Tcl_Obj *pathPtr;
+ struct utimbuf *tval;
+{
+#ifdef MAC_TCL
+ long gmt_offset=TclpGetGMTOffset();
+ struct utimbuf local_tval;
+ local_tval.actime=tval->actime+gmt_offset;
+ local_tval.modtime=tval->modtime+gmt_offset;
+ return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),
+ &local_tval);
+#else
+ return utime(Tcl_GetString(Tcl_FSGetNormalizedPath(NULL,pathPtr)),tval);
+#endif
}
+
+/* Everything from here on is contained in this obsolete ifdef */
+#ifdef USE_OBSOLETE_FS_HOOKS
\f
/*
*----------------------------------------------------------------------
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to 'TclStat(...)'. The
- * passed function should be have exactly like 'TclStat' when called
- * during that time (see 'TclStat(...)' for more informatin).
+ * passed function should behave exactly like 'TclStat' when called
+ * during that time (see 'TclStat(...)' for more information).
* The function will be added even if it already in the list.
*
* Results:
* could not be allocated.
*
* Side effects:
- * Memory allocataed and modifies the link list for 'TclStat'
+ * Memory allocated and modifies the link list for 'TclStat'
* functions.
*
*----------------------------------------------------------------------
if (newStatProcPtr != NULL) {
newStatProcPtr->proc = proc;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
newStatProcPtr->nextPtr = statProcList;
statProcList = newStatProcPtr;
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
StatProc *tmpStatProcPtr;
StatProc *prevStatProcPtr = NULL;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
tmpStatProcPtr = statProcList;
/*
* Traverse the 'statProcList' looking for the particular node
* the list. Ensure that the "default" node cannot be removed.
*/
- while ((retVal == TCL_ERROR) && (tmpStatProcPtr != &defaultStatProc)) {
+ while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
if (tmpStatProcPtr->proc == proc) {
if (prevStatProcPtr == NULL) {
statProcList = tmpStatProcPtr->nextPtr;
prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
}
- Tcl_Free((char *)tmpStatProcPtr);
+ ckfree((char *)tmpStatProcPtr);
retVal = TCL_OK;
} else {
}
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
return (retVal);
}
\f
* TclAccessInsertProc --
*
* Insert the passed procedure pointer at the head of the list of
- * functions which are used during a call to 'TclAccess(...)'. The
- * passed function should be have exactly like 'TclAccess' when
- * called during that time (see 'TclAccess(...)' for more informatin).
- * The function will be added even if it already in the list.
+ * functions which are used during a call to 'TclAccess(...)'.
+ * The passed function should behave exactly like 'TclAccess' when
+ * called during that time (see 'TclAccess(...)' for more
+ * information). The function will be added even if it already in
+ * the list.
*
* Results:
* Normally TCL_OK; TCL_ERROR if memory for a new node in the list
* could not be allocated.
*
* Side effects:
- * Memory allocataed and modifies the link list for 'TclAccess'
+ * Memory allocated and modifies the link list for 'TclAccess'
* functions.
*
*----------------------------------------------------------------------
if (newAccessProcPtr != NULL) {
newAccessProcPtr->proc = proc;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
newAccessProcPtr->nextPtr = accessProcList;
accessProcList = newAccessProcPtr;
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
* the list. Ensure that the "default" node cannot be removed.
*/
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
tmpAccessProcPtr = accessProcList;
- while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) {
+ while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
if (tmpAccessProcPtr->proc == proc) {
if (prevAccessProcPtr == NULL) {
accessProcList = tmpAccessProcPtr->nextPtr;
prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
}
- Tcl_Free((char *)tmpAccessProcPtr);
+ ckfree((char *)tmpAccessProcPtr);
retVal = TCL_OK;
} else {
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
}
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
return (retVal);
}
*
* Insert the passed procedure pointer at the head of the list of
* functions which are used during a call to
- * 'Tcl_OpenFileChannel(...)'. The passed function should be have
+ * 'Tcl_OpenFileChannel(...)'. The passed function should behave
* exactly like 'Tcl_OpenFileChannel' when called during that time
- * (see 'Tcl_OpenFileChannel(...)' for more informatin). The
+ * (see 'Tcl_OpenFileChannel(...)' for more information). The
* function will be added even if it already in the list.
*
* Results:
* could not be allocated.
*
* Side effects:
- * Memory allocataed and modifies the link list for
+ * Memory allocated and modifies the link list for
* 'Tcl_OpenFileChannel' functions.
*
*----------------------------------------------------------------------
if (newOpenFileChannelProcPtr != NULL) {
newOpenFileChannelProcPtr->proc = proc;
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
openFileChannelProcList = newOpenFileChannelProcPtr;
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
*
* Removed the passed function pointer from the list of
* 'Tcl_OpenFileChannel' functions. Ensures that the built-in
- * open file channel function is not removvable.
+ * open file channel function is not removable.
*
* Results:
* TCL_OK if the procedure pointer was successfully removed,
/*
* Traverse the 'openFileChannelProcList' looking for the particular
* node whose 'proc' member matches 'proc' and remove that one from
- * the list. Ensure that the "default" node cannot be removed.
+ * the list.
*/
- Tcl_MutexLock(&hookMutex);
+ Tcl_MutexLock(&obsoleteFsHookMutex);
tmpOpenFileChannelProcPtr = openFileChannelProcList;
while ((retVal == TCL_ERROR) &&
- (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) {
+ (tmpOpenFileChannelProcPtr != NULL)) {
if (tmpOpenFileChannelProcPtr->proc == proc) {
if (prevOpenFileChannelProcPtr == NULL) {
openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
tmpOpenFileChannelProcPtr->nextPtr;
}
- Tcl_Free((char *)tmpOpenFileChannelProcPtr);
+ ckfree((char *)tmpOpenFileChannelProcPtr);
retVal = TCL_OK;
} else {
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
}
}
- Tcl_MutexUnlock(&hookMutex);
+ Tcl_MutexUnlock(&obsoleteFsHookMutex);
return (retVal);
}
+#endif /* USE_OBSOLETE_FS_HOOKS */
*/
#include "tclInt.h"
+#include "tclPort.h"
/*
* Prototypes for procedures defined later in this file:
static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
+static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
+static void DupIndex _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *dupPtr));
+static void FreeIndex _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* The structure below defines the index Tcl object type by means of
Tcl_ObjType tclIndexType = {
"index", /* name */
- (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
- (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
+ FreeIndex, /* freeIntRepProc */
+ DupIndex, /* dupIntRepProc */
+ UpdateStringOfIndex, /* updateStringProc */
SetIndexFromAny /* setFromAnyProc */
};
/*
- * Boolean flag indicating whether or not the tclIndexType object
- * type has been registered with the Tcl compiler.
+ * The definition of the internal representation of the "index"
+ * object; The internalRep.otherValuePtr field of an object of "index"
+ * type will be a pointer to one of these structures.
+ *
+ * Keep this structure declaration in sync with tclTestObj.c
+ */
+
+typedef struct {
+ VOID *tablePtr; /* Pointer to the table of strings */
+ int offset; /* Offset between table entries */
+ int index; /* Selected index into table. */
+} IndexRep;
+
+/*
+ * The following macros greatly simplify moving through a table...
*/
+#define STRING_AT(table, offset, index) \
+ (*((CONST char * CONST *)(((char *)(table)) + ((offset) * (index)))))
+#define NEXT_ENTRY(table, offset) \
+ (&(STRING_AT(table, offset, 1)))
+#define EXPAND_OF(indexRep) \
+ STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)
-static int indexTypeInitialized = 0;
\f
/*
*----------------------------------------------------------------------
Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* Object containing the string to lookup. */
- char **tablePtr; /* Array of strings to compare against the
+ CONST char **tablePtr; /* Array of strings to compare against the
* value of objPtr; last entry must be NULL
* and there must not be duplicate entries. */
- char *msg; /* Identifying word to use in error messages. */
+ CONST char *msg; /* Identifying word to use in error messages. */
int flags; /* 0 or TCL_EXACT */
int *indexPtr; /* Place to store resulting integer index. */
{
* is cached).
*/
- if ((objPtr->typePtr == &tclIndexType)
- && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
- *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
- return TCL_OK;
+ if (objPtr->typePtr == &tclIndexType) {
+ IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+ /*
+ * Here's hoping we don't get hit by unfortunate packing
+ * constraints on odd platforms like a Cray PVP...
+ */
+ if (indexRep->tablePtr == (VOID *)tablePtr &&
+ indexRep->offset == sizeof(char *)) {
+ *indexPtr = indexRep->index;
+ return TCL_OK;
+ }
}
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
indexPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* Object containing the string to lookup. */
- char **tablePtr; /* The first string in the table. The second
+ CONST VOID *tablePtr; /* The first string in the table. The second
* string will be at this address plus the
* offset, the third plus the offset again,
* etc. The last entry must be NULL
* and there must not be duplicate entries. */
int offset; /* The number of bytes between entries */
- char *msg; /* Identifying word to use in error messages. */
+ CONST char *msg; /* Identifying word to use in error messages. */
int flags; /* 0 or TCL_EXACT */
int *indexPtr; /* Place to store resulting integer index. */
{
int index, length, i, numAbbrev;
- char *key, *p1, *p2, **entryPtr;
+ char *key, *p1;
+ CONST char *p2;
+ CONST char * CONST *entryPtr;
Tcl_Obj *resultPtr;
+ IndexRep *indexRep;
/*
* See if there is a valid cached result from a previous lookup.
*/
- if ((objPtr->typePtr == &tclIndexType)
- && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
- *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
- return TCL_OK;
+ if (objPtr->typePtr == &tclIndexType) {
+ indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+ if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
+ *indexPtr = indexRep->index;
+ return TCL_OK;
+ }
}
/*
* abbreviations unless TCL_EXACT is set in flags.
*/
- if (!indexTypeInitialized) {
- /*
- * This is the first time we've done a lookup. Register the
- * tclIndexType.
- */
-
- Tcl_RegisterObjType(&tclIndexType);
- indexTypeInitialized = 1;
- }
-
key = Tcl_GetStringFromObj(objPtr, &length);
index = -1;
numAbbrev = 0;
goto error;
}
+ /*
+ * Scan the table looking for one of:
+ * - An exact match (always preferred)
+ * - A single abbreviation (allowed depending on flags)
+ * - Several abbreviations (never allowed, but overridden by exact match)
+ */
for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
- entryPtr = (char **) ((long) entryPtr + offset), i++) {
+ entryPtr = NEXT_ENTRY(entryPtr, offset), i++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
- if (*p1 == 0) {
+ if (*p1 == '\0') {
index = i;
goto done;
}
}
- if (*p1 == 0) {
+ if (*p1 == '\0') {
/*
* The value is an abbreviation for this entry. Continue
* checking other entries to make sure it's unique. If we
index = i;
}
}
+ /*
+ * Check if we were instructed to disallow abbreviations.
+ */
if ((flags & TCL_EXACT) || (numAbbrev != 1)) {
goto error;
}
done:
- if ((objPtr->typePtr != NULL)
- && (objPtr->typePtr->freeIntRepProc != NULL)) {
- objPtr->typePtr->freeIntRepProc(objPtr);
- }
- objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) tablePtr;
/*
- * Make sure to account for offsets != sizeof(char *). [Bug 5153]
+ * Cache the found representation. Note that we want to avoid
+ * allocating a new internal-rep if at all possible since that is
+ * potentially a slow operation.
*/
- objPtr->internalRep.twoPtrValue.ptr2 =
- (VOID *) (index * (offset / sizeof(char *)));
- objPtr->typePtr = &tclIndexType;
+ if (objPtr->typePtr == &tclIndexType) {
+ indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+ } else {
+ if ((objPtr->typePtr != NULL)
+ && (objPtr->typePtr->freeIntRepProc != NULL)) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+ indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
+ objPtr->internalRep.otherValuePtr = (VOID *) indexRep;
+ objPtr->typePtr = &tclIndexType;
+ }
+ indexRep->tablePtr = (VOID*) tablePtr;
+ indexRep->offset = offset;
+ indexRep->index = index;
+
*indexPtr = index;
return TCL_OK;
error:
if (interp != NULL) {
+ /*
+ * Produce a fancy error message.
+ */
int count;
resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
- key, "\": must be ", *tablePtr, (char *) NULL);
- for (entryPtr = (char **) ((long) tablePtr + offset), count = 0;
+ key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL);
+ for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
*entryPtr != NULL;
- entryPtr = (char **) ((long) entryPtr + offset), count++) {
- if ((*((char **) ((long) entryPtr + offset))) == NULL) {
+ entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
+ if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr,
(count > 0) ? ", or " : " or ", *entryPtr,
(char *) NULL);
/*
*----------------------------------------------------------------------
*
+ * UpdateStringOfIndex --
+ *
+ * This procedure is called to convert a Tcl object from index
+ * internal form to its string form. No abbreviation is ever
+ * generated.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The string representation of the object is updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfIndex(objPtr)
+ Tcl_Obj *objPtr;
+{
+ IndexRep *indexRep = (IndexRep *) objPtr->internalRep.otherValuePtr;
+ register char *buf;
+ register unsigned len;
+ register CONST char *indexStr = EXPAND_OF(indexRep);
+
+ len = strlen(indexStr);
+ buf = (char *) ckalloc(len + 1);
+ memcpy(buf, indexStr, len+1);
+ objPtr->bytes = buf;
+ objPtr->length = len;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupIndex --
+ *
+ * This procedure is called to copy the internal rep of an index
+ * Tcl object from to another object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The internal representation of the target object is updated
+ * and the type is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupIndex(srcPtr, dupPtr)
+ Tcl_Obj *srcPtr, *dupPtr;
+{
+ IndexRep *srcIndexRep = (IndexRep *) srcPtr->internalRep.otherValuePtr;
+ IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
+
+ memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
+ dupPtr->internalRep.otherValuePtr = (VOID *) dupIndexRep;
+ dupPtr->typePtr = &tclIndexType;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeIndex --
+ *
+ * This procedure is called to delete the internal rep of an index
+ * Tcl object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The internal representation of the target object is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeIndex(objPtr)
+ Tcl_Obj *objPtr;
+{
+ ckfree((char *) objPtr->internalRep.otherValuePtr);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_WrongNumArgs --
*
* This procedure generates a "wrong # args" error message in an
Tcl_Obj *CONST objv[]; /* Initial argument objects, which
* should be included in the error
* message. */
- char *message; /* Error message to print after the
+ CONST char *message; /* Error message to print after the
* leading objects in objv. The
* message may be NULL. */
{
Tcl_Obj *objPtr;
- char **tablePtr;
int i;
+ register IndexRep *indexRep;
objPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
*/
if (objv[i]->typePtr == &tclIndexType) {
- tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
- Tcl_AppendStringsToObj(objPtr,
- tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
- (char *) NULL);
+ indexRep = (IndexRep *) objv[i]->internalRep.otherValuePtr;
+ Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), (char *) NULL);
} else {
Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
(char *) NULL);
}
- if (i < (objc - 1)) {
+
+ /*
+ * Append a space character (" ") if there is more text to follow
+ * (either another element from objv, or the message string).
+ */
+ if ((i < (objc - 1)) || message) {
Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
}
}
+
if (message) {
- Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
+ Tcl_AppendStringsToObj(objPtr, message, (char *) NULL);
}
Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
}
-
if {[info exists env(TCL_LIBRARY)]} {\n\
lappend dirs $env(TCL_LIBRARY)\n\
}\n\
- lappend dirs $tclDefaultLibrary\n\
- unset tclDefaultLibrary\n\
+ catch {\n\
+ lappend dirs $tclDefaultLibrary\n\
+ unset tclDefaultLibrary\n\
+ }\n\
set dirs [concat $dirs $tcl_libPath]\n\
}\n\
foreach i $dirs {\n\
} else {\n\
append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
}\n\
- set tcl_pkgPath [lreplace $tcl_pkgPath end end]\n\
}\n\
}\n\
set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
# files
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Use at your own risk. Note that the position of functions should not
# be changed between versions to avoid gratuitous incompatibilities.
-declare 0 generic {
- int TclAccess(CONST char *path, int mode)
-}
+# Replaced by Tcl_FSAccess in 8.4:
+#declare 0 generic {
+# int TclAccess(CONST char *path, int mode)
+#}
declare 1 generic {
int TclAccessDeleteProc(TclAccessProc_ *proc)
}
# int TclChdir(Tcl_Interp *interp, char *dirName)
# }
declare 5 {unix win} {
- int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \
+ int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
declare 6 generic {
int TclCopyAndCollapse(int count, CONST char *src, char *dst)
}
declare 8 generic {
- int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \
+ int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {unix win} {
- int TclCreatePipeline(Tcl_Interp *interp, int argc, char **argv, \
- Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, \
+ int TclCreatePipeline(Tcl_Interp *interp, int argc, CONST char **argv,
+ Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
}
declare 10 generic {
- int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr, char *procName, \
+ int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr,
+ CONST char *procName,
Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr)
}
declare 11 generic {
void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr)
}
declare 13 generic {
- int TclDoGlob(Tcl_Interp *interp, char *separators, \
- Tcl_DString *headPtr, char *tail, GlobTypeData *types)
+ int TclDoGlob(Tcl_Interp *interp, char *separators,
+ Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
}
declare 14 generic {
void TclDumpMemoryInfo(FILE *outFile)
declare 16 generic {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
-declare 17 generic {
- int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
-}
-declare 18 generic {
- int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
-}
-declare 19 generic {
- int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
-}
-declare 20 generic {
- int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
-}
-declare 21 generic {
- int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
-}
+# Removed in 8.4
+#declare 17 generic {
+# int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
+#}
+#declare 18 generic {
+# int TclFileCopyCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
+#declare 19 generic {
+# int TclFileDeleteCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
+#declare 20 generic {
+# int TclFileMakeDirsCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
+#declare 21 generic {
+# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
+#}
declare 22 generic {
- int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \
- int listLength, CONST char **elementPtr, CONST char **nextPtr, \
+ int TclFindElement(Tcl_Interp *interp, CONST char *listStr,
+ int listLength, CONST char **elementPtr, CONST char **nextPtr,
int *sizePtr, int *bracePtr)
}
declare 23 generic {
- Proc * TclFindProc(Interp *iPtr, char *procName)
+ Proc * TclFindProc(Interp *iPtr, CONST char *procName)
}
declare 24 generic {
int TclFormatInt(char *buffer, long n)
# char * TclGetCwd(Tcl_Interp *interp)
# }
declare 27 generic {
- int TclGetDate(char *p, unsigned long now, long zone, \
+ int TclGetDate(char *p, unsigned long now, long zone,
unsigned long *timePtr)
}
declare 28 generic {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
-declare 29 generic {
- Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \
- int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg)
-}
+# Removed in 8.4b2:
+#declare 29 generic {
+# Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp,
+# int localIndex, Tcl_Obj *elemPtr, int flags)
+#}
# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
# declare 30 generic {
# char * TclGetEnv(CONST char *name)
char * TclGetExtension(char *name)
}
declare 32 generic {
- int TclGetFrame(Tcl_Interp *interp, char *str, CallFrame **framePtrPtr)
+ int TclGetFrame(Tcl_Interp *interp, CONST char *str,
+ CallFrame **framePtrPtr)
}
declare 33 generic {
TclCmdProcType TclGetInterpProc(void)
}
declare 34 generic {
- int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
-declare 35 generic {
- Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, \
- int leaveErrorMsg)
-}
+# Removed in 8.4b2:
+#declare 35 generic {
+# Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
+# int flags)
+#}
declare 36 generic {
- int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr)
+ int TclGetLong(Tcl_Interp *interp, CONST char *str, long *longPtr)
}
declare 37 generic {
int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
}
declare 38 generic {
- int TclGetNamespaceForQualName(Tcl_Interp *interp, char *qualName, \
- Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, \
- Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, \
- char **simpleNamePtr)
+ int TclGetNamespaceForQualName(Tcl_Interp *interp, CONST char *qualName,
+ Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr,
+ Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr,
+ CONST char **simpleNamePtr)
}
declare 39 generic {
TclObjCmdProcType TclGetObjInterpProc(void)
}
declare 40 generic {
- int TclGetOpenMode(Tcl_Interp *interp, char *str, int *seekFlagPtr)
+ int TclGetOpenMode(Tcl_Interp *interp, CONST char *str, int *seekFlagPtr)
}
declare 41 generic {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr)
}
declare 43 generic {
- int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags)
+ int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 44 generic {
- int TclGuessPackageName(char *fileName, Tcl_DString *bufPtr)
+ int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr)
}
declare 45 generic {
int TclHideUnsafeCommands(Tcl_Interp *interp)
declare 46 generic {
int TclInExit(void)
}
-declare 47 generic {
- Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp, \
- int localIndex, Tcl_Obj *elemPtr, long incrAmount)
-}
-declare 48 generic {
- Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex, \
- long incrAmount)
-}
+# Removed in 8.4b2:
+#declare 47 generic {
+# Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp,
+# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
+#}
+# Removed in 8.4b2:
+#declare 48 generic {
+# Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
+# long incrAmount)
+#}
declare 49 generic {
- Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, \
+ Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
}
declare 50 generic {
- void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, \
+ void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
}
declare 51 generic {
int TclInterpInit(Tcl_Interp *interp)
}
declare 52 generic {
- int TclInvoke(Tcl_Interp *interp, int argc, char **argv, int flags)
+ int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 53 generic {
- int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, \
- int argc, char **argv)
+ int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
+ int argc, CONST84 char **argv)
}
declare 54 generic {
- int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, \
+ int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
}
declare 55 generic {
}
# Replaced with TclpLoadFile in 8.1:
# declare 56 generic {
-# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \
-# char *sym2, Tcl_PackageInitProc **proc1Ptr, \
+# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
+# char *sym2, Tcl_PackageInitProc **proc1Ptr,
# Tcl_PackageInitProc **proc2Ptr)
# }
# Signature changed to take a length in 8.1:
# int TclLooksLikeInt(char *p)
# }
declare 58 generic {
- Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \
- int flags, char *msg, int createPart1, int createPart2, \
+ Var * TclLookupVar(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
+ int flags, CONST char *msg, int createPart1, int createPart2,
Var **arrayPtrPtr)
}
-declare 59 generic {
- int TclpMatchFiles(Tcl_Interp *interp, char *separators, \
- Tcl_DString *dirPtr, char *pattern, char *tail)
-}
+# Replaced by Tcl_FSMatchInDirectory in 8.4
+#declare 59 generic {
+# int TclpMatchFiles(Tcl_Interp *interp, char *separators,
+# Tcl_DString *dirPtr, char *pattern, char *tail)
+#}
declare 60 generic {
- int TclNeedSpace(char *start, char *end)
+ int TclNeedSpace(CONST char *start, CONST char *end)
}
declare 61 generic {
Tcl_Obj * TclNewProcBodyObj(Proc *procPtr)
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 generic {
- int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, \
+ int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
}
declare 64 generic {
- int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \
+ int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
int flags)
}
declare 65 generic {
- int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, \
+ int TclObjInvokeGlobal(Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[], int flags)
}
declare 66 generic {
declare 67 generic {
int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
}
-declare 68 generic {
- int TclpAccess(CONST char *path, int mode)
-}
+# Replaced by Tcl_FSAccess in 8.4:
+#declare 68 generic {
+# int TclpAccess(CONST char *path, int mode)
+#}
declare 69 generic {
char * TclpAlloc(unsigned int size)
}
-declare 70 generic {
- int TclpCopyFile(CONST char *source, CONST char *dest)
-}
-declare 71 generic {
- int TclpCopyDirectory(CONST char *source, CONST char *dest, \
- Tcl_DString *errorPtr)
-}
-declare 72 generic {
- int TclpCreateDirectory(CONST char *path)
-}
-declare 73 generic {
- int TclpDeleteFile(CONST char *path)
-}
+#declare 70 generic {
+# int TclpCopyFile(CONST char *source, CONST char *dest)
+#}
+#declare 71 generic {
+# int TclpCopyDirectory(CONST char *source, CONST char *dest,
+# Tcl_DString *errorPtr)
+#}
+#declare 72 generic {
+# int TclpCreateDirectory(CONST char *path)
+#}
+#declare 73 generic {
+# int TclpDeleteFile(CONST char *path)
+#}
declare 74 generic {
void TclpFree(char *ptr)
}
declare 76 generic {
unsigned long TclpGetSeconds(void)
}
+
+# deprecated
declare 77 generic {
void TclpGetTime(Tcl_Time *time)
}
+
declare 78 generic {
int TclpGetTimeZone(unsigned long time)
}
-declare 79 generic {
- int TclpListVolumes(Tcl_Interp *interp)
-}
-declare 80 generic {
- Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName, \
- char *modeString, int permissions)
-}
+# Replaced by Tcl_FSListVolumes in 8.4:
+#declare 79 generic {
+# int TclpListVolumes(Tcl_Interp *interp)
+#}
+# Replaced by Tcl_FSOpenFileChannel in 8.4:
+#declare 80 generic {
+# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
+# char *modeString, int permissions)
+#}
declare 81 generic {
char * TclpRealloc(char *ptr, unsigned int size)
}
-declare 82 generic {
- int TclpRemoveDirectory(CONST char *path, int recursive, \
- Tcl_DString *errorPtr)
-}
-declare 83 generic {
- int TclpRenameFile(CONST char *source, CONST char *dest)
-}
+#declare 82 generic {
+# int TclpRemoveDirectory(CONST char *path, int recursive,
+# Tcl_DString *errorPtr)
+#}
+#declare 83 generic {
+# int TclpRenameFile(CONST char *source, CONST char *dest)
+#}
# Removed in 8.1:
# declare 84 generic {
-# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \
+# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr,
# ParseValue *pvPtr)
# }
# declare 85 generic {
-# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \
+# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags,
# char **termPtr, ParseValue *pvPtr)
# }
# declare 86 generic {
-# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \
+# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
# int flags, char **termPtr, ParseValue *pvPtr)
# }
# declare 87 generic {
# void TclPlatformInit(Tcl_Interp *interp)
# }
declare 88 generic {
- char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \
- char *name1, char *name2, int flags)
+ char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
+ CONST char *name1, CONST char *name2, int flags)
}
declare 89 generic {
- int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \
+ int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
void TclProcCleanupProc(Proc *procPtr)
}
declare 92 generic {
- int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, \
- Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, \
+ int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
+ Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description,
CONST char *procName)
}
declare 93 generic {
void TclProcDeleteProc(ClientData clientData)
}
declare 94 generic {
- int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, \
- int argc, char **argv)
-}
-declare 95 generic {
- int TclpStat(CONST char *path, struct stat *buf)
+ int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
+ int argc, CONST84 char **argv)
}
+# Replaced by Tcl_FSStat in 8.4:
+#declare 95 generic {
+# int TclpStat(CONST char *path, Tcl_StatBuf *buf)
+#}
declare 96 generic {
int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName)
}
declare 98 generic {
int TclServiceIdle(void)
}
-declare 99 generic {
- Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, \
- int localIndex, Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int leaveErrorMsg)
-}
-declare 100 generic {
- Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \
- Tcl_Obj *objPtr, int leaveErrorMsg)
-}
-declare 101 {unix win} {
+# Removed in 8.4b2:
+#declare 99 generic {
+# Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
+# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
+#}
+# Removed in 8.4b2:
+#declare 100 generic {
+# Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
+# Tcl_Obj *objPtr, int flags)
+#}
+declare 101 generic {
char * TclSetPreInitScript(char *string)
}
declare 102 generic {
void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 generic {
- int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \
+ int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto,
int *portPtr)
}
declare 104 {unix win} {
int TclSockMinimumBuffers(int sock, int size)
}
-declare 105 generic {
- int TclStat(CONST char *path, struct stat *buf)
-}
+# Replaced by Tcl_FSStat in 8.4:
+#declare 105 generic {
+# int TclStat(CONST char *path, Tcl_StatBuf *buf)
+#}
declare 106 generic {
int TclStatDeleteProc(TclStatProc_ *proc)
}
# defined here instead of in tcl.decls since they are not stable yet.
declare 111 generic {
- void Tcl_AddInterpResolvers(Tcl_Interp *interp, char *name, \
- Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \
+ void Tcl_AddInterpResolvers(Tcl_Interp *interp, CONST char *name,
+ Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 112 generic {
- int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \
+ int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
declare 113 generic {
- Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, char *name, \
+ Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, CONST char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 generic {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 115 generic {
- int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, char *pattern, \
- int resetListFirst)
+ int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ CONST char *pattern, int resetListFirst)
}
declare 116 generic {
- Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, char *name, \
+ Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, CONST char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 117 generic {
- Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, char *name, \
+ Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, CONST char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 generic {
- int Tcl_GetInterpResolvers(Tcl_Interp *interp, char *name, \
+ int Tcl_GetInterpResolvers(Tcl_Interp *interp, CONST char *name,
Tcl_ResolverInfo *resInfo)
}
declare 119 generic {
- int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, \
+ int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 generic {
- Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, char *name, \
+ Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, CONST char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 generic {
- int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \
- char *pattern)
+ int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ CONST char *pattern)
}
declare 122 generic {
Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 123 generic {
- void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, \
+ void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
declare 124 generic {
Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp)
}
declare 126 generic {
- void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, \
+ void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 127 generic {
- int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, \
- char *pattern, int allowOverwrite)
+ int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
+ CONST char *pattern, int allowOverwrite)
}
declare 128 generic {
void Tcl_PopCallFrame(Tcl_Interp* interp)
}
declare 129 generic {
- int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr, \
+ int Tcl_PushCallFrame(Tcl_Interp* interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
declare 130 generic {
- int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, char *name)
+ int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, CONST char *name)
}
declare 131 generic {
- void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, \
- Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, \
+ void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr,
+ Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 132 generic {
struct tm * TclpGetDate(TclpTime_t time, int useGMT)
}
declare 134 generic {
- size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \
- CONST struct tm *t)
+ size_t TclpStrftime(char *s, size_t maxsize, CONST char *format,
+ CONST struct tm *t, int useGMT)
}
declare 135 generic {
int TclpCheckStackSpace(void)
# Added in 8.1:
-declare 137 generic {
- int TclpChdir(CONST char *dirName)
-}
+#declare 137 generic {
+# int TclpChdir(CONST char *dirName)
+#}
declare 138 generic {
- char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
-}
-declare 139 generic {
- int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \
- char *sym2, Tcl_PackageInitProc **proc1Ptr, \
- Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
+ CONST84_RETURN char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
}
+#declare 139 generic {
+# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
+# char *sym2, Tcl_PackageInitProc **proc1Ptr,
+# Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
+#}
declare 140 generic {
- int TclLooksLikeInt(char *bytes, int length)
+ int TclLooksLikeInt(CONST char *bytes, int length)
}
+# This is used by TclX, but should otherwise be considered private
declare 141 generic {
- char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+ CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 generic {
- int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, ClientData clientData)
}
declare 143 generic {
- int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, \
+ int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
LiteralEntry **litPtrPtr)
}
declare 144 generic {
- void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr, \
+ void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
int index)
}
declare 145 generic {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 generic {
- void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr, \
+ void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr,
int *endPtr)
}
Tcl_Obj *TclGetLibraryPath(void)
}
-# moved to tclTest.c in 8.3.2/8.4a2
+# moved to tclTest.c (static) in 8.3.2/8.4a2
#declare 154 generic {
# int TclTestChannelCmd(ClientData clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
#declare 155 generic {
-# int TclTestChannelEventCmd(ClientData clientData, \
+# int TclTestChannelEventCmd(ClientData clientData,
# Tcl_Interp *interp, int argc, char **argv)
#}
declare 156 generic {
- void TclRegError (Tcl_Interp *interp, char *msg, \
+ void TclRegError (Tcl_Interp *interp, CONST char *msg,
int status)
}
declare 157 generic {
- Var * TclVarTraceExists (Tcl_Interp *interp, char *varName)
+ Var * TclVarTraceExists (Tcl_Interp *interp, CONST char *varName)
}
declare 158 generic {
- void TclSetStartupScriptFileName(char *filename)
+ void TclSetStartupScriptFileName(CONST char *filename)
}
declare 159 generic {
- char *TclGetStartupScriptFileName(void)
-}
-declare 160 generic {
- int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators, \
- Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
+ CONST84_RETURN char *TclGetStartupScriptFileName(void)
}
+#declare 160 generic {
+# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
+# Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
+#}
# new in 8.3.2/8.4a2
declare 161 generic {
- int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, \
+ int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 generic {
void TclChannelEventScriptInvoker(ClientData clientData, int flags)
}
+# ALERT: The result of 'TclGetInstructionTable' is actually an
+# "InstructionDesc*" but we do not want to describe this structure in
+# "tclInt.h". It is described in "tclCompile.h". Use a cast to the
+# correct type when calling this procedure.
+
+declare 163 generic {
+ void * TclGetInstructionTable (void)
+}
+
+# ALERT: The argument of 'TclExpandCodeArray' is actually a
+# "CompileEnv*" but we do not want to describe this structure in
+# "tclInt.h". It is described in "tclCompile.h".
+
+declare 164 generic {
+ void TclExpandCodeArray (void *envPtr)
+}
+
+# These functions are vfs aware, but are generally only useful internally.
+declare 165 generic {
+ void TclpSetInitialEncodings(void)
+}
+
+# New function due to TIP #33
+declare 166 generic {
+ int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
+ int index, Tcl_Obj *valuePtr)
+}
+
+# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
+declare 167 generic {
+ void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
+}
+declare 168 generic {
+ Tcl_Obj *TclGetStartupScriptPath(void)
+}
+# variant of Tcl_UtfNCmp that takes n as bytes, not chars
+declare 169 generic {
+ int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n)
+}
+declare 170 generic {
+ int TclCheckInterpTraces (Tcl_Interp *interp, CONST char *command, int numChars, \
+ Command *cmdPtr, int result, int traceFlags, int objc, \
+ Tcl_Obj *CONST objv[])
+}
+declare 171 generic {
+ int TclCheckExecutionTraces (Tcl_Interp *interp, CONST char *command, int numChars, \
+ Command *cmdPtr, int result, int traceFlags, int objc, \
+ Tcl_Obj *CONST objv[])
+}
+
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
int FSpSetDefaultDir(FSSpecPtr theSpec)
}
declare 6 mac {
- OSErr FSpFindFolder(short vRefNum, OSType folderType, \
+ OSErr FSpFindFolder(short vRefNum, OSType folderType,
Boolean createFolder, FSSpec *spec)
}
declare 7 mac {
- void GetGlobalMouse(Point *mouse)
+ void GetGlobalMouseTcl(Point *mouse)
}
# The following routines are utility functions in Tcl. They are exported
# however. The first set are from the MoreFiles package.
declare 8 mac {
- pascal OSErr FSpGetDirectoryID(CONST FSSpec *spec, long *theDirID, \
+ pascal OSErr FSpGetDirectoryIDTcl(CONST FSSpec *spec, long *theDirID,
Boolean *isDirectory)
}
declare 9 mac {
- pascal short FSpOpenResFileCompat(CONST FSSpec *spec, \
+ pascal short FSpOpenResFileCompatTcl(CONST FSSpec *spec,
SignedByte permission)
}
declare 10 mac {
- pascal void FSpCreateResFileCompat(CONST FSSpec *spec, OSType creator, \
+ pascal void FSpCreateResFileCompatTcl(CONST FSSpec *spec, OSType creator,
OSType fileType, ScriptCode scriptTag)
}
int FSpLocationFromPath(int length, CONST char *path, FSSpecPtr theSpec)
}
declare 12 mac {
- OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length, \
+ OSErr FSpPathFromLocation(FSSpecPtr theSpec, int *length,
Handle *fullPath)
}
int TclMacTimerExpired(void *timerToken)
}
declare 20 mac {
- int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr, \
+ int TclMacRegisterResourceFork(short fileRef, Tcl_Obj *tokenPtr,
int insert)
}
declare 21 mac {
# declare 24 mac {
# int TclMacReadlink(char *path, char *buf, int size)
# }
+declare 24 mac {
+ char * TclpGetTZName(int isdst)
+}
declare 25 mac {
- int TclMacChmod(char *path, int mode)
+ int TclMacChmod(CONST char *path, int mode)
+}
+# version of FSpLocationFromPath that doesn't resolve the last path component
+declare 26 mac {
+ int FSpLLocationFromPath(int length, CONST char *path, FSSpecPtr theSpec)
}
############################
void TclWinConvertWSAError(DWORD errCode)
}
declare 2 win {
- struct servent * TclWinGetServByName(CONST char *nm, \
+ struct servent * TclWinGetServByName(CONST char *nm,
CONST char *proto)
}
declare 3 win {
- int TclWinGetSockOpt(SOCKET s, int level, int optname, \
+ int TclWinGetSockOpt(SOCKET s, int level, int optname,
char FAR * optval, int FAR *optlen)
}
declare 4 win {
u_short TclWinNToHS(u_short ns)
}
declare 7 win {
- int TclWinSetSockOpt(SOCKET s, int level, int optname, \
+ int TclWinSetSockOpt(SOCKET s, int level, int optname,
CONST char FAR * optval, int optlen)
}
declare 8 win {
int TclpCloseFile(TclFile file)
}
declare 13 win {
- Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \
+ Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)
}
declare 14 win {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 15 win {
- int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \
- TclFile inputFile, TclFile outputFile, TclFile errorFile, \
+ int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv,
+ TclFile inputFile, TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr)
}
# Signature changed in 8.1:
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
-declare 21 win {
- void TclpAsyncMark(Tcl_AsyncHandler async)
-}
+
+# removed permanently for 8.4
+#declare 21 win {
+# void TclpAsyncMark(Tcl_AsyncHandler async)
+#}
# Added in 8.1:
declare 22 win {
void TclWinSetInterfaces(int wide)
}
+# Added in Tcl 8.3.3 / 8.4
+
+declare 27 win {
+ void TclWinFlushDirtyChannels (void)
+}
+
#########################
# Unix specific internals
int TclpCloseFile(TclFile file)
}
declare 2 unix {
- Tcl_Channel TclpCreateCommandChannel(TclFile readFile, \
+ Tcl_Channel TclpCreateCommandChannel(TclFile readFile,
TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)
}
declare 3 unix {
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
- int TclpCreateProcess(Tcl_Interp *interp, int argc, char **argv, \
- TclFile inputFile, TclFile outputFile, TclFile errorFile, \
+ int TclpCreateProcess(Tcl_Interp *interp, int argc, CONST char **argv,
+ TclFile inputFile, TclFile outputFile, TclFile errorFile,
Tcl_Pid *pidPtr)
}
# Signature changed in 8.1:
# declare 5 unix {
-# TclFile TclpCreateTempFile(char *contents,
-# Tcl_DString *namePtr)
+# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
# }
declare 6 unix {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
TclFile TclpCreateTempFile(CONST char *contents)
}
+# Added in 8.4:
+
+declare 10 unix {
+ Tcl_DirEntry * TclpReaddir(DIR * dir)
+}
+
+declare 11 unix {
+ struct tm * TclpLocaltime(time_t * clock)
+}
+
+declare 12 unix {
+ struct tm * TclpGmtime(time_t * clock)
+}
+
+declare 13 unix {
+ char * TclpInetNtoa(struct in_addr addr)
+}
+
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* needed by stdlib.h in some configurations.
*/
-#include <stdio.h>
-
#ifndef _TCL
#include "tcl.h"
#endif
+#include <stdio.h>
+
#include <ctype.h>
#ifdef NO_LIMITS_H
# include "../compat/limits.h"
typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
- Tcl_Interp* interp, char* name, int length,
+ Tcl_Interp* interp, CONST84 char* name, int length,
Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr));
typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
- Tcl_Interp* interp, char* name, Tcl_Namespace *context,
+ Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context,
int flags, Tcl_Var *rPtr));
typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
- char* name, Tcl_Namespace *context, int flags,
+ CONST84 char* name, Tcl_Namespace *context, int flags,
Tcl_Command *rPtr));
typedef struct Tcl_ResolverInfo {
* namespace has already cached a Command *
* pointer; this causes all its cached
* Command* pointers to be invalidated. */
- int resolverEpoch; /* Incremented whenever the name resolution
- * rules change for this namespace; this
- * invalidates all byte codes compiled in
- * the namespace, causing the code to be
- * recompiled under the new rules. */
+ int resolverEpoch; /* Incremented whenever (a) the name resolution
+ * rules change for this namespace or (b) a
+ * newly added command shadows a command that
+ * is compiled to bytecodes.
+ * This invalidates all byte codes compiled
+ * in the namespace, causing the code to be
+ * recompiled under the new rules.*/
Tcl_ResolveCmdProc *cmdResProc;
/* If non-null, this procedure overrides
* the usual command resolution mechanism
} VarTrace;
/*
+ * The following structure defines a command trace, which is used to
+ * invoke a specific C procedure whenever certain operations are performed
+ * on a command.
+ */
+
+typedef struct CommandTrace {
+ Tcl_CommandTraceProc *traceProc;/* Procedure to call when operations given
+ * by flags are performed on command. */
+ ClientData clientData; /* Argument to pass to proc. */
+ int flags; /* What events the trace procedure is
+ * interested in: OR-ed combination of
+ * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
+ struct CommandTrace *nextPtr; /* Next in list of traces associated with
+ * a particular command. */
+} CommandTrace;
+
+/*
+ * When a command trace is active (i.e. its associated procedure is
+ * executing), one of the following structures is linked into a list
+ * associated with the command's interpreter. The information in
+ * the structure is needed in order for Tcl to behave reasonably
+ * if traces are deleted while traces are active.
+ */
+
+typedef struct ActiveCommandTrace {
+ struct Command *cmdPtr; /* Command that's being traced. */
+ struct ActiveCommandTrace *nextPtr;
+ /* Next in list of all active command
+ * traces for the interpreter, or NULL
+ * if no more. */
+ CommandTrace *nextTracePtr; /* Next trace to check after current
+ * trace procedure returns; if this
+ * trace gets deleted, must update pointer
+ * to avoid using free'd memory. */
+} ActiveCommandTrace;
+
+/*
* When a variable trace is active (i.e. its associated procedure is
* executing), one of the following structures is linked into a list
* associated with the variable's interpreter. The information in
typedef struct Trace {
int level; /* Only trace commands at nesting level
* less than or equal to this. */
- Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */
+ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */
ClientData clientData; /* Arbitrary value to pass to proc. */
struct Trace *nextPtr; /* Next in list of traces for this interp. */
+ int flags; /* Flags governing the trace - see
+ * Tcl_CreateObjTrace for details */
+ Tcl_CmdObjTraceDeleteProc* delProc;
+ /* Procedure to call when trace is deleted */
} Trace;
/*
+ * When an interpreter trace is active (i.e. its associated procedure
+ * is executing), one of the following structures is linked into a list
+ * associated with the interpreter. The information in the structure
+ * is needed in order for Tcl to behave reasonably if traces are
+ * deleted while traces are active.
+ */
+
+typedef struct ActiveInterpTrace {
+ struct ActiveInterpTrace *nextPtr;
+ /* Next in list of all active command
+ * traces for the interpreter, or NULL
+ * if no more. */
+ Trace *nextTracePtr; /* Next trace to check after current
+ * trace procedure returns; if this
+ * trace gets deleted, must update pointer
+ * to avoid using free'd memory. */
+} ActiveInterpTrace;
+
+/*
* The structure below defines an entry in the assocData hash table which
* is associated with an interpreter. The entry contains a pointer to a
* function to call when the interpreter is deleted, and a pointer to
typedef VOID **TclHandle;
-EXTERN TclHandle TclHandleCreate _ANSI_ARGS_((VOID *ptr));
-EXTERN void TclHandleFree _ANSI_ARGS_((TclHandle handle));
-EXTERN TclHandle TclHandlePreserve _ANSI_ARGS_((TclHandle handle));
-EXTERN void TclHandleRelease _ANSI_ARGS_((TclHandle handle));
-
/*
*----------------------------------------------------------------
* Data structures related to history. These are used primarily
int stackTop; /* Index of current top of stack; -1 when
* the stack is empty. */
int stackEnd; /* Index of last usable item in stack. */
+ Tcl_Obj *errorInfo;
+ Tcl_Obj *errorCode;
} ExecEnv;
/*
/* Procedure invoked when deleting command
* to, e.g., free all client data. */
ClientData deleteData; /* Arbitrary value passed to deleteProc. */
- int deleted; /* Means that the command is in the process
- * of being deleted (its deleteProc is
- * currently executing). Other attempts to
- * delete the command should be ignored. */
+ int flags; /* Miscellaneous bits of information about
+ * command. See below for definitions. */
ImportRef *importRefPtr; /* List of each imported Command created in
* another namespace when this command is
* imported. These imported commands
* command. The list is used to remove all
* those imported commands when deleting
* this "real" command. */
+ CommandTrace *tracePtr; /* First in list of all traces set for this
+ * command. */
} Command;
/*
+ * Flag bits for commands.
+ *
+ * CMD_IS_DELETED - Means that the command is in the process
+ * of being deleted (its deleteProc is
+ * currently executing). Other attempts to
+ * delete the command should be ignored.
+ * CMD_TRACE_ACTIVE - 1 means that trace processing is currently
+ * underway for a rename/delete change.
+ * See the two flags below for which is
+ * currently being processed.
+ * CMD_HAS_EXEC_TRACES - 1 means that this command has at least
+ * one execution trace (as opposed to simple
+ * delete/rename traces) in its tracePtr list.
+ * TCL_TRACE_RENAME - A rename trace is in progress. Further
+ * recursive renames will not be traced.
+ * TCL_TRACE_DELETE - A delete trace is in progress. Further
+ * recursive deletes will not be traced.
+ * (these last two flags are defined in tcl.h)
+ */
+#define CMD_IS_DELETED 0x1
+#define CMD_TRACE_ACTIVE 0x2
+#define CMD_HAS_EXEC_TRACES 0x4
+
+/*
*----------------------------------------------------------------
* Data structures related to name resolution procedures.
*----------------------------------------------------------------
/*
* Information related to procedures and variables. See tclProc.c
- * and tclvar.c for usage.
+ * and tclVar.c for usage.
*/
int numLevels; /* Keeps track of how many nested calls to
* unless an "uplevel" command is
* executing). NULL means no procedure is
* active or "uplevel 0" is executing. */
- ActiveVarTrace *activeTracePtr;
+ ActiveVarTrace *activeVarTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
int returnCode; /* Completion code to return if current
* are added/removed by calling
* Tcl_AddInterpResolvers and
* Tcl_RemoveInterpResolver. */
- char *scriptFile; /* NULL means there is no nested source
+ Tcl_Obj *scriptFile; /* NULL means there is no nested source
* command active; otherwise this points to
- * the name of the file being sourced (it's
- * not malloc-ed: it points to an argument
- * to Tcl_EvalFile. */
+ * pathPtr of the file being sourced. */
int flags; /* Various flag bits. See below. */
long randSeed; /* Seed used for rand() function. */
Trace *tracePtr; /* List of traces for this interpreter. */
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */
+ ActiveCommandTrace *activeCmdTracePtr;
+ /* First in list of active command traces for
+ * interp, or NULL if no active traces. */
+ ActiveInterpTrace *activeInterpTracePtr;
+ /* First in list of active traces for
+ * interp, or NULL if no active traces. */
+
+ int tracesForbiddingInline; /* Count of traces (in the list headed by
+ * tracePtr) that forbid inline bytecode
+ * compilation */
/*
* Statistical information about the bytecode compiler and interpreter's
* operation.
* interpreter; instead, have Tcl_EvalObj call
* Tcl_EvalEx. Used primarily for testing the
* new parser.
+ * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
+ * active; so no further trace callbacks should be
+ * invoked.
*/
#define DELETED 1
#define RAND_SEED_INITIALIZED 0x40
#define SAFE_INTERP 0x80
#define USE_EVAL_DIRECT 0x100
+#define INTERP_TRACE_IN_PROGRESS 0x200
/*
*----------------------------------------------------------------
#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
/*
- * The following macros are used to specify the runtime platform
+ * The following enum values are used to specify the runtime platform
* setting of the tclPlatform variable.
*/
} TclPlatformType;
/*
+ * The following enum values are used to indicate the translation
+ * of a Tcl channel. Declared here so that each platform can define
+ * TCL_PLATFORM_TRANSLATION to the native translation on that platform
+ */
+
+typedef enum TclEolTranslation {
+ TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */
+ TCL_TRANSLATE_CR, /* Eol == \r. */
+ TCL_TRANSLATE_LF, /* Eol == \n. */
+ TCL_TRANSLATE_CRLF /* Eol == \r\n. */
+} TclEolTranslation;
+
+/*
* Flags for TclInvoke:
*
* TCL_INVOKE_HIDDEN Invoke a hidden command; if not set,
*/
typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName, Tcl_Obj **attrObjPtrPtr));
+ int objIndex, Tcl_Obj *fileName, Tcl_Obj **attrObjPtrPtr));
typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName, Tcl_Obj *attrObjPtr));
+ int objIndex, Tcl_Obj *fileName, Tcl_Obj *attrObjPtr));
typedef struct TclFileAttrProcs {
TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */
typedef struct TclFile_ *TclFile;
/*
+ * Opaque names for platform specific types.
+ */
+
+typedef struct TclpTime_t_ *TclpTime_t;
+
+/*
+ * The "globParameters" argument of the function TclGlob is an
+ * or'ed combination of the following values:
+ */
+
+#define TCL_GLOBMODE_NO_COMPLAIN 1
+#define TCL_GLOBMODE_JOIN 2
+#define TCL_GLOBMODE_DIR 4
+#define TCL_GLOBMODE_TAILS 8
+
+/*
*----------------------------------------------------------------
- * Data structures related to hooking 'TclStat(...)' and
- * 'TclAccess(...)'.
+ * Data structures related to obsolete filesystem hooks
*----------------------------------------------------------------
*/
typedef int (TclStatProc_) _ANSI_ARGS_((CONST char *path, struct stat *buf));
typedef int (TclAccessProc_) _ANSI_ARGS_((CONST char *path, int mode));
typedef Tcl_Channel (TclOpenFileChannelProc_) _ANSI_ARGS_((Tcl_Interp *interp,
- char *fileName, char *modeString,
+ CONST char *fileName, CONST char *modeString,
int permissions));
-typedef int (*TclCmdProcType) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char *argv[]));
-typedef int (*TclObjCmdProcType) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[]));
/*
- * Opaque names for platform specific types.
- */
-
-typedef struct TclpTime_t_ *TclpTime_t;
-
-/*
- * The following structure is used to pass glob type data amongst
- * the various glob routines and TclpMatchFilesTypes. Currently
- * most of the fields are ignored. However they will be used in
- * a future release to implement glob's ability to find files
- * of particular types/permissions/etc only.
- */
-typedef struct GlobTypeData {
- /* Corresponds to bcdpfls as in 'find -t' */
- int type;
- /* Corresponds to file permissions */
- int perm;
- /* Acceptable mac type */
- Tcl_Obj* macType;
- /* Acceptable mac creator */
- Tcl_Obj* macCreator;
-} GlobTypeData;
-
-/*
- * type and permission definitions for glob command
+ *----------------------------------------------------------------
+ * Data structures related to procedures
+ *----------------------------------------------------------------
*/
-#define TCL_GLOB_TYPE_BLOCK (1<<0)
-#define TCL_GLOB_TYPE_CHAR (1<<1)
-#define TCL_GLOB_TYPE_DIR (1<<2)
-#define TCL_GLOB_TYPE_PIPE (1<<3)
-#define TCL_GLOB_TYPE_FILE (1<<4)
-#define TCL_GLOB_TYPE_LINK (1<<5)
-#define TCL_GLOB_TYPE_SOCK (1<<6)
-#define TCL_GLOB_PERM_RONLY (1<<0)
-#define TCL_GLOB_PERM_HIDDEN (1<<1)
-#define TCL_GLOB_PERM_R (1<<2)
-#define TCL_GLOB_PERM_W (1<<3)
-#define TCL_GLOB_PERM_X (1<<4)
+typedef Tcl_CmdProc *TclCmdProcType;
+typedef Tcl_ObjCmdProc *TclObjCmdProcType;
/*
*----------------------------------------------------------------
extern Tcl_ChannelType tclFileChannelType;
extern char * tclMemDumpFileName;
extern TclPlatformType tclPlatform;
-extern char * tclpFileAttrStrings[];
-extern CONST TclFileAttrProcs tclpFileAttrProcs[];
/*
* Variables denoting the Tcl object types defined in the core.
extern Tcl_ObjType tclByteArrayType;
extern Tcl_ObjType tclByteCodeType;
extern Tcl_ObjType tclDoubleType;
+extern Tcl_ObjType tclEndOffsetType;
extern Tcl_ObjType tclIntType;
extern Tcl_ObjType tclListType;
extern Tcl_ObjType tclProcBodyType;
extern Tcl_ObjType tclStringType;
+extern Tcl_ObjType tclArraySearchType;
+extern Tcl_ObjType tclIndexType;
+extern Tcl_ObjType tclNsNameType;
+#ifndef TCL_WIDE_INT_IS_LONG
+extern Tcl_ObjType tclWideIntType;
+#endif
+
+/*
+ * Variables denoting the hash key types defined in the core.
+ */
+
+extern Tcl_HashKeyType tclArrayHashKeyType;
+extern Tcl_HashKeyType tclOneWordHashKeyType;
+extern Tcl_HashKeyType tclStringHashKeyType;
+extern Tcl_HashKeyType tclObjHashKeyType;
/*
* The head of the list of free Tcl objects, and the total number of Tcl
#ifdef TCL_COMPILE_STATS
extern long tclObjsAlloced;
extern long tclObjsFreed;
+#define TCL_MAX_SHARED_OBJ_STATS 5
+extern long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
#endif /* TCL_COMPILE_STATS */
/*
*/
extern char * tclEmptyStringRep;
+extern char tclEmptyString;
/*
*----------------------------------------------------------------
*----------------------------------------------------------------
*/
-EXTERN int TclAccess _ANSI_ARGS_((CONST char *path,
- int mode));
-EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc));
-EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc));
-EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void));
EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp,
- char *value));
-EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
- int numPids, Tcl_Pid *pidPtr,
- Tcl_Channel errorChan));
-EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr));
-EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Channel inChan, Tcl_Channel outChan,
- int toRead, Tcl_Obj *cmdPtr));
-/*
- * TclCreatePipeline unofficially exported for use by BLT.
- */
-EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, Tcl_Pid **pidArrayPtr,
- TclFile *inPipePtr, TclFile *outPipePtr,
- TclFile *errFilePtr));
-EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp,
- Namespace *nsPtr, char *procName,
- Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr,
- Proc **procPtrPtr));
-EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_((
- Interp *iPtr, CallFrame *framePtr));
-EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr,
- Tcl_HashTable *tablePtr));
-EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp,
- char *separators, Tcl_DString *headPtr,
- char *tail, GlobTypeData *types));
-EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile));
+ CONST char *value));
EXTERN void TclExpandTokenArray _ANSI_ARGS_((
Tcl_Parse *parsePtr));
-EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
- double value));
EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv)) ;
+ int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv));
+ int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv)) ;
+ int objc, Tcl_Obj *CONST objv[])) ;
EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv)) ;
+ int objc, Tcl_Obj *CONST objv[])) ;
EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void));
EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void));
EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void));
EXTERN void TclFinalizeExecution _ANSI_ARGS_((void));
EXTERN void TclFinalizeIOSubsystem _ANSI_ARGS_((void));
+EXTERN void TclFinalizeFilesystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeLoad _ANSI_ARGS_((void));
EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void));
+EXTERN void TclFinalizeAsync _ANSI_ARGS_((void));
EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void));
EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void));
EXTERN void TclFindEncodings _ANSI_ARGS_((CONST char *argv0));
-EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr,
- char *procName));
-EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n));
-EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr));
-EXTERN int TclGetDate _ANSI_ARGS_((char *p,
- unsigned long now, long zone,
- unsigned long *timePtr));
-EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp *interp, int localIndex,
- Tcl_Obj *elemPtr, int leaveErrorMsg));
-EXTERN char * TclGetExtension _ANSI_ARGS_((char *name));
-EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, CallFrame **framePtrPtr));
-EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void));
-EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, int endValue, int *indexPtr));
-EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
- int localIndex, int leaveErrorMsg));
-EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, long *longPtr));
-EXTERN int TclGetLoadedPackages _ANSI_ARGS_((
- Tcl_Interp *interp, char *targetName));
-EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_((
- Tcl_Interp *interp, char *qualName,
- Namespace *cxtNsPtr, int flags,
- Namespace **nsPtrPtr, Namespace **altNsPtrPtr,
- Namespace **actualCxtPtrPtr,
- char **simpleNamePtr));
-EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
-EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, int *seekFlagPtr));
-EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_((
- Tcl_Command command));
EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
- char *pattern, char *unquotedPrefix,
- int globFlags, GlobTypeData* types));
-EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, int flags));
-EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName,
- Tcl_DString *bufPtr));
-EXTERN int TclHideUnsafeCommands _ANSI_ARGS_((
- Tcl_Interp *interp));
-EXTERN int TclInExit _ANSI_ARGS_((void));
-EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp *interp, int localIndex,
- Tcl_Obj *elemPtr, long incrAmount));
-EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_((
- Tcl_Interp *interp, int localIndex,
- long incrAmount));
-EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
- long incrAmount, int flags));
+ char *pattern, Tcl_Obj *unquotedPrefix,
+ int globFlags, Tcl_GlobTypeData* types));
EXTERN void TclInitAlloc _ANSI_ARGS_((void));
-EXTERN void TclInitCompiledLocals _ANSI_ARGS_((
- Tcl_Interp *interp, CallFrame *framePtr,
- Namespace *nsPtr));
EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void));
EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void));
EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void));
EXTERN void TclInitNotifier _ANSI_ARGS_((void));
EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void));
EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0));
-EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp,
- int argc, char **argv, int flags));
-EXTERN int TclInvokeObjectCommand _ANSI_ARGS_((
- ClientData clientData, Tcl_Interp *interp,
- int argc, char **argv));
-EXTERN int TclInvokeStringCommand _ANSI_ARGS_((
- ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
int len));
-EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr));
-EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp,
- char *part1, char *part2, int flags, char *msg,
- int createPart1, int createPart2,
- Var **arrayPtrPtr));
-EXTERN int TclMathInProgress _ANSI_ARGS_((void));
-EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end));
-EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr));
-EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr));
-EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[], int flags));
-EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[], int flags));
-EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_((
- TclOpenFileChannelProc_ *proc));
-EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_((
- TclOpenFileChannelProc_ *proc));
-EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename,
+EXTERN int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id,
+ int* result));
+EXTERN Tcl_Obj * TclLindexList _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* listPtr,
+ Tcl_Obj* argPtr ));
+EXTERN Tcl_Obj * TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* listPtr,
+ int indexCount,
+ Tcl_Obj *CONST indexArray[]
+ ));
+EXTERN Tcl_Obj * TclLsetList _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* listPtr,
+ Tcl_Obj* indexPtr,
+ Tcl_Obj* valuePtr
+ ));
+EXTERN Tcl_Obj * TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* listPtr,
+ int indexCount,
+ Tcl_Obj *CONST indexArray[],
+ Tcl_Obj* valuePtr
+ ));
+EXTERN int TclParseBackslash _ANSI_ARGS_((CONST char *src,
+ int numBytes, int *readPtr, char *dst));
+EXTERN int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes,
+ Tcl_UniChar *resultPtr));
+EXTERN int TclParseInteger _ANSI_ARGS_((CONST char *string,
+ int numBytes));
+EXTERN int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src,
+ int numBytes, Tcl_Parse *parsePtr, char *typePtr));
+EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
int mode));
-EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
+EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_StatBuf *buf));
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
-EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source,
- CONST char *dest));
-EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char *source,
- CONST char *dest, Tcl_DString *errorPtr));
-EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path));
-EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path));
-EXTERN void TclpExit _ANSI_ARGS_((int status));
+EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void));
EXTERN void TclpFinalizeCondition _ANSI_ARGS_((
Tcl_Condition *condPtr));
EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
CONST char *argv0));
EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name,
int *lengthPtr));
-EXTERN void TclpFree _ANSI_ARGS_((char *ptr));
-EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void));
-EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
-EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void));
-EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
-EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
-EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char *name,
- Tcl_DString *bufferPtr));
-EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0));
EXTERN void TclpInitLock _ANSI_ARGS_((void));
EXTERN void TclpInitPlatform _ANSI_ARGS_((void));
EXTERN void TclpInitUnlock _ANSI_ARGS_((void));
-EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr,
+ CONST char *sym1, CONST char *sym2,
+ Tcl_PackageInitProc **proc1Ptr,
+ Tcl_PackageInitProc **proc2Ptr,
+ ClientData *clientDataPtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr));
+EXTERN Tcl_Obj* TclpObjListVolumes _ANSI_ARGS_((void));
EXTERN void TclpMasterLock _ANSI_ARGS_((void));
EXTERN void TclpMasterUnlock _ANSI_ARGS_((void));
EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
char *separators, Tcl_DString *dirPtr,
char *pattern, char *tail));
+EXTERN int TclpObjNormalizePath _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int nextCheckpoint));
+EXTERN int TclpObjCreateDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix,
+ char *joining));
+EXTERN Tcl_Obj* TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ int *lenPtr));
+EXTERN Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+ int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
+EXTERN int TclCrossFilesystemCopy _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *source, Tcl_Obj *target));
+EXTERN int TclpObjDeleteFile _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN int TclpObjCopyDirectory _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr));
+EXTERN int TclpObjCopyFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+EXTERN int TclpObjRemoveDirectory _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ int recursive, Tcl_Obj **errorPtr));
+EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
+ Tcl_Obj *destPathPtr));
+EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
+ CONST char *pattern, Tcl_GlobTypeData *types));
+EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_Obj *toPtr, int linkType));
+EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj*pathPtr));
+EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
- char *fileName, char *modeString,
+ Tcl_Obj *pathPtr, int mode,
int permissions));
+EXTERN void TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *,
+ format));
EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName,
Tcl_DString *linkPtr));
-EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr,
- unsigned int size));
EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file));
-EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char *path,
- int recursive, Tcl_DString *errorPtr));
-EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source,
- CONST char *dest));
-EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void));
EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp));
-EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin));
-EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr));
-EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp,
- unsigned int size));
-EXTERN void TclpUnloadFile _ANSI_ARGS_((ClientData clientData));
-EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, char *name1, char *name2,
- int flags));
-EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *cmdInterp, Tcl_Command cmd));
-EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr));
-EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
- Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
- CONST char *description, CONST char *procName));
-EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
-EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN void TclpUnloadFile _ANSI_ARGS_((Tcl_LoadHandle loadHandle));
EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN void TclpThreadDataKeyInit _ANSI_ARGS_((
EXTERN void TclpThreadExit _ANSI_ARGS_((int status));
EXTERN void TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex));
EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex));
+EXTERN VOID TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id));
EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
-EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp,
- char *oldName, char *newName)) ;
-EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_((
- Tcl_Interp *interp, Command *newCmdPtr));
-EXTERN int TclServiceIdle _ANSI_ARGS_((void));
-EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp *interp, int localIndex,
- Tcl_Obj *elemPtr, Tcl_Obj *objPtr,
- int leaveErrorMsg));
-EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
- int localIndex, Tcl_Obj *objPtr,
- int leaveErrorMsg));
-EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string));
-EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp));
-EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *proto, int *portPtr));
-EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock,
- int size));
-EXTERN int TclStat _ANSI_ARGS_((CONST char *path,
- struct stat *buf));
-EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc));
-EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc));
-EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr));
+EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
+ int result));
EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
int result, Tcl_Interp *targetInterp));
-EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr));
+EXTERN Tcl_Obj* TclpNativeToNormalized
+ _ANSI_ARGS_((ClientData clientData));
+EXTERN Tcl_Obj* TclpFilesystemPathType
+ _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+EXTERN Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_LoadHandle loadHandle, CONST char *symbol));
+EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr,
+ Tcl_LoadHandle *loadHandle,
+ Tcl_FSUnloadFileProc **unloadProcPtr));
/*
*----------------------------------------------------------------
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LsearchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_LsetObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData,
#ifdef MAC_TCL
EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST84 char **argv));
EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData,
*----------------------------------------------------------------
*/
+EXTERN int TclCompileAppendCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileLappendCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileLindexCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileListCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileLlengthCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileLsetCmd _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Parse* parsePtr, struct CompileEnv* envPtr));
+EXTERN int TclCompileRegexpCmd _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Parse* parsePtr, struct CompileEnv* envPtr));
+EXTERN int TclCompileReturnCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
+ * Functions defined in generic/tclVar.c and currenttly exported only
+ * for use by the bytecode compiler and engine. Some of these could later
+ * be placed in the public interface.
+ */
+
+EXTERN Var * TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *arrayName, CONST char *elName, CONST int flags,
+ CONST char *msg, CONST int createPart1,
+ CONST int createPart2, Var *arrayPtr));
+EXTERN Var * TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *part1Ptr, CONST char *part2, int flags,
+ CONST char *msg, CONST int createPart1,
+ CONST int createPart2, Var **arrayPtrPtr));
+EXTERN Tcl_Obj *TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, CONST char *part1, CONST char *part2,
+ CONST int flags));
+EXTERN Tcl_Obj *TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, CONST char *part1, CONST char *part2,
+ Tcl_Obj *newValuePtr, CONST int flags));
+EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, CONST char *part1, CONST char *part2,
+ CONST long i, CONST int flags));
+
+/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
*
* EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
* EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+ *
+ * These macros are defined in terms of two macros that depend on
+ * memory allocator in use: TclAllocObjStorage, TclFreeObjStorage.
+ * They are defined below.
*----------------------------------------------------------------
*/
# define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */
-#ifdef TCL_MEM_DEBUG
-# define TclNewObj(objPtr) \
- (objPtr) = (Tcl_Obj *) \
- Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \
- (objPtr)->refCount = 0; \
- (objPtr)->bytes = tclEmptyStringRep; \
- (objPtr)->length = 0; \
- (objPtr)->typePtr = NULL; \
- TclIncrObjsAllocated()
-
-# define TclDbNewObj(objPtr, file, line) \
- (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
+#define TclNewObj(objPtr) \
+ TclAllocObjStorage(objPtr); \
+ TclIncrObjsAllocated(); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
- (objPtr)->typePtr = NULL; \
- TclIncrObjsAllocated()
-
-# define TclDecrRefCount(objPtr) \
+ (objPtr)->typePtr = NULL
+
+#define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
- if ((objPtr)->refCount < -1) \
- panic("Reference count for %lx was negative: %s line %d", \
- (objPtr), __FILE__, __LINE__); \
- if (((objPtr)->bytes != NULL) \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
- ckfree((char *) (objPtr)->bytes); \
- } \
if (((objPtr)->typePtr != NULL) \
&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
} \
- ckfree((char *) (objPtr)); \
+ if (((objPtr)->bytes != NULL) \
+ && ((objPtr)->bytes != tclEmptyStringRep)) { \
+ ckfree((char *) (objPtr)->bytes); \
+ } \
+ TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
}
+#ifdef TCL_MEM_DEBUG
+# define TclAllocObjStorage(objPtr) \
+ (objPtr) = (Tcl_Obj *) \
+ Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__)
+
+# define TclFreeObjStorage(objPtr) \
+ if ((objPtr)->refCount < -1) { \
+ panic("Reference count for %lx was negative: %s line %d", \
+ (objPtr), __FILE__, __LINE__); \
+ } \
+ ckfree((char *) (objPtr))
+
+# define TclDbNewObj(objPtr, file, line) \
+ (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
+ (objPtr)->refCount = 0; \
+ (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->length = 0; \
+ (objPtr)->typePtr = NULL; \
+ TclIncrObjsAllocated()
+
+#elif defined(PURIFY)
+
+/*
+ * The PURIFY mode is like the regular mode, but instead of doing block
+ * Tcl_Obj allocation and keeping a freed list for efficiency, it always
+ * allocates and frees a single Tcl_Obj so that tools like Purify can
+ * better track memory leaks
+ */
+
+# define TclAllocObjStorage(objPtr) \
+ (objPtr) = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj))
+
+# define TclFreeObjStorage(objPtr) \
+ ckfree((char *) (objPtr))
+
+#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+
+/*
+ * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's
+ * from per-thread caches.
+ */
+
+EXTERN Tcl_Obj *TclThreadAllocObj _ANSI_ARGS_((void));
+EXTERN void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));
+
+# define TclAllocObjStorage(objPtr) \
+ (objPtr) = TclThreadAllocObj()
+
+# define TclFreeObjStorage(objPtr) \
+ TclThreadFreeObj((objPtr))
+
#else /* not TCL_MEM_DEBUG */
#ifdef TCL_THREADS
+/* declared in tclObj.c */
extern Tcl_Mutex tclObjMutex;
#endif
-# define TclNewObj(objPtr) \
- Tcl_MutexLock(&tclObjMutex); \
- if (tclFreeObjList == NULL) { \
- TclAllocateFreeObjects(); \
- } \
- (objPtr) = tclFreeObjList; \
- tclFreeObjList = (Tcl_Obj *) \
- tclFreeObjList->internalRep.otherValuePtr; \
- (objPtr)->refCount = 0; \
- (objPtr)->bytes = tclEmptyStringRep; \
- (objPtr)->length = 0; \
- (objPtr)->typePtr = NULL; \
- TclIncrObjsAllocated(); \
- Tcl_MutexUnlock(&tclObjMutex)
+# define TclAllocObjStorage(objPtr) \
+ Tcl_MutexLock(&tclObjMutex); \
+ if (tclFreeObjList == NULL) { \
+ TclAllocateFreeObjects(); \
+ } \
+ (objPtr) = tclFreeObjList; \
+ tclFreeObjList = (Tcl_Obj *) \
+ tclFreeObjList->internalRep.otherValuePtr; \
+ Tcl_MutexUnlock(&tclObjMutex)
+
+# define TclFreeObjStorage(objPtr) \
+ Tcl_MutexLock(&tclObjMutex); \
+ (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
+ tclFreeObjList = (objPtr); \
+ Tcl_MutexUnlock(&tclObjMutex)
-# define TclDecrRefCount(objPtr) \
- if (--(objPtr)->refCount <= 0) { \
- if (((objPtr)->bytes != NULL) \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
- ckfree((char *) (objPtr)->bytes); \
- } \
- if (((objPtr)->typePtr != NULL) \
- && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
- (objPtr)->typePtr->freeIntRepProc(objPtr); \
- } \
- Tcl_MutexLock(&tclObjMutex); \
- (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
- tclFreeObjList = (objPtr); \
- TclIncrObjsFreed(); \
- Tcl_MutexUnlock(&tclObjMutex); \
- }
#endif /* TCL_MEM_DEBUG */
/*
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
+/*
+ *----------------------------------------------------------------
+ * Macro used by the Tcl core to compare Unicode strings. On
+ * big-endian systems we can use the more efficient memcmp, but
+ * this would not be lexically correct on little-endian systems.
+ * The ANSI C "prototype" for this macro is:
+ *
+ * EXTERN int TclUniCharNcmp _ANSI_ARGS_((CONST Tcl_UniChar *cs,
+ * CONST Tcl_UniChar *ct, unsigned long n));
+ *----------------------------------------------------------------
+ */
+#ifdef WORDS_BIGENDIAN
+# define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar))
+#else /* !WORDS_BIGENDIAN */
+# define TclUniCharNcmp Tcl_UniCharNcmp
+#endif /* WORDS_BIGENDIAN */
+
#include "tclIntDecls.h"
# undef TCL_STORAGE_CLASS
#endif /* _TCLINT */
-
* Exported function declarations:
*/
-/* 0 */
-EXTERN int TclAccess _ANSI_ARGS_((CONST char * path, int mode));
+/* Slot 0 is reserved */
/* 1 */
EXTERN int TclAccessDeleteProc _ANSI_ARGS_((
TclAccessProc_ * proc));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 9 */
EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv,
+ int argc, CONST char ** argv,
Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr,
TclFile * outPipePtr, TclFile * errFilePtr));
#endif /* UNIX */
#ifdef __WIN32__
/* 9 */
EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv,
+ int argc, CONST char ** argv,
Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr,
TclFile * outPipePtr, TclFile * errFilePtr));
#endif /* __WIN32__ */
/* 10 */
EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp * interp,
- Namespace * nsPtr, char * procName,
+ Namespace * nsPtr, CONST char * procName,
Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr,
Proc ** procPtrPtr));
/* 11 */
/* 13 */
EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp,
char * separators, Tcl_DString * headPtr,
- char * tail, GlobTypeData * types));
+ char * tail, Tcl_GlobTypeData * types));
/* 14 */
EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile));
/* Slot 15 is reserved */
/* 16 */
EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp,
double value));
-/* 17 */
-EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int objc, Tcl_Obj *CONST objv[]));
-/* 18 */
-EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
-/* 19 */
-EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
-/* 20 */
-EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
-/* 21 */
-EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv));
+/* Slot 17 is reserved */
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+/* Slot 21 is reserved */
/* 22 */
EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp,
CONST char * listStr, int listLength,
int * bracePtr));
/* 23 */
EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr,
- char * procName));
+ CONST char * procName));
/* 24 */
EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n));
/* 25 */
long zone, unsigned long * timePtr));
/* 28 */
EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
-/* 29 */
-EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- Tcl_Obj * elemPtr, int leaveErrorMsg));
+/* Slot 29 is reserved */
/* Slot 30 is reserved */
/* 31 */
EXTERN char * TclGetExtension _ANSI_ARGS_((char * name));
/* 32 */
EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, CallFrame ** framePtrPtr));
+ CONST char * str, CallFrame ** framePtrPtr));
/* 33 */
EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void));
/* 34 */
EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int endValue,
int * indexPtr));
-/* 35 */
-EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
- int localIndex, int leaveErrorMsg));
+/* Slot 35 is reserved */
/* 36 */
EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, long * longPtr));
+ CONST char * str, long * longPtr));
/* 37 */
EXTERN int TclGetLoadedPackages _ANSI_ARGS_((
Tcl_Interp * interp, char * targetName));
/* 38 */
EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_((
- Tcl_Interp * interp, char * qualName,
+ Tcl_Interp * interp, CONST char * qualName,
Namespace * cxtNsPtr, int flags,
Namespace ** nsPtrPtr,
Namespace ** altNsPtrPtr,
Namespace ** actualCxtPtrPtr,
- char ** simpleNamePtr));
+ CONST char ** simpleNamePtr));
/* 39 */
EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
/* 40 */
EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp * interp,
- char * str, int * seekFlagPtr));
+ CONST char * str, int * seekFlagPtr));
/* 41 */
EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_((
Tcl_Command command));
Tcl_DString * bufferPtr));
/* 43 */
EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv, int flags));
+ int argc, CONST84 char ** argv, int flags));
/* 44 */
-EXTERN int TclGuessPackageName _ANSI_ARGS_((char * fileName,
- Tcl_DString * bufPtr));
+EXTERN int TclGuessPackageName _ANSI_ARGS_((
+ CONST char * fileName, Tcl_DString * bufPtr));
/* 45 */
EXTERN int TclHideUnsafeCommands _ANSI_ARGS_((
Tcl_Interp * interp));
/* 46 */
EXTERN int TclInExit _ANSI_ARGS_((void));
-/* 47 */
-EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- Tcl_Obj * elemPtr, long incrAmount));
-/* 48 */
-EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- long incrAmount));
+/* Slot 47 is reserved */
+/* Slot 48 is reserved */
/* 49 */
EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr,
EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp * interp));
/* 52 */
EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp * interp, int argc,
- char ** argv, int flags));
+ CONST84 char ** argv, int flags));
/* 53 */
EXTERN int TclInvokeObjectCommand _ANSI_ARGS_((
ClientData clientData, Tcl_Interp * interp,
- int argc, char ** argv));
+ int argc, CONST84 char ** argv));
/* 54 */
EXTERN int TclInvokeStringCommand _ANSI_ARGS_((
ClientData clientData, Tcl_Interp * interp,
/* Slot 57 is reserved */
/* 58 */
EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * part1, char * part2, int flags,
- char * msg, int createPart1, int createPart2,
- Var ** arrayPtrPtr));
-/* 59 */
-EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp * interp,
- char * separators, Tcl_DString * dirPtr,
- char * pattern, char * tail));
+ CONST char * part1, CONST char * part2,
+ int flags, CONST char * msg, int createPart1,
+ int createPart2, Var ** arrayPtrPtr));
+/* Slot 59 is reserved */
/* 60 */
-EXTERN int TclNeedSpace _ANSI_ARGS_((char * start, char * end));
+EXTERN int TclNeedSpace _ANSI_ARGS_((CONST char * start,
+ CONST char * end));
/* 61 */
EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc * procPtr));
/* 62 */
/* 67 */
EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_((
TclOpenFileChannelProc_ * proc));
-/* 68 */
-EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode));
+/* Slot 68 is reserved */
/* 69 */
EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
-/* 70 */
-EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char * source,
- CONST char * dest));
-/* 71 */
-EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char * source,
- CONST char * dest, Tcl_DString * errorPtr));
-/* 72 */
-EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char * path));
-/* 73 */
-EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char * path));
+/* Slot 70 is reserved */
+/* Slot 71 is reserved */
+/* Slot 72 is reserved */
+/* Slot 73 is reserved */
/* 74 */
EXTERN void TclpFree _ANSI_ARGS_((char * ptr));
/* 75 */
EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time * time));
/* 78 */
EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
-/* 79 */
-EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp * interp));
-/* 80 */
-EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp,
- char * fileName, char * modeString,
- int permissions));
+/* Slot 79 is reserved */
+/* Slot 80 is reserved */
/* 81 */
EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr,
unsigned int size));
-/* 82 */
-EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char * path,
- int recursive, Tcl_DString * errorPtr));
-/* 83 */
-EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char * source,
- CONST char * dest));
+/* Slot 82 is reserved */
+/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
/* 88 */
EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp * interp, char * name1,
- char * name2, int flags));
+ Tcl_Interp * interp, CONST char * name1,
+ CONST char * name2, int flags));
/* 89 */
EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Interp * cmdInterp, Tcl_Command cmd));
EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
/* 94 */
EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp * interp, int argc, char ** argv));
-/* 95 */
-EXTERN int TclpStat _ANSI_ARGS_((CONST char * path,
- struct stat * buf));
+ Tcl_Interp * interp, int argc,
+ CONST84 char ** argv));
+/* Slot 95 is reserved */
/* 96 */
EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp,
char * oldName, char * newName));
Tcl_Interp * interp, Command * newCmdPtr));
/* 98 */
EXTERN int TclServiceIdle _ANSI_ARGS_((void));
-/* 99 */
-EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_((
- Tcl_Interp * interp, int localIndex,
- Tcl_Obj * elemPtr, Tcl_Obj * objPtr,
- int leaveErrorMsg));
-/* 100 */
-EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
- int localIndex, Tcl_Obj * objPtr,
- int leaveErrorMsg));
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* Slot 99 is reserved */
+/* Slot 100 is reserved */
/* 101 */
EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string));
-#endif /* UNIX */
-#ifdef __WIN32__
-/* 101 */
-EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string));
-#endif /* __WIN32__ */
/* 102 */
EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp));
/* 103 */
EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock,
int size));
#endif /* __WIN32__ */
-/* 105 */
-EXTERN int TclStat _ANSI_ARGS_((CONST char * path,
- struct stat * buf));
+/* Slot 105 is reserved */
/* 106 */
EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ * proc));
/* 107 */
/* Slot 110 is reserved */
/* 111 */
EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_((
- Tcl_Interp * interp, char * name,
+ Tcl_Interp * interp, CONST char * name,
Tcl_ResolveCmdProc * cmdProc,
Tcl_ResolveVarProc * varProc,
Tcl_ResolveCompiledVarProc * compiledVarProc));
Tcl_Obj * objPtr));
/* 113 */
EXTERN Tcl_Namespace * Tcl_CreateNamespace _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, ClientData clientData,
+ CONST char * name, ClientData clientData,
Tcl_NamespaceDeleteProc * deleteProc));
/* 114 */
EXTERN void Tcl_DeleteNamespace _ANSI_ARGS_((
Tcl_Namespace * nsPtr));
/* 115 */
EXTERN int Tcl_Export _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Namespace * nsPtr, char * pattern,
+ Tcl_Namespace * nsPtr, CONST char * pattern,
int resetListFirst));
/* 116 */
EXTERN Tcl_Command Tcl_FindCommand _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, Tcl_Namespace * contextNsPtr,
- int flags));
+ CONST char * name,
+ Tcl_Namespace * contextNsPtr, int flags));
/* 117 */
EXTERN Tcl_Namespace * Tcl_FindNamespace _ANSI_ARGS_((Tcl_Interp * interp,
- char * name, Tcl_Namespace * contextNsPtr,
- int flags));
+ CONST char * name,
+ Tcl_Namespace * contextNsPtr, int flags));
/* 118 */
EXTERN int Tcl_GetInterpResolvers _ANSI_ARGS_((
- Tcl_Interp * interp, char * name,
+ Tcl_Interp * interp, CONST char * name,
Tcl_ResolverInfo * resInfo));
/* 119 */
EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_((
Tcl_ResolverInfo * resInfo));
/* 120 */
EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_((
- Tcl_Interp * interp, char * name,
+ Tcl_Interp * interp, CONST char * name,
Tcl_Namespace * contextNsPtr, int flags));
/* 121 */
EXTERN int Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Namespace * nsPtr, char * pattern));
+ Tcl_Namespace * nsPtr, CONST char * pattern));
/* 122 */
EXTERN Tcl_Command Tcl_GetCommandFromObj _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * objPtr));
Tcl_Obj * objPtr));
/* 127 */
EXTERN int Tcl_Import _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Namespace * nsPtr, char * pattern,
+ Tcl_Namespace * nsPtr, CONST char * pattern,
int allowOverwrite));
/* 128 */
EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp));
Tcl_Namespace * nsPtr, int isProcCallFrame));
/* 130 */
EXTERN int Tcl_RemoveInterpResolvers _ANSI_ARGS_((
- Tcl_Interp * interp, char * name));
+ Tcl_Interp * interp, CONST char * name));
/* 131 */
EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_((
Tcl_Namespace * namespacePtr,
EXTERN struct tm * TclpGetDate _ANSI_ARGS_((TclpTime_t time, int useGMT));
/* 134 */
EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize,
- CONST char * format, CONST struct tm * t));
+ CONST char * format, CONST struct tm * t,
+ int useGMT));
/* 135 */
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
/* Slot 136 is reserved */
-/* 137 */
-EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName));
+/* Slot 137 is reserved */
/* 138 */
-EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name,
+EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name,
Tcl_DString * valuePtr));
-/* 139 */
-EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp * interp,
- char * fileName, char * sym1, char * sym2,
- Tcl_PackageInitProc ** proc1Ptr,
- Tcl_PackageInitProc ** proc2Ptr,
- ClientData * clientDataPtr));
+/* Slot 139 is reserved */
/* 140 */
-EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes,
+EXTERN int TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes,
int length));
/* 141 */
-EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp,
+EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_DString * cwdPtr));
/* 142 */
EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_((
/* Slot 155 is reserved */
/* 156 */
EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp * interp,
- char * msg, int status));
+ CONST char * msg, int status));
/* 157 */
EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp,
- char * varName));
+ CONST char * varName));
/* 158 */
EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_((
- char * filename));
+ CONST char * filename));
/* 159 */
-EXTERN char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
-/* 160 */
-EXTERN int TclpMatchFilesTypes _ANSI_ARGS_((Tcl_Interp * interp,
- char * separators, Tcl_DString * dirPtr,
- char * pattern, char * tail,
- GlobTypeData * types));
+EXTERN CONST84_RETURN char * TclGetStartupScriptFileName _ANSI_ARGS_((void));
+/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Channel chan, Tcl_Obj * cmdObjPtr));
/* 162 */
EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_((
ClientData clientData, int flags));
+/* 163 */
+EXTERN void * TclGetInstructionTable _ANSI_ARGS_((void));
+/* 164 */
+EXTERN void TclExpandCodeArray _ANSI_ARGS_((void * envPtr));
+/* 165 */
+EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void));
+/* 166 */
+EXTERN int TclListObjSetElement _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * listPtr,
+ int index, Tcl_Obj * valuePtr));
+/* 167 */
+EXTERN void TclSetStartupScriptPath _ANSI_ARGS_((
+ Tcl_Obj * pathPtr));
+/* 168 */
+EXTERN Tcl_Obj * TclGetStartupScriptPath _ANSI_ARGS_((void));
+/* 169 */
+EXTERN int TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1,
+ CONST char * s2, unsigned long n));
+/* 170 */
+EXTERN int TclCheckInterpTraces _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * command,
+ int numChars, Command * cmdPtr, int result,
+ int traceFlags, int objc,
+ Tcl_Obj *CONST objv[]));
+/* 171 */
+EXTERN int TclCheckExecutionTraces _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * command,
+ int numChars, Command * cmdPtr, int result,
+ int traceFlags, int objc,
+ Tcl_Obj *CONST objv[]));
typedef struct TclIntStubs {
int magic;
struct TclIntStubHooks *hooks;
- int (*tclAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 0 */
+ void *reserved0;
int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */
void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */
int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */
int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
- int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
+ int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
- int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
+ int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved9;
#endif /* MAC_TCL */
- int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
+ int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */
void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */
- int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, GlobTypeData * types)); /* 13 */
+ int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, Tcl_GlobTypeData * types)); /* 13 */
void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */
void *reserved15;
void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */
- int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 17 */
- int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 18 */
- int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 19 */
- int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 20 */
- int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 21 */
+ void *reserved17;
+ void *reserved18;
+ void *reserved19;
+ void *reserved20;
+ void *reserved21;
int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
- Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */
+ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
void *reserved26;
int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
- Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */
+ void *reserved29;
void *reserved30;
char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
- int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * str, CallFrame ** framePtrPtr)); /* 32 */
+ int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */
TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
- Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 35 */
- int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); /* 36 */
+ void *reserved35;
+ int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 36 */
int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
- int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, char ** simpleNamePtr)); /* 38 */
+ int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */
- int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * seekFlagPtr)); /* 40 */
+ int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * seekFlagPtr)); /* 40 */
Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */
char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
- int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 43 */
- int (*tclGuessPackageName) _ANSI_ARGS_((char * fileName, Tcl_DString * bufPtr)); /* 44 */
+ int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 43 */
+ int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
- Tcl_Obj * (*tclIncrElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, long incrAmount)); /* 47 */
- Tcl_Obj * (*tclIncrIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, long incrAmount)); /* 48 */
+ void *reserved47;
+ void *reserved48;
Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
- int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 52 */
- int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 53 */
+ int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 52 */
+ int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 53 */
int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
void *reserved56;
void *reserved57;
- Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
- int (*tclpMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */
- int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */
+ Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, CONST char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
+ void *reserved59;
+ int (*tclNeedSpace) _ANSI_ARGS_((CONST char * start, CONST char * end)); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */
int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */
int (*tclObjInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 63 */
int (*tclObjInvokeGlobal) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 65 */
int (*tclOpenFileChannelDeleteProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 66 */
int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */
- int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */
-#if !defined(__CYGWIN__) || defined(__MINGW32__)
+ void *reserved68;
char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */
-#endif
- int (*tclpCopyFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 70 */
- int (*tclpCopyDirectory) _ANSI_ARGS_((CONST char * source, CONST char * dest, Tcl_DString * errorPtr)); /* 71 */
- int (*tclpCreateDirectory) _ANSI_ARGS_((CONST char * path)); /* 72 */
- int (*tclpDeleteFile) _ANSI_ARGS_((CONST char * path)); /* 73 */
-#if !defined(__CYGWIN__) || defined(__MINGW32__)
+ void *reserved70;
+ void *reserved71;
+ void *reserved72;
+ void *reserved73;
void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */
-#endif
unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */
unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */
void (*tclpGetTime) _ANSI_ARGS_((Tcl_Time * time)); /* 77 */
int (*tclpGetTimeZone) _ANSI_ARGS_((unsigned long time)); /* 78 */
- int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */
- Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */
-#if !defined(__CYGWIN__) || defined(__MINGW32__)
+ void *reserved79;
+ void *reserved80;
char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
-#endif
- int (*tclpRemoveDirectory) _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */
- int (*tclpRenameFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 83 */
+ void *reserved82;
+ void *reserved83;
void *reserved84;
void *reserved85;
void *reserved86;
void *reserved87;
- char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, char * name2, int flags)); /* 88 */
+ char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, CONST char * name1, CONST char * name2, int flags)); /* 88 */
int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */
void *reserved90;
void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */
int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */
void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
- int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 94 */
- int (*tclpStat) _ANSI_ARGS_((CONST char * path, struct stat * buf)); /* 95 */
+ int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 94 */
+ void *reserved95;
int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
- Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 99 */
- Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 100 */
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
- char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
-#endif /* UNIX */
-#ifdef __WIN32__
+ void *reserved99;
+ void *reserved100;
char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
-#endif /* __WIN32__ */
-#ifdef MAC_TCL
- void *reserved101;
-#endif /* MAC_TCL */
void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */
int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifdef MAC_TCL
void *reserved104;
#endif /* MAC_TCL */
- int (*tclStat) _ANSI_ARGS_((CONST char * path, struct stat * buf)); /* 105 */
+ void *reserved105;
int (*tclStatDeleteProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 106 */
int (*tclStatInsertProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 107 */
void (*tclTeardownNamespace) _ANSI_ARGS_((Namespace * nsPtr)); /* 108 */
int (*tclUpdateReturnInfo) _ANSI_ARGS_((Interp * iPtr)); /* 109 */
void *reserved110;
- void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */
+ void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */
int (*tcl_AppendExportList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, Tcl_Obj * objPtr)); /* 112 */
- Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
+ Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */
- int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, char * pattern, int resetListFirst)); /* 115 */
- Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
- Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
- int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
+ int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 115 */
+ Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
+ Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
+ int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */
- Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */
- int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, char * pattern)); /* 121 */
+ Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */
+ int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern)); /* 121 */
Tcl_Command (*tcl_GetCommandFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 122 */
void (*tcl_GetCommandFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); /* 123 */
Tcl_Namespace * (*tcl_GetCurrentNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 124 */
Tcl_Namespace * (*tcl_GetGlobalNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 125 */
void (*tcl_GetVariableFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr)); /* 126 */
- int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, char * pattern, int allowOverwrite)); /* 127 */
+ int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 127 */
void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp* interp)); /* 128 */
int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */
- int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 130 */
+ int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 130 */
void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */
int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */
struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */
- size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */
+ size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t, int useGMT)); /* 134 */
int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */
void *reserved136;
- int (*tclpChdir) _ANSI_ARGS_((CONST char * dirName)); /* 137 */
- char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
- int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */
- int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */
- char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
+ void *reserved137;
+ CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
+ void *reserved139;
+ int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */
+ CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
Tcl_Obj * (*tclGetLibraryPath) _ANSI_ARGS_((void)); /* 153 */
void *reserved154;
void *reserved155;
- void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, char * msg, int status)); /* 156 */
- Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, char * varName)); /* 157 */
- void (*tclSetStartupScriptFileName) _ANSI_ARGS_((char * filename)); /* 158 */
- char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
- int (*tclpMatchFilesTypes) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail, GlobTypeData * types)); /* 160 */
+ void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 156 */
+ Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 157 */
+ void (*tclSetStartupScriptFileName) _ANSI_ARGS_((CONST char * filename)); /* 158 */
+ CONST84_RETURN char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
+ void *reserved160;
int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */
void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */
+ void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */
+ void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */
+ void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */
+ int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */
+ void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
+ Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
+ int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */
+ int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */
+ int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
} TclIntStubs;
#ifdef __cplusplus
* Inline function declarations:
*/
-#ifndef TclAccess
-#define TclAccess \
- (tclIntStubsPtr->tclAccess) /* 0 */
-#endif
+/* Slot 0 is reserved */
#ifndef TclAccessDeleteProc
#define TclAccessDeleteProc \
(tclIntStubsPtr->tclAccessDeleteProc) /* 1 */
#define TclExprFloatError \
(tclIntStubsPtr->tclExprFloatError) /* 16 */
#endif
-#ifndef TclFileAttrsCmd
-#define TclFileAttrsCmd \
- (tclIntStubsPtr->tclFileAttrsCmd) /* 17 */
-#endif
-#ifndef TclFileCopyCmd
-#define TclFileCopyCmd \
- (tclIntStubsPtr->tclFileCopyCmd) /* 18 */
-#endif
-#ifndef TclFileDeleteCmd
-#define TclFileDeleteCmd \
- (tclIntStubsPtr->tclFileDeleteCmd) /* 19 */
-#endif
-#ifndef TclFileMakeDirsCmd
-#define TclFileMakeDirsCmd \
- (tclIntStubsPtr->tclFileMakeDirsCmd) /* 20 */
-#endif
-#ifndef TclFileRenameCmd
-#define TclFileRenameCmd \
- (tclIntStubsPtr->tclFileRenameCmd) /* 21 */
-#endif
+/* Slot 17 is reserved */
+/* Slot 18 is reserved */
+/* Slot 19 is reserved */
+/* Slot 20 is reserved */
+/* Slot 21 is reserved */
#ifndef TclFindElement
#define TclFindElement \
(tclIntStubsPtr->tclFindElement) /* 22 */
#define TclpGetDefaultStdChannel \
(tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
#endif
-#ifndef TclGetElementOfIndexedArray
-#define TclGetElementOfIndexedArray \
- (tclIntStubsPtr->tclGetElementOfIndexedArray) /* 29 */
-#endif
+/* Slot 29 is reserved */
/* Slot 30 is reserved */
#ifndef TclGetExtension
#define TclGetExtension \
#define TclGetIntForIndex \
(tclIntStubsPtr->tclGetIntForIndex) /* 34 */
#endif
-#ifndef TclGetIndexedScalar
-#define TclGetIndexedScalar \
- (tclIntStubsPtr->tclGetIndexedScalar) /* 35 */
-#endif
+/* Slot 35 is reserved */
#ifndef TclGetLong
#define TclGetLong \
(tclIntStubsPtr->tclGetLong) /* 36 */
#define TclInExit \
(tclIntStubsPtr->tclInExit) /* 46 */
#endif
-#ifndef TclIncrElementOfIndexedArray
-#define TclIncrElementOfIndexedArray \
- (tclIntStubsPtr->tclIncrElementOfIndexedArray) /* 47 */
-#endif
-#ifndef TclIncrIndexedScalar
-#define TclIncrIndexedScalar \
- (tclIntStubsPtr->tclIncrIndexedScalar) /* 48 */
-#endif
+/* Slot 47 is reserved */
+/* Slot 48 is reserved */
#ifndef TclIncrVar2
#define TclIncrVar2 \
(tclIntStubsPtr->tclIncrVar2) /* 49 */
#define TclLookupVar \
(tclIntStubsPtr->tclLookupVar) /* 58 */
#endif
-#ifndef TclpMatchFiles
-#define TclpMatchFiles \
- (tclIntStubsPtr->tclpMatchFiles) /* 59 */
-#endif
+/* Slot 59 is reserved */
#ifndef TclNeedSpace
#define TclNeedSpace \
(tclIntStubsPtr->tclNeedSpace) /* 60 */
#define TclOpenFileChannelInsertProc \
(tclIntStubsPtr->tclOpenFileChannelInsertProc) /* 67 */
#endif
-#ifndef TclpAccess
-#define TclpAccess \
- (tclIntStubsPtr->tclpAccess) /* 68 */
-#endif
+/* Slot 68 is reserved */
#ifndef TclpAlloc
#define TclpAlloc \
(tclIntStubsPtr->tclpAlloc) /* 69 */
#endif
-#ifndef TclpCopyFile
-#define TclpCopyFile \
- (tclIntStubsPtr->tclpCopyFile) /* 70 */
-#endif
-#ifndef TclpCopyDirectory
-#define TclpCopyDirectory \
- (tclIntStubsPtr->tclpCopyDirectory) /* 71 */
-#endif
-#ifndef TclpCreateDirectory
-#define TclpCreateDirectory \
- (tclIntStubsPtr->tclpCreateDirectory) /* 72 */
-#endif
-#ifndef TclpDeleteFile
-#define TclpDeleteFile \
- (tclIntStubsPtr->tclpDeleteFile) /* 73 */
-#endif
+/* Slot 70 is reserved */
+/* Slot 71 is reserved */
+/* Slot 72 is reserved */
+/* Slot 73 is reserved */
#ifndef TclpFree
#define TclpFree \
(tclIntStubsPtr->tclpFree) /* 74 */
#define TclpGetTimeZone \
(tclIntStubsPtr->tclpGetTimeZone) /* 78 */
#endif
-#ifndef TclpListVolumes
-#define TclpListVolumes \
- (tclIntStubsPtr->tclpListVolumes) /* 79 */
-#endif
-#ifndef TclpOpenFileChannel
-#define TclpOpenFileChannel \
- (tclIntStubsPtr->tclpOpenFileChannel) /* 80 */
-#endif
+/* Slot 79 is reserved */
+/* Slot 80 is reserved */
#ifndef TclpRealloc
#define TclpRealloc \
(tclIntStubsPtr->tclpRealloc) /* 81 */
#endif
-#ifndef TclpRemoveDirectory
-#define TclpRemoveDirectory \
- (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */
-#endif
-#ifndef TclpRenameFile
-#define TclpRenameFile \
- (tclIntStubsPtr->tclpRenameFile) /* 83 */
-#endif
+/* Slot 82 is reserved */
+/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
#define TclProcInterpProc \
(tclIntStubsPtr->tclProcInterpProc) /* 94 */
#endif
-#ifndef TclpStat
-#define TclpStat \
- (tclIntStubsPtr->tclpStat) /* 95 */
-#endif
+/* Slot 95 is reserved */
#ifndef TclRenameCommand
#define TclRenameCommand \
(tclIntStubsPtr->tclRenameCommand) /* 96 */
#define TclServiceIdle \
(tclIntStubsPtr->tclServiceIdle) /* 98 */
#endif
-#ifndef TclSetElementOfIndexedArray
-#define TclSetElementOfIndexedArray \
- (tclIntStubsPtr->tclSetElementOfIndexedArray) /* 99 */
-#endif
-#ifndef TclSetIndexedScalar
-#define TclSetIndexedScalar \
- (tclIntStubsPtr->tclSetIndexedScalar) /* 100 */
-#endif
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+/* Slot 99 is reserved */
+/* Slot 100 is reserved */
#ifndef TclSetPreInitScript
#define TclSetPreInitScript \
(tclIntStubsPtr->tclSetPreInitScript) /* 101 */
#endif
-#endif /* UNIX */
-#ifdef __WIN32__
-#ifndef TclSetPreInitScript
-#define TclSetPreInitScript \
- (tclIntStubsPtr->tclSetPreInitScript) /* 101 */
-#endif
-#endif /* __WIN32__ */
#ifndef TclSetupEnv
#define TclSetupEnv \
(tclIntStubsPtr->tclSetupEnv) /* 102 */
(tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */
#endif
#endif /* __WIN32__ */
-#ifndef TclStat
-#define TclStat \
- (tclIntStubsPtr->tclStat) /* 105 */
-#endif
+/* Slot 105 is reserved */
#ifndef TclStatDeleteProc
#define TclStatDeleteProc \
(tclIntStubsPtr->tclStatDeleteProc) /* 106 */
(tclIntStubsPtr->tclpCheckStackSpace) /* 135 */
#endif
/* Slot 136 is reserved */
-#ifndef TclpChdir
-#define TclpChdir \
- (tclIntStubsPtr->tclpChdir) /* 137 */
-#endif
+/* Slot 137 is reserved */
#ifndef TclGetEnv
#define TclGetEnv \
(tclIntStubsPtr->tclGetEnv) /* 138 */
#endif
-#ifndef TclpLoadFile
-#define TclpLoadFile \
- (tclIntStubsPtr->tclpLoadFile) /* 139 */
-#endif
+/* Slot 139 is reserved */
#ifndef TclLooksLikeInt
#define TclLooksLikeInt \
(tclIntStubsPtr->tclLooksLikeInt) /* 140 */
#define TclGetStartupScriptFileName \
(tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
#endif
-#ifndef TclpMatchFilesTypes
-#define TclpMatchFilesTypes \
- (tclIntStubsPtr->tclpMatchFilesTypes) /* 160 */
-#endif
+/* Slot 160 is reserved */
#ifndef TclChannelTransform
#define TclChannelTransform \
(tclIntStubsPtr->tclChannelTransform) /* 161 */
#define TclChannelEventScriptInvoker \
(tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */
#endif
+#ifndef TclGetInstructionTable
+#define TclGetInstructionTable \
+ (tclIntStubsPtr->tclGetInstructionTable) /* 163 */
+#endif
+#ifndef TclExpandCodeArray
+#define TclExpandCodeArray \
+ (tclIntStubsPtr->tclExpandCodeArray) /* 164 */
+#endif
+#ifndef TclpSetInitialEncodings
+#define TclpSetInitialEncodings \
+ (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */
+#endif
+#ifndef TclListObjSetElement
+#define TclListObjSetElement \
+ (tclIntStubsPtr->tclListObjSetElement) /* 166 */
+#endif
+#ifndef TclSetStartupScriptPath
+#define TclSetStartupScriptPath \
+ (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */
+#endif
+#ifndef TclGetStartupScriptPath
+#define TclGetStartupScriptPath \
+ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
+#endif
+#ifndef TclpUtfNcmp2
+#define TclpUtfNcmp2 \
+ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
+#endif
+#ifndef TclCheckInterpTraces
+#define TclCheckInterpTraces \
+ (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */
+#endif
+#ifndef TclCheckExecutionTraces
+#define TclCheckExecutionTraces \
+ (tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
/* !END!: Do not edit above this line. */
#endif /* _TCLINTDECLS */
-
TclFile * writePipe));
/* 4 */
EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile,
- Tcl_Pid * pidPtr));
+ int argc, CONST char ** argv,
+ TclFile inputFile, TclFile outputFile,
+ TclFile errorFile, Tcl_Pid * pidPtr));
/* Slot 5 is reserved */
/* 6 */
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
/* 9 */
EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((
CONST char * contents));
+/* 10 */
+EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR * dir));
+/* 11 */
+EXTERN struct tm * TclpLocaltime _ANSI_ARGS_((time_t * clock));
+/* 12 */
+EXTERN struct tm * TclpGmtime _ANSI_ARGS_((time_t * clock));
+/* 13 */
+EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr));
#endif /* UNIX */
#ifdef __WIN32__
/* 0 */
TclFile * writePipe));
/* 15 */
EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp,
- int argc, char ** argv, TclFile inputFile,
- TclFile outputFile, TclFile errorFile,
- Tcl_Pid * pidPtr));
+ int argc, CONST char ** argv,
+ TclFile inputFile, TclFile outputFile,
+ TclFile errorFile, Tcl_Pid * pidPtr));
/* Slot 16 is reserved */
/* Slot 17 is reserved */
/* 18 */
/* 20 */
EXTERN void TclWinAddProcess _ANSI_ARGS_((HANDLE hProcess,
DWORD id));
-/* 21 */
-EXTERN void TclpAsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
+/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((
CONST char * contents));
EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void));
/* 26 */
EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide));
+/* 27 */
+EXTERN void TclWinFlushDirtyChannels _ANSI_ARGS_((void));
#endif /* __WIN32__ */
#ifdef MAC_TCL
/* 0 */
OSType folderType, Boolean createFolder,
FSSpec * spec));
/* 7 */
-EXTERN void GetGlobalMouse _ANSI_ARGS_((Point * mouse));
+EXTERN void GetGlobalMouseTcl _ANSI_ARGS_((Point * mouse));
/* 8 */
-EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((CONST FSSpec * spec,
- long * theDirID, Boolean * isDirectory));
+EXTERN pascal OSErr FSpGetDirectoryIDTcl _ANSI_ARGS_((
+ CONST FSSpec * spec, long * theDirID,
+ Boolean * isDirectory));
/* 9 */
-EXTERN pascal short FSpOpenResFileCompat _ANSI_ARGS_((
+EXTERN pascal short FSpOpenResFileCompatTcl _ANSI_ARGS_((
CONST FSSpec * spec, SignedByte permission));
/* 10 */
-EXTERN pascal void FSpCreateResFileCompat _ANSI_ARGS_((
+EXTERN pascal void FSpCreateResFileCompatTcl _ANSI_ARGS_((
CONST FSSpec * spec, OSType creator,
OSType fileType, ScriptCode scriptTag));
/* 11 */
/* 23 */
EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((CONST char * path,
CONST char * mode));
-/* Slot 24 is reserved */
+/* 24 */
+EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst));
/* 25 */
-EXTERN int TclMacChmod _ANSI_ARGS_((char * path, int mode));
+EXTERN int TclMacChmod _ANSI_ARGS_((CONST char * path, int mode));
+/* 26 */
+EXTERN int FSpLLocationFromPath _ANSI_ARGS_((int length,
+ CONST char * path, FSSpecPtr theSpec));
#endif /* MAC_TCL */
typedef struct TclIntPlatStubs {
int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */
- int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
+ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
void *reserved5;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */
int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */
+ Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR * dir)); /* 10 */
+ struct tm * (*tclpLocaltime) _ANSI_ARGS_((time_t * clock)); /* 11 */
+ struct tm * (*tclpGmtime) _ANSI_ARGS_((time_t * clock)); /* 12 */
+ char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 13 */
#endif /* UNIX */
#ifdef __WIN32__
void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */
int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 13 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 14 */
- int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */
+ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */
void *reserved16;
void *reserved17;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */
TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */
void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */
- void (*tclpAsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 21 */
+ void *reserved21;
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */
char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */
TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */
void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */
+ void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */
int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */
int (*fSpSetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */
OSErr (*fSpFindFolder) _ANSI_ARGS_((short vRefNum, OSType folderType, Boolean createFolder, FSSpec * spec)); /* 6 */
- void (*getGlobalMouse) _ANSI_ARGS_((Point * mouse)); /* 7 */
- pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */
- pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */
- pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */
+ void (*getGlobalMouseTcl) _ANSI_ARGS_((Point * mouse)); /* 7 */
+ pascal OSErr (*fSpGetDirectoryIDTcl) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */
+ pascal short (*fSpOpenResFileCompatTcl) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */
+ pascal void (*fSpCreateResFileCompatTcl) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */
int (*fSpLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 11 */
OSErr (*fSpPathFromLocation) _ANSI_ARGS_((FSSpecPtr theSpec, int * length, Handle * fullPath)); /* 12 */
void (*tclMacExitHandler) _ANSI_ARGS_((void)); /* 13 */
short (*tclMacUnRegisterResourceFork) _ANSI_ARGS_((char * tokenPtr, Tcl_Obj * resultPtr)); /* 21 */
int (*tclMacCreateEnv) _ANSI_ARGS_((void)); /* 22 */
FILE * (*tclMacFOpenHack) _ANSI_ARGS_((CONST char * path, CONST char * mode)); /* 23 */
- void *reserved24;
- int (*tclMacChmod) _ANSI_ARGS_((char * path, int mode)); /* 25 */
+ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 24 */
+ int (*tclMacChmod) _ANSI_ARGS_((CONST char * path, int mode)); /* 25 */
+ int (*fSpLLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 26 */
#endif /* MAC_TCL */
} TclIntPlatStubs;
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#endif
+#ifndef TclpReaddir
+#define TclpReaddir \
+ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */
+#endif
+#ifndef TclpLocaltime
+#define TclpLocaltime \
+ (tclIntPlatStubsPtr->tclpLocaltime) /* 11 */
+#endif
+#ifndef TclpGmtime
+#define TclpGmtime \
+ (tclIntPlatStubsPtr->tclpGmtime) /* 12 */
+#endif
+#ifndef TclpInetNtoa
+#define TclpInetNtoa \
+ (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */
+#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclWinConvertError
#define TclWinAddProcess \
(tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
#endif
-#ifndef TclpAsyncMark
-#define TclpAsyncMark \
- (tclIntPlatStubsPtr->tclpAsyncMark) /* 21 */
-#endif
+/* Slot 21 is reserved */
#ifndef TclpCreateTempFile
#define TclpCreateTempFile \
(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
#define TclWinSetInterfaces \
(tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */
#endif
+#ifndef TclWinFlushDirtyChannels
+#define TclWinFlushDirtyChannels \
+ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */
+#endif
#endif /* __WIN32__ */
#ifdef MAC_TCL
#ifndef TclpSysAlloc
#define FSpFindFolder \
(tclIntPlatStubsPtr->fSpFindFolder) /* 6 */
#endif
-#ifndef GetGlobalMouse
-#define GetGlobalMouse \
- (tclIntPlatStubsPtr->getGlobalMouse) /* 7 */
+#ifndef GetGlobalMouseTcl
+#define GetGlobalMouseTcl \
+ (tclIntPlatStubsPtr->getGlobalMouseTcl) /* 7 */
#endif
-#ifndef FSpGetDirectoryID
-#define FSpGetDirectoryID \
- (tclIntPlatStubsPtr->fSpGetDirectoryID) /* 8 */
+#ifndef FSpGetDirectoryIDTcl
+#define FSpGetDirectoryIDTcl \
+ (tclIntPlatStubsPtr->fSpGetDirectoryIDTcl) /* 8 */
#endif
-#ifndef FSpOpenResFileCompat
-#define FSpOpenResFileCompat \
- (tclIntPlatStubsPtr->fSpOpenResFileCompat) /* 9 */
+#ifndef FSpOpenResFileCompatTcl
+#define FSpOpenResFileCompatTcl \
+ (tclIntPlatStubsPtr->fSpOpenResFileCompatTcl) /* 9 */
#endif
-#ifndef FSpCreateResFileCompat
-#define FSpCreateResFileCompat \
- (tclIntPlatStubsPtr->fSpCreateResFileCompat) /* 10 */
+#ifndef FSpCreateResFileCompatTcl
+#define FSpCreateResFileCompatTcl \
+ (tclIntPlatStubsPtr->fSpCreateResFileCompatTcl) /* 10 */
#endif
#ifndef FSpLocationFromPath
#define FSpLocationFromPath \
#define TclMacFOpenHack \
(tclIntPlatStubsPtr->tclMacFOpenHack) /* 23 */
#endif
-/* Slot 24 is reserved */
+#ifndef TclpGetTZName
+#define TclpGetTZName \
+ (tclIntPlatStubsPtr->tclpGetTZName) /* 24 */
+#endif
#ifndef TclMacChmod
#define TclMacChmod \
(tclIntPlatStubsPtr->tclMacChmod) /* 25 */
#endif
+#ifndef FSpLLocationFromPath
+#define FSpLLocationFromPath \
+ (tclIntPlatStubsPtr->fSpLLocationFromPath) /* 26 */
+#endif
#endif /* MAC_TCL */
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
/* !END!: Do not edit above this line. */
#endif /* _TCLINTPLATDECLS */
-
* RCS: @(#) $Id$
*/
-#include <stdio.h>
#include "tclInt.h"
#include "tclPort.h"
+#include <stdio.h>
\f
/*
* Counter for how many aliases were created (global)
Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
- Tcl_Obj *prefixPtr; /* Tcl list making up the prefix of the
- * target command to be invoked in the target
- * interpreter. Additional arguments
- * specified when calling the alias in the
- * slave interp will be appended to the prefix
- * before the command is invoked. */
Tcl_Command slaveCmd; /* Source command in slave interpreter,
* bound to command that invokes the target
* command in the target interpreter. */
* redirecting to it. Random access to this
* hash table is never required - we are using
* a hash table only for convenience. */
+ int objc; /* Count of Tcl_Obj in the prefix of the
+ * target command to be invoked in the
+ * target interpreter. Additional arguments
+ * specified when calling the alias in the
+ * slave interp will be appended to the prefix
+ * before the command is invoked. */
+ Tcl_Obj *objPtr; /* The first actual prefix object - the target
+ * command name; this has to be at the end of the
+ * structure, which will be extended to accomodate
+ * the remaining objects in the prefix. */
} Alias;
/*
Tcl_Obj *CONST objv[]));
static void SlaveObjCmdDeleteProc _ANSI_ARGS_((
ClientData clientData));
+static int SlaveRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, int objc,
+ Tcl_Obj *CONST objv[]));
+
\f
/*
*---------------------------------------------------------------------------
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int index;
- static char *options[] = {
+ static CONST char *options[] = {
"alias", "aliases", "create", "delete",
"eval", "exists", "expose", "hide",
"hidden", "issafe", "invokehidden", "marktrusted",
- "slaves", "share", "target", "transfer",
+ "recursionlimit", "slaves", "share",
+ "target", "transfer",
NULL
};
enum option {
OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE,
OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED,
- OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER
+ OPT_RECLIMIT, OPT_SLAVES, OPT_SHARE,
+ OPT_TARGET, OPT_TRANSFER
};
int i, last, safe;
Tcl_Obj *slavePtr;
char buf[16 + TCL_INTEGER_SPACE];
- static char *options[] = {
+ static CONST char *options[] = {
"-safe", "--", NULL
};
enum option {
case OPT_INVOKEHID: {
int i, index, global;
Tcl_Interp *slaveInterp;
- static char *hiddenOptions[] = {
+ static CONST char *hiddenOptions[] = {
"-global", "--", NULL
};
enum hiddenOption {
}
return SlaveMarkTrusted(interp, slaveInterp);
}
+ case OPT_RECLIMIT: {
+ Tcl_Interp *slaveInterp;
+
+ if (objc != 3 && objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
+ }
case OPT_SLAVES: {
Tcl_Interp *slaveInterp;
InterpInfo *iiPtr;
int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
- char *slaveCmd; /* Command to install in slave. */
+ CONST char *slaveCmd; /* Command to install in slave. */
Tcl_Interp *targetInterp; /* Interpreter for target command. */
- char *targetCmd; /* Name of target command. */
+ CONST char *targetCmd; /* Name of target command. */
int argc; /* How many additional arguments? */
- char **argv; /* These are the additional args. */
+ CONST char * CONST *argv; /* These are the additional args. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int
Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
- char *slaveCmd; /* Command to install in slave. */
+ CONST char *slaveCmd; /* Command to install in slave. */
Tcl_Interp *targetInterp; /* Interpreter for target command. */
- char *targetCmd; /* Name of target command. */
+ CONST char *targetCmd; /* Name of target command. */
int objc; /* How many additional arguments? */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
argvPtr)
Tcl_Interp *interp; /* Interp to start search from. */
- char *aliasName; /* Name of alias to find. */
+ CONST char *aliasName; /* Name of alias to find. */
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
- char **targetNamePtr; /* (Return) name of target command. */
+ CONST char **targetNamePtr; /* (Return) name of target command. */
int *argcPtr; /* (Return) count of addnl args. */
- char ***argvPtr; /* (Return) additional arguments. */
+ CONST char ***argvPtr; /* (Return) additional arguments. */
{
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
+ objc = aliasPtr->objc;
+ objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
*argcPtr = objc - 1;
}
if (argvPtr != NULL) {
- *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * (objc - 1));
+ *argvPtr = (CONST char **)
+ ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
for (i = 1; i < objc; i++) {
*argvPtr[i - 1] = Tcl_GetString(objv[i]);
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ObjGetAlias --
+ * Tcl_GetAliasObj --
*
* Object version: Gets information about an alias.
*
Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
objvPtr)
Tcl_Interp *interp; /* Interp to start search from. */
- char *aliasName; /* Name of alias to find. */
+ CONST char *aliasName; /* Name of alias to find. */
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
- char **targetNamePtr; /* (Return) name of target command. */
+ CONST char **targetNamePtr; /* (Return) name of target command. */
int *objcPtr; /* (Return) count of addnl args. */
Tcl_Obj ***objvPtr; /* (Return) additional args. */
{
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
+ objc = aliasPtr->objc;
+ objv = &aliasPtr->objPtr;
if (targetInterpPtr != (Tcl_Interp **) NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
- if (targetNamePtr != (char **) NULL) {
+ if (targetNamePtr != (CONST char **) NULL) {
*targetNamePtr = Tcl_GetString(objv[0]);
}
if (objcPtr != (int *) NULL) {
aliasPtr = (Alias *) cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
- int objc;
- Tcl_Obj **objv;
+ Tcl_Obj *cmdNamePtr;
/*
* If the target of the next alias in the chain is the same as
* the source alias, we have a loop.
*/
- Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv);
+ cmdNamePtr = nextAliasPtr->objPtr;
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
- Tcl_GetString(objv[0]),
+ Tcl_GetString(cmdNamePtr),
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
/*flags*/ 0);
if (aliasCmd == (Tcl_Command) NULL) {
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
+ int i;
+ Tcl_Obj **prefv;
- aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
+ aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
+ + objc * sizeof(Tcl_Obj *)));
aliasPtr->namePtr = namePtr;
Tcl_IncrRefCount(aliasPtr->namePtr);
aliasPtr->targetInterp = masterInterp;
- aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr);
- Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv);
- Tcl_IncrRefCount(aliasPtr->prefixPtr);
+
+ aliasPtr->objc = objc + 1;
+ prefv = &aliasPtr->objPtr;
+
+ *prefv = targetNamePtr;
+ Tcl_IncrRefCount(targetNamePtr);
+ for (i = 0; i < objc; i++) {
+ *(++prefv) = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ }
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
Command *cmdPtr;
Tcl_DecrRefCount(aliasPtr->namePtr);
- Tcl_DecrRefCount(aliasPtr->prefixPtr);
+ Tcl_DecrRefCount(targetNamePtr);
+ for (i = 0; i < objc; i++) {
+ Tcl_DecrRefCount(objv[i]);
+ }
cmdPtr = (Command *) aliasPtr->slaveCmd;
cmdPtr->clientData = NULL;
AliasDelete(interp, slaveInterp, namePtr)
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
- Tcl_Obj *namePtr; /* Name of alias to describe. */
+ Tcl_Obj *namePtr; /* Name of alias to delete. */
{
Slave *slavePtr;
Alias *aliasPtr;
Slave *slavePtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
+ Tcl_Obj *prefixPtr;
/*
* If the alias has been renamed in the slave, the master can still use
return TCL_OK;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- Tcl_SetObjResult(interp, aliasPtr->prefixPtr);
+ prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
+ Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
}
\f
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
+#define ALIAS_CMDV_PREALLOC 10
Tcl_Interp *targetInterp;
Alias *aliasPtr;
int result, prefc, cmdc;
- Tcl_Obj *cmdPtr;
Tcl_Obj **prefv, **cmdv;
-
+ Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
aliasPtr = (Alias *) clientData;
targetInterp = aliasPtr->targetInterp;
- Tcl_Preserve((ClientData) targetInterp);
-
- ((Interp *) targetInterp)->numLevels++;
-
- Tcl_ResetResult(targetInterp);
- Tcl_AllowExceptions(targetInterp);
-
/*
* Append the arguments to the command prefix and invoke the command
* in the target interp's global namespace.
*/
- Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv);
- cmdPtr = Tcl_NewListObj(prefc, prefv);
- Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1);
- Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv);
- result = TclObjInvoke(targetInterp, cmdc, cmdv,
- TCL_INVOKE_NO_TRACEBACK);
- Tcl_DecrRefCount(cmdPtr);
-
- ((Interp *) targetInterp)->numLevels--;
-
- /*
- * Check if we are at the bottom of the stack for the target interpreter.
- * If so, check for special return codes.
- */
-
- if (((Interp *) targetInterp)->numLevels == 0) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo((Interp *) targetInterp);
- }
- if ((result != TCL_OK) && (result != TCL_ERROR)) {
- Tcl_ResetResult(targetInterp);
- if (result == TCL_BREAK) {
- Tcl_SetObjResult(targetInterp,
- Tcl_NewStringObj("invoked \"break\" outside of a loop",
- -1));
- } else if (result == TCL_CONTINUE) {
- Tcl_SetObjResult(targetInterp,
- Tcl_NewStringObj(
- "invoked \"continue\" outside of a loop",
- -1));
- } else {
- char buf[32 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "command returned bad code: %d", result);
- Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
- }
- result = TCL_ERROR;
- }
+ prefc = aliasPtr->objc;
+ prefv = &aliasPtr->objPtr;
+ cmdc = prefc + objc - 1;
+ if (cmdc <= ALIAS_CMDV_PREALLOC) {
+ cmdv = cmdArr;
+ } else {
+ cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
}
- TclTransferResult(targetInterp, result, interp);
+ prefv = &aliasPtr->objPtr;
+ memcpy((VOID *) cmdv, (VOID *) prefv,
+ (size_t) (prefc * sizeof(Tcl_Obj *)));
+ memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1),
+ (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
+
+ Tcl_ResetResult(targetInterp);
- Tcl_Release((ClientData) targetInterp);
+ if (targetInterp != interp) {
+ Tcl_Preserve((ClientData) targetInterp);
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
+ TclTransferResult(targetInterp, result, interp);
+ Tcl_Release((ClientData) targetInterp);
+ } else {
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
+ }
+
+ if (cmdv != cmdArr) {
+ ckfree((char *) cmdv);
+ }
return result;
+#undef ALIAS_CMDV_PREALLOC
}
\f
/*
{
Alias *aliasPtr;
Target *targetPtr;
+ int i;
+ Tcl_Obj **objv;
aliasPtr = (Alias *) clientData;
Tcl_DecrRefCount(aliasPtr->namePtr);
- Tcl_DecrRefCount(aliasPtr->prefixPtr);
+ objv = &aliasPtr->objPtr;
+ for (i = 0; i < aliasPtr->objc; i++) {
+ Tcl_DecrRefCount(objv[i]);
+ }
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
Tcl_Interp *
Tcl_CreateSlave(interp, slavePath, isSafe)
Tcl_Interp *interp; /* Interpreter to start search at. */
- char *slavePath; /* Name of slave to create. */
+ CONST char *slavePath; /* Name of slave to create. */
int isSafe; /* Should new slave be "safe" ? */
{
Tcl_Obj *pathPtr;
Tcl_Interp *
Tcl_GetSlave(interp, slavePath)
Tcl_Interp *interp; /* Interpreter to start search from. */
- char *slavePath; /* Path of slave to find. */
+ CONST char *slavePath; /* Path of slave to find. */
{
Tcl_Obj *pathPtr;
Tcl_Interp *slaveInterp;
if (Tcl_Init(slaveInterp) == TCL_ERROR) {
goto error;
}
+ /*
+ * This will create the "memory" command in slave interpreters
+ * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing.
+ */
+ Tcl_InitMemory(slaveInterp);
}
return slaveInterp;
{
Tcl_Interp *slaveInterp;
int index;
- static char *options[] = {
+ static CONST char *options[] = {
"alias", "aliases", "eval", "expose",
"hide", "hidden", "issafe", "invokehidden",
- "marktrusted", NULL
+ "marktrusted", "recursionlimit", NULL
};
enum options {
OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE,
OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
- OPT_MARKTRUSTED
+ OPT_MARKTRUSTED, OPT_RECLIMIT
};
slaveInterp = (Tcl_Interp *) clientData;
switch ((enum options) index) {
case OPT_ALIAS: {
- if (objc == 3) {
- return AliasDescribe(interp, slaveInterp, objv[2]);
- }
- if (Tcl_GetString(objv[3])[0] == '\0') {
- if (objc == 4) {
- return AliasDelete(interp, slaveInterp, objv[2]);
+ if (objc > 2) {
+ if (objc == 3) {
+ return AliasDescribe(interp, slaveInterp, objv[2]);
+ }
+ if (Tcl_GetString(objv[3])[0] == '\0') {
+ if (objc == 4) {
+ return AliasDelete(interp, slaveInterp, objv[2]);
+ }
+ } else {
+ return AliasCreate(interp, slaveInterp, interp, objv[2],
+ objv[3], objc - 4, objv + 4);
}
- } else {
- return AliasCreate(interp, slaveInterp, interp, objv[2],
- objv[3], objc - 4, objv + 4);
}
Tcl_WrongNumArgs(interp, 2, objv,
"aliasName ?targetName? ?args..?");
return TCL_ERROR;
}
case OPT_ALIASES: {
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
+ return TCL_ERROR;
+ }
return AliasList(interp, slaveInterp);
}
case OPT_EVAL: {
return SlaveHidden(interp, slaveInterp);
}
case OPT_ISSAFE: {
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL);
+ return TCL_ERROR;
+ }
Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
return TCL_OK;
}
case OPT_INVOKEHIDDEN: {
int global, i, index;
- static char *hiddenOptions[] = {
+ static CONST char *hiddenOptions[] = {
"-global", "--", NULL
};
enum hiddenOption {
}
return SlaveMarkTrusted(interp, slaveInterp);
}
+ case OPT_RECLIMIT: {
+ if (objc != 2 && objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?");
+ return TCL_ERROR;
+ }
+ return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2);
+ }
}
return TCL_ERROR;
/*
*----------------------------------------------------------------------
*
+ * SlaveRecursionLimit --
+ *
+ * Helper function to set/query the Recursion limit of an interp
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * When (objc == 1), slaveInterp will be set to a new recursion
+ * limit of objv[0].
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SlaveRecursionLimit(interp, slaveInterp, objc, objv)
+ Tcl_Interp *interp; /* Interp for error return. */
+ Tcl_Interp *slaveInterp; /* Interp in which limit is set/queried. */
+ int objc; /* Set or Query. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. */
+{
+ Interp *iPtr;
+ int limit;
+
+ if (objc) {
+ if (Tcl_IsSafe(interp)) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "permission denied: ",
+ "safe interpreters cannot change recursion limit",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (limit <= 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "recursion limit must be > 0", -1));
+ return TCL_ERROR;
+ }
+ Tcl_SetRecursionLimit(slaveInterp, limit);
+ iPtr = (Interp *) slaveInterp;
+ if (interp == slaveInterp && iPtr->numLevels > limit) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "falling back due to new recursion limit", -1));
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, objv[0]);
+ return TCL_OK;
+ } else {
+ limit = Tcl_SetRecursionLimit(slaveInterp, 0);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(limit));
+ return TCL_OK;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* SlaveHide --
*
* Helper function to hide a command in a slave interpreter.
typedef struct Link {
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
- char *varName; /* Name of variable (must be global). This
+ Tcl_Obj *varName; /* Name of variable (must be global). This
* is needed during trace callbacks, since
* the actual variable may be aliased at
* that time via upvar. */
union {
int i;
double d;
+ Tcl_WideInt w;
} lastValue; /* Last known value of C variable; used to
* avoid string conversions. */
int flags; /* Miscellaneous one-bit values; see below
*/
static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, char *name1, char *name2,
- int flags));
-static char * StringValue _ANSI_ARGS_((Link *linkPtr,
- char *buffer));
+ Tcl_Interp *interp, CONST char *name1,
+ CONST char *name2, int flags));
+static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr));
\f
/*
*----------------------------------------------------------------------
int
Tcl_LinkVar(interp, varName, addr, type)
Tcl_Interp *interp; /* Interpreter in which varName exists. */
- char *varName; /* Name of a global variable in interp. */
+ CONST char *varName; /* Name of a global variable in interp. */
char *addr; /* Address of a C variable to be linked
* to varName. */
int type; /* Type of C variable: TCL_LINK_INT, etc.
* Also may have TCL_LINK_READ_ONLY
* OR'ed in. */
{
+ Tcl_Obj *objPtr;
Link *linkPtr;
- char buffer[TCL_DOUBLE_SPACE];
int code;
linkPtr = (Link *) ckalloc(sizeof(Link));
linkPtr->interp = interp;
- linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1));
- strcpy(linkPtr->varName, varName);
+ linkPtr->varName = Tcl_NewStringObj(varName, -1);
+ Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
if (type & TCL_LINK_READ_ONLY) {
} else {
linkPtr->flags = 0;
}
- if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer),
+ objPtr = ObjValue(linkPtr);
+ if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
- ckfree(linkPtr->varName);
+ Tcl_DecrRefCount(linkPtr->varName);
+ Tcl_DecrRefCount(objPtr);
ckfree((char *) linkPtr);
return TCL_ERROR;
}
|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
(ClientData) linkPtr);
if (code != TCL_OK) {
- ckfree(linkPtr->varName);
+ Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
}
return code;
void
Tcl_UnlinkVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable to unlink. */
- char *varName; /* Global variable in interp to unlink. */
+ CONST char *varName; /* Global variable in interp to unlink. */
{
Link *linkPtr;
Tcl_UntraceVar(interp, varName,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, (ClientData) linkPtr);
- ckfree(linkPtr->varName);
+ Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
}
\f
void
Tcl_UpdateLinkedVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable. */
- char *varName; /* Name of global variable that is linked. */
+ CONST char *varName; /* Name of global variable that is linked. */
{
Link *linkPtr;
- char buffer[TCL_DOUBLE_SPACE];
int savedFlag;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
}
savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
linkPtr->flags |= LINK_BEING_UPDATED;
- Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
LinkTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Contains information about the link. */
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
- char *name1; /* First part of variable name. */
- char *name2; /* Second part of variable name. */
+ CONST char *name1; /* First part of variable name. */
+ CONST char *name2; /* Second part of variable name. */
int flags; /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *) clientData;
- int changed;
- char buffer[TCL_DOUBLE_SPACE];
- char *value, **pp, *result;
- Tcl_Obj *objPtr;
+ int changed, valueLength;
+ CONST char *value;
+ char **pp, *result;
+ Tcl_Obj *objPtr, *valueObj;
/*
* If the variable is being unset, then just re-create it (with a
if (flags & TCL_TRACE_UNSETS) {
if (flags & TCL_INTERP_DESTROYED) {
- ckfree(linkPtr->varName);
+ Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
- Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY
- |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- LinkTraceProc, (ClientData) linkPtr);
+ Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
+ |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
}
return NULL;
}
if (flags & TCL_TRACE_READS) {
switch (linkPtr->type) {
- case TCL_LINK_INT:
- case TCL_LINK_BOOLEAN:
- changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
- break;
- case TCL_LINK_DOUBLE:
- changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
- break;
- case TCL_LINK_STRING:
- changed = 1;
- break;
- default:
- return "internal error: bad linked variable type";
+ case TCL_LINK_INT:
+ case TCL_LINK_BOOLEAN:
+ changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i;
+ break;
+ case TCL_LINK_DOUBLE:
+ changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d;
+ break;
+ case TCL_LINK_WIDE_INT:
+ changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w;
+ break;
+ case TCL_LINK_STRING:
+ changed = 1;
+ break;
+ default:
+ return "internal error: bad linked variable type";
}
if (changed) {
- Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
}
return NULL;
*/
if (linkPtr->flags & LINK_READ_ONLY) {
- Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer),
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "linked variable is read-only";
}
- value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY);
- if (value == NULL) {
+ valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
+ if (valueObj == NULL) {
/*
* This shouldn't ever happen.
*/
result = NULL;
switch (linkPtr->type) {
- case TCL_LINK_INT:
- if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
- Tcl_SetObjResult(interp, objPtr);
- Tcl_SetVar(interp, linkPtr->varName,
- StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
- result = "variable must have integer value";
- goto end;
- }
- *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
- break;
- case TCL_LINK_DOUBLE:
- if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
- != TCL_OK) {
- Tcl_SetObjResult(interp, objPtr);
- Tcl_SetVar(interp, linkPtr->varName,
- StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
- result = "variable must have real value";
- goto end;
- }
- *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
- break;
- case TCL_LINK_BOOLEAN:
- if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
- != TCL_OK) {
- Tcl_SetObjResult(interp, objPtr);
- Tcl_SetVar(interp, linkPtr->varName,
- StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
- result = "variable must have boolean value";
- goto end;
- }
- *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
- break;
- case TCL_LINK_STRING:
- pp = (char **)(linkPtr->addr);
- if (*pp != NULL) {
- ckfree(*pp);
- }
- *pp = (char *) ckalloc((unsigned) (strlen(value) + 1));
- strcpy(*pp, value);
- break;
- default:
- return "internal error: bad linked variable type";
+ case TCL_LINK_INT:
+ if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i)
+ != TCL_OK) {
+ Tcl_SetObjResult(interp, objPtr);
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ result = "variable must have integer value";
+ goto end;
+ }
+ *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
+ break;
+
+ case TCL_LINK_WIDE_INT:
+ if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w)
+ != TCL_OK) {
+ Tcl_SetObjResult(interp, objPtr);
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ result = "variable must have integer value";
+ goto end;
+ }
+ *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
+ break;
+
+ case TCL_LINK_DOUBLE:
+ if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d)
+ != TCL_OK) {
+ Tcl_SetObjResult(interp, objPtr);
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ result = "variable must have real value";
+ goto end;
+ }
+ *(double *)(linkPtr->addr) = linkPtr->lastValue.d;
+ break;
+
+ case TCL_LINK_BOOLEAN:
+ if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i)
+ != TCL_OK) {
+ Tcl_SetObjResult(interp, objPtr);
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ result = "variable must have boolean value";
+ goto end;
+ }
+ *(int *)(linkPtr->addr) = linkPtr->lastValue.i;
+ break;
+
+ case TCL_LINK_STRING:
+ value = Tcl_GetStringFromObj(valueObj, &valueLength);
+ valueLength++;
+ pp = (char **)(linkPtr->addr);
+ if (*pp != NULL) {
+ ckfree(*pp);
+ }
+ *pp = (char *) ckalloc((unsigned) valueLength);
+ memcpy(*pp, value, (unsigned) valueLength);
+ break;
+
+ default:
+ return "internal error: bad linked variable type";
}
end:
Tcl_DecrRefCount(objPtr);
/*
*----------------------------------------------------------------------
*
- * StringValue --
+ * ObjValue --
*
- * Converts the value of a C variable to a string for use in a
+ * Converts the value of a C variable to a Tcl_Obj* for use in a
* Tcl variable to which it is linked.
*
* Results:
- * The return value is a pointer to a string that represents
+ * The return value is a pointer to a Tcl_Obj that represents
* the value of the C variable given by linkPtr.
*
* Side effects:
*----------------------------------------------------------------------
*/
-static char *
-StringValue(linkPtr, buffer)
+static Tcl_Obj *
+ObjValue(linkPtr)
Link *linkPtr; /* Structure describing linked variable. */
- char *buffer; /* Small buffer to use for converting
- * values. Must have TCL_DOUBLE_SPACE
- * bytes or more. */
{
char *p;
switch (linkPtr->type) {
- case TCL_LINK_INT:
- linkPtr->lastValue.i = *(int *)(linkPtr->addr);
- TclFormatInt(buffer, linkPtr->lastValue.i);
- return buffer;
- case TCL_LINK_DOUBLE:
- linkPtr->lastValue.d = *(double *)(linkPtr->addr);
- Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer);
- return buffer;
- case TCL_LINK_BOOLEAN:
- linkPtr->lastValue.i = *(int *)(linkPtr->addr);
- if (linkPtr->lastValue.i != 0) {
- return "1";
- }
- return "0";
- case TCL_LINK_STRING:
- p = *(char **)(linkPtr->addr);
- if (p == NULL) {
- return "NULL";
- }
- return p;
- }
+ case TCL_LINK_INT:
+ linkPtr->lastValue.i = *(int *)(linkPtr->addr);
+ return Tcl_NewIntObj(linkPtr->lastValue.i);
+ case TCL_LINK_WIDE_INT:
+ linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr);
+ return Tcl_NewWideIntObj(linkPtr->lastValue.w);
+ case TCL_LINK_DOUBLE:
+ linkPtr->lastValue.d = *(double *)(linkPtr->addr);
+ return Tcl_NewDoubleObj(linkPtr->lastValue.d);
+ case TCL_LINK_BOOLEAN:
+ linkPtr->lastValue.i = *(int *)(linkPtr->addr);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
+ case TCL_LINK_STRING:
+ p = *(char **)(linkPtr->addr);
+ if (p == NULL) {
+ return Tcl_NewStringObj("NULL", 4);
+ }
+ return Tcl_NewStringObj(p, -1);
/*
* This code only gets executed if the link type is unknown
* (shouldn't ever happen).
*/
-
- return "??";
+ default:
+ return Tcl_NewStringObj("??", 2);
+ }
}
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
/*
* The structure below defines the list Tcl object type by means of
* procedures that can be invoked by generic object code.
+ *
+ * The internal representation of a list object is a two-pointer
+ * representation. The first pointer designates a List structure that
+ * contains an array of pointers to the element objects, together with
+ * integers that represent the current element count and the allocated
+ * size of the array. The second pointer is normally NULL; during
+ * execution of functions in this file that operate on nested sublists,
+ * it is occasionally used as working storage to avoid an auxiliary
+ * stack.
*/
Tcl_ObjType tclListType = {
listRepPtr->elemCount = objc;
listRepPtr->elements = elemPtrs;
- listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr->typePtr = &tclListType;
}
return listPtr;
* TCL_MEM_DEBUG is defined. It creates new list objects. It is the
* same as the Tcl_NewListObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
- * caller. This simplifies debugging since then the checkmem command
- * will report the correct file name and line number when reporting
- * objects that haven't been freed.
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewListObj.
Tcl_DbNewListObj(objc, objv, file, line)
int objc; /* Count of objects referenced by objv. */
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
listRepPtr->elemCount = objc;
listRepPtr->elements = elemPtrs;
- listPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+ listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr->typePtr = &tclListType;
}
return listPtr;
Tcl_DbNewListObj(objc, objv, file, line)
int objc; /* Count of objects referenced by objv. */
Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
listRepPtr->elemCount = objc;
listRepPtr->elements = elemPtrs;
- objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclListType;
} else {
objPtr->bytes = tclEmptyStringRep;
+ objPtr->length = 0;
}
}
\f
return result;
}
}
- listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
*objcPtr = listRepPtr->elemCount;
*objvPtr = listRepPtr->elements;
return TCL_OK;
return result;
}
}
- listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
listLen = listRepPtr->elemCount;
result = Tcl_ListObjGetElements(interp, elemListPtr, &objc, &objv);
}
}
- listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
numRequired = numElems + 1 ;
}
}
- listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
if ((index < 0) || (index >= listRepPtr->elemCount)) {
*objPtrPtr = NULL;
} else {
}
}
- listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
*intPtr = listRepPtr->elemCount;
return TCL_OK;
}
return result;
}
}
- listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
/*
*----------------------------------------------------------------------
*
+ * TclLsetList --
+ *
+ * Core of the 'lset' command when objc == 4. Objv[2] may be
+ * either a scalar index or a list of indices.
+ *
+ * Results:
+ * Returns the new value of the list variable, or NULL if an
+ * error occurs.
+ *
+ * Side effects:
+ * Surgery is performed on the list value to produce the
+ * result.
+ *
+ * On entry, the reference count of the variable value does not reflect
+ * any references held on the stack. The first action of this function
+ * is to determine whether the object is shared, and to duplicate it if
+ * it is. The reference count of the duplicate is incremented.
+ * At this point, the reference count will be 1 for either case, so that
+ * the object will appear to be unshared.
+ *
+ * If an error occurs, and the object has been duplicated, the reference
+ * count on the duplicate is decremented so that it is now 0: this dismisses
+ * any memory that was allocated by this procedure.
+ *
+ * If no error occurs, the reference count of the original object is
+ * incremented if the object has not been duplicated, and nothing is
+ * done to a reference count of the duplicate. Now the reference count
+ * of an unduplicated object is 2 (the returned pointer, plus the one
+ * stored in the variable). The reference count of a duplicate object
+ * is 1, reflecting that the returned pointer is the only active
+ * reference. The caller is expected to store the returned value back
+ * in the variable and decrement its reference count. (INST_STORE_*
+ * does exactly this.)
+ *
+ * Tcl_LsetFlat and related functions maintain a linked list of
+ * Tcl_Obj's whose string representations must be spoilt by threading
+ * via 'ptr2' of the two-pointer internal representation. On entry
+ * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
+ * the 'ptr2' field of any Tcl_Obj that has been modified is set to
+ * NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclLsetList( interp, listPtr, indexArgPtr, valuePtr )
+ Tcl_Interp* interp; /* Tcl interpreter */
+ Tcl_Obj* listPtr; /* Pointer to the list being modified */
+ Tcl_Obj* indexArgPtr; /* Index or index-list arg to 'lset' */
+ Tcl_Obj* valuePtr; /* Value arg to 'lset' */
+{
+ int indexCount; /* Number of indices in the index list */
+ Tcl_Obj** indices; /* Vector of indices in the index list*/
+
+ int duplicated; /* Flag == 1 if the obj has been
+ * duplicated, 0 otherwise */
+ Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */
+ int index; /* Current index in the list - discarded */
+ int result; /* Status return from library calls */
+ Tcl_Obj* subListPtr; /* Pointer to the current sublist */
+ int elemCount; /* Count of elements in the current sublist */
+ Tcl_Obj** elemPtrs; /* Pointers to elements of current sublist */
+ Tcl_Obj* chainPtr; /* Pointer to the enclosing sublist
+ * of the current sublist */
+ int i;
+
+
+ /*
+ * Determine whether the index arg designates a list or a single
+ * index. We have to be careful about the order of the checks to
+ * avoid repeated shimmering; see TIP #22 and #23 for details.
+ */
+
+ if ( indexArgPtr->typePtr != &tclListType
+ && TclGetIntForIndex( NULL, indexArgPtr, 0, &index ) == TCL_OK ) {
+
+ /*
+ * indexArgPtr designates a single index.
+ */
+
+ return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr );
+
+ } else if ( Tcl_ListObjGetElements( NULL, indexArgPtr,
+ &indexCount, &indices ) != TCL_OK ) {
+
+ /*
+ * indexArgPtr designates something that is neither an index nor a
+ * well formed list. Report the error via TclLsetFlat.
+ */
+
+ return TclLsetFlat( interp, listPtr, 1, &indexArgPtr, valuePtr );
+
+ }
+
+ /*
+ * At this point, we know that argPtr designates a well formed list,
+ * and the 'else if' above has parsed it into indexCount and indices.
+ * If there are no indices, simply return 'valuePtr', counting the
+ * returned pointer as a reference.
+ */
+
+ if ( indexCount == 0 ) {
+ Tcl_IncrRefCount( valuePtr );
+ return valuePtr;
+ }
+
+ /*
+ * Duplicate the list arg if necessary.
+ */
+
+ if ( Tcl_IsShared( listPtr ) ) {
+ duplicated = 1;
+ listPtr = Tcl_DuplicateObj( listPtr );
+ Tcl_IncrRefCount( listPtr );
+ } else {
+ duplicated = 0;
+ }
+
+ /*
+ * It would be tempting simply to go off to TclLsetFlat to finish the
+ * processing. Alas, it is also incorrect! The problem is that
+ * 'indexArgPtr' may designate a sublist of 'listPtr' whose value
+ * is to be manipulated. The fact that 'listPtr' is itself unshared
+ * does not guarantee that no sublist is. Therefore, it's necessary
+ * to replicate all the work here, expanding the index list on each
+ * trip through the loop.
+ */
+
+ /*
+ * Anchor the linked list of Tcl_Obj's whose string reps must be
+ * invalidated if the operation succeeds.
+ */
+
+ retValuePtr = listPtr;
+ chainPtr = NULL;
+
+ /*
+ * Handle each index arg by diving into the appropriate sublist
+ */
+
+ for ( i = 0; ; ++i ) {
+
+ /*
+ * Take the sublist apart.
+ */
+
+ result = Tcl_ListObjGetElements( interp, listPtr,
+ &elemCount, &elemPtrs );
+ if ( result != TCL_OK ) {
+ break;
+ }
+ listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
+
+ /*
+ * Reconstitute the index array
+ */
+
+ result = Tcl_ListObjGetElements( interp, indexArgPtr,
+ &indexCount, &indices );
+ if ( result != TCL_OK ) {
+ /*
+ * Shouldn't be able to get here, because we already
+ * parsed the thing successfully once.
+ */
+ break;
+ }
+
+ /*
+ * Determine the index of the requested element.
+ */
+
+ result = TclGetIntForIndex( interp, indices[ i ],
+ (elemCount - 1), &index );
+ if ( result != TCL_OK ) {
+ break;
+ }
+
+ /*
+ * Check that the index is in range.
+ */
+
+ if ( ( index < 0 ) || ( index >= elemCount ) ) {
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "list index out of range",
+ -1 ) );
+ result = TCL_ERROR;
+ break;
+ }
+
+ /*
+ * Break the loop after extracting the innermost sublist
+ */
+
+ if ( i >= indexCount-1 ) {
+ result = TCL_OK;
+ break;
+ }
+
+ /*
+ * Extract the appropriate sublist, and make sure that it is unshared.
+ */
+
+ subListPtr = elemPtrs[ index ];
+ if ( Tcl_IsShared( subListPtr ) ) {
+ subListPtr = Tcl_DuplicateObj( subListPtr );
+ result = TclListObjSetElement( interp, listPtr, index,
+ subListPtr );
+ if ( result != TCL_OK ) {
+ /*
+ * We actually shouldn't be able to get here, because
+ * we've already checked everything that TclListObjSetElement
+ * checks. If we were to get here, it would result in leaking
+ * subListPtr.
+ */
+ break;
+ }
+ }
+
+ /*
+ * Chain the current sublist onto the linked list of Tcl_Obj's
+ * whose string reps must be spoilt.
+ */
+
+ chainPtr = listPtr;
+ listPtr = subListPtr;
+
+ }
+
+ /*
+ * Store the new element into the correct slot in the innermost sublist.
+ */
+
+ if ( result == TCL_OK ) {
+ result = TclListObjSetElement( interp, listPtr, index, valuePtr );
+ }
+
+ if ( result == TCL_OK ) {
+
+ listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
+
+ /* Spoil all the string reps */
+
+ while ( listPtr != NULL ) {
+ subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2;
+ Tcl_InvalidateStringRep( listPtr );
+ listPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ listPtr = subListPtr;
+ }
+
+ /* Return the new list if everything worked. */
+
+ if ( !duplicated ) {
+ Tcl_IncrRefCount( retValuePtr );
+ }
+ return retValuePtr;
+ }
+
+ /* Clean up the one dangling reference otherwise */
+
+ if ( duplicated ) {
+ Tcl_DecrRefCount( retValuePtr );
+ }
+ return NULL;
+
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLsetFlat --
+ *
+ * Core of the 'lset' command when objc>=5. Objv[2], ... ,
+ * objv[objc-2] contain scalar indices.
+ *
+ * Results:
+ * Returns the new value of the list variable, or NULL if an
+ * error occurs.
+ *
+ * Side effects:
+ * Surgery is performed on the list value to produce the
+ * result.
+ *
+ * On entry, the reference count of the variable value does not reflect
+ * any references held on the stack. The first action of this function
+ * is to determine whether the object is shared, and to duplicate it if
+ * it is. The reference count of the duplicate is incremented.
+ * At this point, the reference count will be 1 for either case, so that
+ * the object will appear to be unshared.
+ *
+ * If an error occurs, and the object has been duplicated, the reference
+ * count on the duplicate is decremented so that it is now 0: this dismisses
+ * any memory that was allocated by this procedure.
+ *
+ * If no error occurs, the reference count of the original object is
+ * incremented if the object has not been duplicated, and nothing is
+ * done to a reference count of the duplicate. Now the reference count
+ * of an unduplicated object is 2 (the returned pointer, plus the one
+ * stored in the variable). The reference count of a duplicate object
+ * is 1, reflecting that the returned pointer is the only active
+ * reference. The caller is expected to store the returned value back
+ * in the variable and decrement its reference count. (INST_STORE_*
+ * does exactly this.)
+ *
+ * Tcl_LsetList and related functions maintain a linked list of
+ * Tcl_Obj's whose string representations must be spoilt by threading
+ * via 'ptr2' of the two-pointer internal representation. On entry
+ * to Tcl_LsetList, the values of 'ptr2' are immaterial; on exit,
+ * the 'ptr2' field of any Tcl_Obj that has been modified is set to
+ * NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclLsetFlat( interp, listPtr, indexCount, indexArray, valuePtr )
+ Tcl_Interp* interp; /* Tcl interpreter */
+ Tcl_Obj* listPtr; /* Pointer to the list being modified */
+ int indexCount; /* Number of index args */
+ Tcl_Obj *CONST indexArray[];
+ /* Index args */
+ Tcl_Obj* valuePtr; /* Value arg to 'lset' */
+{
+
+ int duplicated; /* Flag == 1 if the obj has been
+ * duplicated, 0 otherwise */
+ Tcl_Obj* retValuePtr; /* Pointer to the list to be returned */
+
+ int elemCount; /* Length of one sublist being changed */
+ Tcl_Obj** elemPtrs; /* Pointers to the elements of a sublist */
+
+ Tcl_Obj* subListPtr; /* Pointer to the current sublist */
+
+ int index; /* Index of the element to replace in the
+ * current sublist */
+ Tcl_Obj* chainPtr; /* Pointer to the enclosing list of
+ * the current sublist. */
+
+ int result; /* Status return from library calls */
+
+
+
+ int i;
+
+ /*
+ * If there are no indices, then simply return the new value,
+ * counting the returned pointer as a reference
+ */
+
+ if ( indexCount == 0 ) {
+ Tcl_IncrRefCount( valuePtr );
+ return valuePtr;
+ }
+
+ /*
+ * If the list is shared, make a private copy.
+ */
+
+ if ( Tcl_IsShared( listPtr ) ) {
+ duplicated = 1;
+ listPtr = Tcl_DuplicateObj( listPtr );
+ Tcl_IncrRefCount( listPtr );
+ } else {
+ duplicated = 0;
+ }
+
+ /*
+ * Anchor the linked list of Tcl_Obj's whose string reps must be
+ * invalidated if the operation succeeds.
+ */
+
+ retValuePtr = listPtr;
+ chainPtr = NULL;
+
+ /*
+ * Handle each index arg by diving into the appropriate sublist
+ */
+
+ for ( i = 0; ; ++i ) {
+
+ /*
+ * Take the sublist apart.
+ */
+
+ result = Tcl_ListObjGetElements( interp, listPtr,
+ &elemCount, &elemPtrs );
+ if ( result != TCL_OK ) {
+ break;
+ }
+ listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
+
+ /*
+ * Determine the index of the requested element.
+ */
+
+ result = TclGetIntForIndex( interp, indexArray[ i ],
+ (elemCount - 1), &index );
+ if ( result != TCL_OK ) {
+ break;
+ }
+
+ /*
+ * Check that the index is in range.
+ */
+
+ if ( ( index < 0 ) || ( index >= elemCount ) ) {
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "list index out of range",
+ -1 ) );
+ result = TCL_ERROR;
+ break;
+ }
+
+ /*
+ * Break the loop after extracting the innermost sublist
+ */
+
+ if ( i >= indexCount-1 ) {
+ result = TCL_OK;
+ break;
+ }
+
+ /*
+ * Extract the appropriate sublist, and make sure that it is unshared.
+ */
+
+ subListPtr = elemPtrs[ index ];
+ if ( Tcl_IsShared( subListPtr ) ) {
+ subListPtr = Tcl_DuplicateObj( subListPtr );
+ result = TclListObjSetElement( interp, listPtr, index,
+ subListPtr );
+ if ( result != TCL_OK ) {
+ /*
+ * We actually shouldn't be able to get here.
+ * If we do, it would result in leaking subListPtr,
+ * but everything's been validated already; the error
+ * exit from TclListObjSetElement should never happen.
+ */
+ break;
+ }
+ }
+
+ /*
+ * Chain the current sublist onto the linked list of Tcl_Obj's
+ * whose string reps must be spoilt.
+ */
+
+ chainPtr = listPtr;
+ listPtr = subListPtr;
+
+ }
+
+ /* Store the result in the list element */
+
+ if ( result == TCL_OK ) {
+ result = TclListObjSetElement( interp, listPtr, index, valuePtr );
+ }
+
+ if ( result == TCL_OK ) {
+
+ listPtr->internalRep.twoPtrValue.ptr2 = (VOID *) chainPtr;
+
+ /* Spoil all the string reps */
+
+ while ( listPtr != NULL ) {
+ subListPtr = (Tcl_Obj *) listPtr->internalRep.twoPtrValue.ptr2;
+ Tcl_InvalidateStringRep( listPtr );
+ listPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ listPtr = subListPtr;
+ }
+
+ /* Return the new list if everything worked. */
+
+ if ( !duplicated ) {
+ Tcl_IncrRefCount( retValuePtr );
+ }
+ return retValuePtr;
+ }
+
+ /* Clean up the one dangling reference otherwise */
+
+ if ( duplicated ) {
+ Tcl_DecrRefCount( retValuePtr );
+ }
+ return NULL;
+
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclListObjSetElement --
+ *
+ * Set a single element of a list to a specified value
+ *
+ * Results:
+ *
+ * The return value is normally TCL_OK. If listPtr does not
+ * refer to a list object and cannot be converted to one, TCL_ERROR
+ * is returned and an error message will be left in the interpreter
+ * result if interp is not NULL. Similarly, if index designates
+ * an element outside the range [0..listLength-1], where
+ * listLength is the count of elements in the list object designated
+ * by listPtr, TCL_ERROR is returned and an error message is left
+ * in the interpreter result.
+ *
+ * Side effects:
+ *
+ * Panics if listPtr designates a shared object. Otherwise, attempts
+ * to convert it to a list. Decrements the ref count of the object
+ * at the specified index within the list, replaces with the
+ * object designated by valuePtr, and increments the ref count
+ * of the replacement object.
+ *
+ * It is the caller's responsibility to invalidate the string
+ * representation of the object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclListObjSetElement( interp, listPtr, index, valuePtr )
+ Tcl_Interp* interp; /* Tcl interpreter; used for error reporting
+ * if not NULL */
+ Tcl_Obj* listPtr; /* List object in which element should be
+ * stored */
+ int index; /* Index of element to store */
+ Tcl_Obj* valuePtr; /* Tcl object to store in the designated
+ * list element */
+{
+ int result; /* Return value from this function */
+ List* listRepPtr; /* Internal representation of the list
+ * being modified */
+ Tcl_Obj** elemPtrs; /* Pointers to elements of the list */
+ int elemCount; /* Number of elements in the list */
+
+ /* Ensure that the listPtr parameter designates an unshared list */
+
+ if ( Tcl_IsShared( listPtr ) ) {
+ panic( "Tcl_ListObjSetElement called with shared object" );
+ }
+ if ( listPtr->typePtr != &tclListType ) {
+ result = SetListFromAny( interp, listPtr );
+ if ( result != TCL_OK ) {
+ return result;
+ }
+ }
+ listRepPtr = (List*) listPtr->internalRep.twoPtrValue.ptr1;
+ elemPtrs = listRepPtr->elements;
+ elemCount = listRepPtr->elemCount;
+
+ /* Ensure that the index is in bounds */
+
+ if ( index < 0 || index >= elemCount ) {
+ if ( interp != NULL ) {
+ Tcl_SetObjResult( interp,
+ Tcl_NewStringObj( "list index out of range",
+ -1 ) );
+ return TCL_ERROR;
+ }
+ }
+
+ /* Add a reference to the new list element */
+
+ Tcl_IncrRefCount( valuePtr );
+
+ /* Remove a reference from the old list element */
+
+ Tcl_DecrRefCount( elemPtrs[ index ] );
+
+ /* Stash the new object in the list */
+
+ elemPtrs[ index ] = valuePtr;
+
+ return TCL_OK;
+
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* FreeListInternalRep --
*
* Deallocate the storage associated with a list object's internal
*
* Side effects:
* Frees listPtr's List* internal representation and sets listPtr's
- * internalRep.otherValuePtr to NULL. Decrements the ref counts
+ * internalRep.twoPtrValue.ptr1 to NULL. Decrements the ref counts
* of all element objects, which may free them.
*
*----------------------------------------------------------------------
FreeListInternalRep(listPtr)
Tcl_Obj *listPtr; /* List object with internal rep to free. */
{
- register List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
register Tcl_Obj **elemPtrs = listRepPtr->elements;
register Tcl_Obj *objPtr;
int numElems = listRepPtr->elemCount;
}
ckfree((char *) elemPtrs);
ckfree((char *) listRepPtr);
+
+ listPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ listPtr->internalRep.twoPtrValue.ptr2 = NULL;
}
\f
/*
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
- List *srcListRepPtr = (List *) srcPtr->internalRep.otherValuePtr;
+ List *srcListRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1;
int numElems = srcListRepPtr->elemCount;
int maxElems = srcListRepPtr->maxElemCount;
register Tcl_Obj **srcElemPtrs = srcListRepPtr->elements;
copyListRepPtr->elemCount = numElems;
copyListRepPtr->elements = copyElemPtrs;
- copyPtr->internalRep.otherValuePtr = (VOID *) copyListRepPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) copyListRepPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
copyPtr->typePtr = &tclListType;
}
\f
oldTypePtr->freeIntRepProc(objPtr);
}
- objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclListType;
return TCL_OK;
}
{
# define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr;
- List *listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
+ List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
int numElems = listRepPtr->elemCount;
register int i;
char *elem, *dst;
entryPtr->refCount--;
/*
- * We found the matching LiteralEntry. Check if it's only being
- * kept alive only by a circular reference from a ByteCode
- * stored as its internal rep.
- */
-
- if ((entryPtr->refCount == 1)
- && (objPtr->typePtr == &tclByteCodeType)) {
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if ((codePtr->numLitObjects == 1)
- && (codePtr->objArrayPtr[0] == objPtr)) {
- entryPtr->refCount = 0;
-
- /*
- * Set the ByteCode object array entry NULL to signal
- * to TclCleanupByteCode to not try to release this
- * about to be freed literal again.
- */
-
- codePtr->objArrayPtr[0] = NULL;
- }
- }
-
- /*
* If the literal is no longer being used by any ByteCode,
- * delete the entry then decrement the ref count of its object.
+ * delete the entry then remove the reference corresponding
+ * to the global literal table entry (decrement the ref count
+ * of the object).
*/
if (entryPtr->refCount == 0) {
} else {
prevPtr->nextPtr = entryPtr->nextPtr;
}
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.currentLitStringBytes -= (double) (length + 1);
-#endif /*TCL_COMPILE_STATS*/
ckfree((char *) entryPtr);
globalTablePtr->numEntries--;
+ TclDecrRefCount(objPtr);
+
/*
- * Remove the reference corresponding to the global
- * literal table entry.
+ * Check if the LiteralEntry is only being kept alive by
+ * a circular reference from a ByteCode stored as its
+ * internal rep. In that case, set the ByteCode object array
+ * entry NULL to signal to TclCleanupByteCode to not try to
+ * release this about to be freed literal again.
*/
+
+ if (objPtr->typePtr == &tclByteCodeType) {
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if ((codePtr->numLitObjects == 1)
+ && (codePtr->objArrayPtr[0] == objPtr)) {
+ codePtr->objArrayPtr[0] = NULL;
+ }
+ }
- TclDecrRefCount(objPtr);
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.currentLitStringBytes -= (double) (length + 1);
+#endif /*TCL_COMPILE_STATS*/
}
break;
}
}
-
+
/*
* Remove the reference corresponding to the local literal table
* entry.
*/
+
Tcl_DecrRefCount(objPtr);
}
\f
* either dynamically (with the "load" command) or statically (as
* indicated by a call to TclGetLoadedPackages). All such packages
* are linked together into a single list for the process. Packages
- * are never unloaded, so these structures are never freed.
+ * are never unloaded, until the application exits, when
+ * TclFinalizeLoad is called, and these structures are freed.
*/
typedef struct LoadedPackage {
* properly capitalized (first letter UC,
* others LC), no "_", as in "Net".
* Malloc-ed. */
- ClientData clientData; /* Token for the loaded file which should be
- * passed to TclpUnloadFile() when the file
+ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be
+ * passed to (*unLoadProcPtr)() when the file
* is no longer needed. If fileName is NULL,
* then this field is irrelevant. */
Tcl_PackageInitProc *initProc;
* untrusted scripts). NULL means the
* package can't be used in unsafe
* interpreters. */
+ Tcl_FSUnloadFileProc *unLoadProcPtr;
+ /* Procedure to use to unload this package.
+ * If NULL, then we do not attempt to unload
+ * the package. If fileName is NULL, then
+ * this field is irrelevant. */
struct LoadedPackage *nextPtr;
/* Next in list of all packages loaded into
* this application process. NULL means
{
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString pkgName, tmp, initName, safeInitName, fileName;
+ Tcl_DString pkgName, tmp, initName, safeInitName;
Tcl_PackageInitProc *initProc, *safeInitProc;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch;
- char *p, *tempString, *fullFileName, *packageName;
- ClientData clientData;
+ char *p, *fullFileName, *packageName;
+ Tcl_LoadHandle loadHandle;
+ Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
Tcl_UniChar ch;
int offset;
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
return TCL_ERROR;
}
- tempString = Tcl_GetString(objv[1]);
- fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);
- if (fullFileName == NULL) {
+ if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
+ fullFileName = Tcl_GetString(objv[1]);
+
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
*/
retc = TclGuessPackageName(fullFileName, &pkgName);
if (!retc) {
- int pargc;
- char **pargv, *pkgGuess;
+ Tcl_Obj *splitPtr;
+ Tcl_Obj *pkgGuessPtr;
+ int pElements;
+ char *pkgGuess;
/*
* The platform-specific code couldn't figure out the
* characters that follow that.
*/
- Tcl_SplitPath(fullFileName, &pargc, &pargv);
- pkgGuess = pargv[pargc-1];
+ splitPtr = Tcl_FSSplitPath(objv[1], &pElements);
+ Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr);
+ pkgGuess = Tcl_GetString(pkgGuessPtr);
if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i')
&& (pkgGuess[2] == 'b')) {
pkgGuess += 3;
}
}
if (p == pkgGuess) {
- ckfree((char *)pargv);
+ Tcl_DecrRefCount(splitPtr);
Tcl_AppendResult(interp,
"couldn't figure out package name for ",
fullFileName, (char *) NULL);
goto done;
}
Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
- ckfree((char *)pargv);
+ Tcl_DecrRefCount(splitPtr);
}
}
*/
Tcl_MutexLock(&packageMutex);
- code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
+ code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
- &clientData);
+ &loadHandle,&unLoadProcPtr);
Tcl_MutexUnlock(&packageMutex);
if (code != TCL_OK) {
goto done;
if (initProc == NULL) {
Tcl_AppendResult(interp, "couldn't find procedure ",
Tcl_DStringValue(&initName), (char *) NULL);
- TclpUnloadFile(clientData);
+ if (unLoadProcPtr != NULL) {
+ (*unLoadProcPtr)(loadHandle);
+ }
code = TCL_ERROR;
goto done;
}
pkgPtr->packageName = (char *) ckalloc((unsigned)
(Tcl_DStringLength(&pkgName) + 1));
strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
- pkgPtr->clientData = clientData;
+ pkgPtr->loadHandle = loadHandle;
+ pkgPtr->unLoadProcPtr = unLoadProcPtr;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
Tcl_DStringFree(&pkgName);
Tcl_DStringFree(&initName);
Tcl_DStringFree(&safeInitName);
- Tcl_DStringFree(&fileName);
Tcl_DStringFree(&tmp);
return code;
}
* package has already been loaded
* into the given interpreter by
* calling the appropriate init proc. */
- char *pkgName; /* Name of package (must be properly
+ CONST char *pkgName; /* Name of package (must be properly
* capitalized: first letter upper
* case, others lower case). */
Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate
pkgPtr->packageName = (char *) ckalloc((unsigned)
(strlen(pkgName) + 1));
strcpy(pkgPtr->packageName, pkgName);
- pkgPtr->clientData = NULL;
+ pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
* call a function in the dll after it's been unloaded.
*/
if (pkgPtr->fileName[0] != '\0') {
- TclpUnloadFile(pkgPtr->clientData);
+ Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
+ if (unLoadProcPtr != NULL) {
+ (*unLoadProcPtr)(pkgPtr->loadHandle);
+ }
}
#endif
ckfree(pkgPtr->fileName);
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* This procedure is called to carry out dynamic loading of binary
* code; it is intended for use only on systems that don't support
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
Tcl_SetResult(interp,
"dynamic loading is not currently available on this system",
/*
*----------------------------------------------------------------------
*
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ return NULL;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclGuessPackageName --
*
* If the "load" command is invoked without providing a package
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
- * a token that represents the loaded
- * file. */
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
+ * a token that represents the loaded
+ * file. */
{
}
*
* Copyright (c) 1988-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 2000 Ajuba Solutions.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# define TCL_STORAGE_CLASS DLLEXPORT
/*
- * The following code ensures that tclLink.c is linked whenever
- * Tcl is linked. Without this code there's no reference to the
- * code in that file from anywhere in Tcl, so it may not be
- * linked into the application.
- */
-
-EXTERN int Tcl_LinkVar();
-int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
-
-/*
* Declarations for various library procedures and variables (don't want
* to include tclPort.h here, because people might copy this file out of
* the Tcl source directory to make their own modified versions).
- * Note: "exit" should really be declared here, but there's no way to
- * declare it without causing conflicts with other definitions elsewher
- * on some systems, so it's better just to leave it out.
*/
+#if !defined(MAC_TCL)
extern int isatty _ANSI_ARGS_((int fd));
-extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
+#else
+#include <unistd.h>
+#endif
+
+static Tcl_Obj *tclStartupScriptPath = NULL;
-static char *tclStartupScriptFileName = NULL;
+static Tcl_MainLoopProc *mainLoopProc = NULL;
+/*
+ * Structure definition for information used to keep the state of
+ * an interactive command processor that reads lines from standard
+ * input and writes prompts and results to standard output.
+ */
+
+typedef enum {
+ PROMPT_NONE, /* Print no prompt */
+ PROMPT_START, /* Print prompt for command start */
+ PROMPT_CONTINUE /* Print prompt for command continuation */
+} PromptType;
+
+typedef struct InteractiveState {
+ Tcl_Channel input; /* The standard input channel from which
+ * lines are read. */
+ int tty; /* Non-zero means standard input is a
+ * terminal-like device. Zero means it's
+ * a file. */
+ Tcl_Obj *commandPtr; /* Used to assemble lines of input into
+ * Tcl commands. */
+ PromptType prompt; /* Next prompt to print */
+ Tcl_Interp *interp; /* Interpreter that evaluates interactive
+ * commands. */
+} InteractiveState;
+
+/*
+ * Forward declarations for procedures defined later in this file.
+ */
+static void Prompt _ANSI_ARGS_((Tcl_Interp *interp,
+ PromptType *promptPtr));
+static void StdinProc _ANSI_ARGS_((ClientData clientData,
+ int mask));
\f
/*
*----------------------------------------------------------------------
*
+ * TclSetStartupScriptPath --
+ *
+ * Primes the startup script VFS path, used to override the
+ * command line processing.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * This procedure initializes the VFS path of the Tcl script to
+ * run at startup.
+ *
+ *----------------------------------------------------------------------
+ */
+void TclSetStartupScriptPath(pathPtr)
+ Tcl_Obj *pathPtr;
+{
+ if (tclStartupScriptPath != NULL) {
+ Tcl_DecrRefCount(tclStartupScriptPath);
+ }
+ tclStartupScriptPath = pathPtr;
+ if (tclStartupScriptPath != NULL) {
+ Tcl_IncrRefCount(tclStartupScriptPath);
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetStartupScriptPath --
+ *
+ * Gets the startup script VFS path, used to override the
+ * command line processing.
+ *
+ * Results:
+ * The startup script VFS path, NULL if none has been set.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *TclGetStartupScriptPath()
+{
+ return tclStartupScriptPath;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclSetStartupScriptFileName --
*
* Primes the startup script file name, used to override the
*----------------------------------------------------------------------
*/
void TclSetStartupScriptFileName(fileName)
- char *fileName;
+ CONST char *fileName;
{
- tclStartupScriptFileName = fileName;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
+ TclSetStartupScriptPath(pathPtr);
}
\f
*
*----------------------------------------------------------------------
*/
-char *TclGetStartupScriptFileName()
+CONST char *TclGetStartupScriptFileName()
{
- return tclStartupScriptFileName;
+ Tcl_Obj *pathPtr = TclGetStartupScriptPath();
+
+ if (pathPtr == NULL) {
+ return NULL;
+ }
+ return Tcl_GetString(pathPtr);
}
*
* Results:
* None. This procedure never returns (it exits the process when
- * it's done.
+ * it's done).
*
* Side effects:
* This procedure initializes the Tcl world and then starts
{
Tcl_Obj *resultPtr;
Tcl_Obj *commandPtr = NULL;
- char buffer[1000], *args;
- int code, gotPartial, tty, length;
+ char buffer[TCL_INTEGER_SPACE + 5], *args;
+ PromptType prompt = PROMPT_START;
+ int code, length, tty;
int exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString argString;
Tcl_FindExecutable(argv[0]);
+
interp = Tcl_CreateInterp();
-#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
-#endif
/*
* Make command-line arguments available in the Tcl variables "argc"
* strip it off and use it as the name of a script file to process.
*/
- if (tclStartupScriptFileName == NULL) {
+ if (TclGetStartupScriptPath() == NULL) {
if ((argc > 1) && (argv[1][0] != '-')) {
- tclStartupScriptFileName = argv[1];
+ TclSetStartupScriptFileName(argv[1]);
argc--;
argv++;
}
}
- args = Tcl_Merge(argc-1, argv+1);
+
+ /*
+ * The CONST casting is safe, and better we do it here than force
+ * all callers of Tcl_Main to do it. (Those callers are likely
+ * in a main() that can't easily change its signature.)
+ */
+
+ args = Tcl_Merge(argc-1, (CONST char **)argv+1);
Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&argString);
ckfree(args);
- if (tclStartupScriptFileName == NULL) {
+ if (TclGetStartupScriptPath() == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
} else {
- tclStartupScriptFileName = Tcl_ExternalToUtfDString(NULL,
- tclStartupScriptFileName, -1, &argString);
+ TclSetStartupScriptFileName(Tcl_ExternalToUtfDString(NULL,
+ TclGetStartupScriptFileName(), -1, &argString));
}
- TclFormatInt(buffer, argc-1);
+ TclFormatInt(buffer, (long) argc-1);
Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive",
- ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0",
+ ((TclGetStartupScriptPath() == NULL) && tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
+ Tcl_Preserve((ClientData) interp);
if ((*appInitProc)(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteChars(errChannel, "\n", 1);
}
}
+ if (Tcl_InterpDeleted(interp)) {
+ goto done;
+ }
/*
* If a script file was specified then just source that file
* and quit.
*/
- if (tclStartupScriptFileName != NULL) {
- code = Tcl_EvalFile(interp, tclStartupScriptFileName);
+ if (TclGetStartupScriptPath() != NULL) {
+ code = Tcl_FSEvalFile(interp, TclGetStartupScriptPath());
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
+
/*
* The following statement guarantees that the errorInfo
* variable is set properly.
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
+ /*
+ * Get a new value for tty if anyone writes to ::tcl_interactive
+ */
+ Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- gotPartial = 0;
- while (1) {
+ while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
if (tty) {
- Tcl_Obj *promptCmdPtr;
-
- promptCmdPtr = Tcl_GetVar2Ex(interp,
- (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
- NULL, TCL_GLOBAL_ONLY);
- if (promptCmdPtr == NULL) {
- defaultPrompt:
- if (!gotPartial && outChannel) {
- Tcl_WriteChars(outChannel, "% ", 2);
- }
- } else {
- code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
- inChannel = Tcl_GetStdChannel(TCL_STDIN);
- outChannel = Tcl_GetStdChannel(TCL_STDOUT);
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (code != TCL_OK) {
- if (errChannel) {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
- }
- Tcl_AddErrorInfo(interp,
- "\n (script that generates prompt)");
- goto defaultPrompt;
- }
+ Prompt(interp, &prompt);
+ if (Tcl_InterpDeleted(interp)) {
+ break;
}
- if (outChannel) {
- Tcl_Flush(outChannel);
+ inChannel = Tcl_GetStdChannel(TCL_STDIN);
+ if (inChannel == (Tcl_Channel) NULL) {
+ break;
}
}
- if (!inChannel) {
- goto done;
+ if (Tcl_IsShared(commandPtr)) {
+ Tcl_DecrRefCount(commandPtr);
+ commandPtr = Tcl_DuplicateObj(commandPtr);
+ Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
- goto done;
- }
- if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
- goto done;
+ if (Tcl_InputBlocked(inChannel)) {
+
+ /*
+ * This can only happen if stdin has been set to
+ * non-blocking. In that case cycle back and try
+ * again. This sets up a tight polling loop (since
+ * we have no event loop running). If this causes
+ * bad CPU hogging, we might try toggling the blocking
+ * on stdin instead.
+ */
+
+ continue;
+ }
+
+ /*
+ * Either EOF, or an error on stdin; we're done
+ */
+
+ break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string.
*/
+ if (Tcl_IsShared(commandPtr)) {
+ Tcl_DecrRefCount(commandPtr);
+ commandPtr = Tcl_DuplicateObj(commandPtr);
+ Tcl_IncrRefCount(commandPtr);
+ }
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
- gotPartial = 1;
+ prompt = PROMPT_CONTINUE;
continue;
}
- gotPartial = 0;
- code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
+ prompt = PROMPT_START;
+ code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
+ Tcl_DecrRefCount(resultPtr);
+ }
+ if (mainLoopProc != NULL) {
+
+ /*
+ * If a main loop has been defined while running interactively,
+ * we want to start a fileevent based prompt by establishing a
+ * channel handler for stdin.
+ */
+
+ InteractiveState *isPtr = NULL;
+
+ if (inChannel) {
+ if (tty) {
+ Prompt(interp, &prompt);
+ }
+ isPtr = (InteractiveState *)
+ ckalloc((int) sizeof(InteractiveState));
+ isPtr->input = inChannel;
+ isPtr->tty = tty;
+ isPtr->commandPtr = commandPtr;
+ isPtr->prompt = prompt;
+ isPtr->interp = interp;
+
+ Tcl_UnlinkVar(interp, "tcl_interactive");
+ Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty),
+ TCL_LINK_BOOLEAN);
+
+ Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
+ (ClientData) isPtr);
+ }
+
+ (*mainLoopProc)();
+ mainLoopProc = NULL;
+
+ if (inChannel) {
+ tty = isPtr->tty;
+ Tcl_UnlinkVar(interp, "tcl_interactive");
+ Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
+ TCL_LINK_BOOLEAN);
+ prompt = isPtr->prompt;
+ commandPtr = isPtr->commandPtr;
+ if (isPtr->input != (Tcl_Channel) NULL) {
+ Tcl_DeleteChannelHandler(isPtr->input, StdinProc,
+ (ClientData) isPtr);
+ }
+ ckfree((char *)isPtr);
+ }
+ inChannel = Tcl_GetStdChannel(TCL_STDIN);
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
}
#ifdef TCL_MEM_DEBUG
+
+ /*
+ * This code here only for the (unsupported and deprecated)
+ * [checkmem] command.
+ */
+
if (tclMemDumpFileName != NULL) {
- Tcl_DecrRefCount(commandPtr);
+ mainLoopProc = NULL;
Tcl_DeleteInterp(interp);
- Tcl_Exit(0);
}
#endif
}
+ done:
+ if ((exitCode == 0) && (mainLoopProc != NULL)) {
+
+ /*
+ * If everything has gone OK so far, call the main loop proc,
+ * if it exists. Packages (like Tk) can set it to start processing
+ * events at this point.
+ */
+
+ (*mainLoopProc)();
+ mainLoopProc = NULL;
+ }
+ if (commandPtr != NULL) {
+ Tcl_DecrRefCount(commandPtr);
+ }
+
/*
* Rather than calling exit, invoke the "exit" command so that
* users can replace "exit" with some other command to do additional
* cleanup on exit. The Tcl_Eval call should never return.
*/
- done:
- if (commandPtr != NULL) {
+ if (!Tcl_InterpDeleted(interp)) {
+ sprintf(buffer, "exit %d", exitCode);
+ Tcl_Eval(interp, buffer);
+
+ /*
+ * If Tcl_Eval returns, trying to eval [exit], something
+ * unusual is happening. Maybe interp has been deleted;
+ * maybe [exit] was redefined. We still want to cleanup
+ * and exit.
+ */
+
+ if (!Tcl_InterpDeleted(interp)) {
+ Tcl_DeleteInterp(interp);
+ }
+ }
+ TclSetStartupScriptPath(NULL);
+
+ /*
+ * If we get here, the master interp has been deleted. Allow
+ * its destruction with the last matching Tcl_Release.
+ */
+
+ Tcl_Release((ClientData) interp);
+ Tcl_Exit(exitCode);
+}
+\f
+/*
+ *---------------------------------------------------------------
+ *
+ * Tcl_SetMainLoop --
+ *
+ * Sets an alternative main loop procedure.
+ *
+ * Results:
+ * Returns the previously defined main loop procedure.
+ *
+ * Side effects:
+ * This procedure will be called before Tcl exits, allowing for
+ * the creation of an event loop.
+ *
+ *---------------------------------------------------------------
+ */
+
+void
+Tcl_SetMainLoop(proc)
+ Tcl_MainLoopProc *proc;
+{
+ mainLoopProc = proc;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * StdinProc --
+ *
+ * This procedure is invoked by the event dispatcher whenever
+ * standard input becomes readable. It grabs the next line of
+ * input characters, adds them to a command being assembled, and
+ * executes the command if it's complete.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Could be almost arbitrary, depending on the command that's
+ * typed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static void
+StdinProc(clientData, mask)
+ ClientData clientData; /* The state of interactive cmd line */
+ int mask; /* Not used. */
+{
+ InteractiveState *isPtr = (InteractiveState *) clientData;
+ Tcl_Channel chan = isPtr->input;
+ Tcl_Obj *commandPtr = isPtr->commandPtr;
+ Tcl_Interp *interp = isPtr->interp;
+ int code, length;
+
+ if (Tcl_IsShared(commandPtr)) {
+ Tcl_DecrRefCount(commandPtr);
+ commandPtr = Tcl_DuplicateObj(commandPtr);
+ Tcl_IncrRefCount(commandPtr);
+ }
+ length = Tcl_GetsObj(chan, commandPtr);
+ if (length < 0) {
+ if (Tcl_InputBlocked(chan)) {
+ return;
+ }
+ if (isPtr->tty) {
+ /*
+ * Would be better to find a way to exit the mainLoop?
+ * Or perhaps evaluate [exit]? Leaving as is for now due
+ * to compatibility concerns.
+ */
+ Tcl_Exit(0);
+ }
+ Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) isPtr);
+ return;
+ }
+
+ if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
+ commandPtr = Tcl_DuplicateObj(commandPtr);
+ Tcl_IncrRefCount(commandPtr);
+ }
+ Tcl_AppendToObj(commandPtr, "\n", 1);
+ if (!TclObjCommandComplete(commandPtr)) {
+ isPtr->prompt = PROMPT_CONTINUE;
+ goto prompt;
+ }
+ isPtr->prompt = PROMPT_START;
+
+ /*
+ * Disable the stdin channel handler while evaluating the command;
+ * otherwise if the command re-enters the event loop we might
+ * process commands from stdin before the current command is
+ * finished. Among other things, this will trash the text of the
+ * command being evaluated.
+ */
+
+ Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) isPtr);
+ code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
+ isPtr->input = chan = Tcl_GetStdChannel(TCL_STDIN);
+ Tcl_DecrRefCount(commandPtr);
+ isPtr->commandPtr = commandPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(commandPtr);
+ if (chan != (Tcl_Channel) NULL) {
+ Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
+ (ClientData) isPtr);
+ }
+ if (code != TCL_OK) {
+ Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
+ }
+ } else if (isPtr->tty) {
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+ Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ Tcl_IncrRefCount(resultPtr);
+ Tcl_GetStringFromObj(resultPtr, &length);
+ if ((length >0) && (outChannel != (Tcl_Channel) NULL)) {
+ Tcl_WriteObj(outChannel, resultPtr);
+ Tcl_WriteChars(outChannel, "\n", 1);
+ }
+ Tcl_DecrRefCount(resultPtr);
+ }
+
+ /*
+ * If a tty stdin is still around, output a prompt.
+ */
+
+ prompt:
+ if (isPtr->tty && (isPtr->input != (Tcl_Channel) NULL)) {
+ Prompt(interp, &(isPtr->prompt));
+ isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Prompt --
+ *
+ * Issue a prompt on standard output, or invoke a script
+ * to issue the prompt.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A prompt gets output, and a Tcl script may be evaluated
+ * in interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+Prompt(interp, promptPtr)
+ Tcl_Interp *interp; /* Interpreter to use for prompting. */
+ PromptType *promptPtr; /* Points to type of prompt to print.
+ * Filled with PROMPT_NONE after a
+ * prompt is printed. */
+{
+ Tcl_Obj *promptCmdPtr;
+ int code;
+ Tcl_Channel outChannel, errChannel;
+
+ if (*promptPtr == PROMPT_NONE) {
+ return;
+ }
+
+ promptCmdPtr = Tcl_GetVar2Ex(interp,
+ ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
+ NULL, TCL_GLOBAL_ONLY);
+ if (Tcl_InterpDeleted(interp)) {
+ return;
+ }
+ if (promptCmdPtr == NULL) {
+ defaultPrompt:
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ if ((*promptPtr == PROMPT_START)
+ && (outChannel != (Tcl_Channel) NULL)) {
+ Tcl_WriteChars(outChannel, "% ", 2);
+ }
+ } else {
+ code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
+ if (code != TCL_OK) {
+ Tcl_AddErrorInfo(interp,
+ "\n (script that generates prompt)");
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
+ }
+ goto defaultPrompt;
+ }
+ }
+ outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ if (outChannel != (Tcl_Channel) NULL) {
+ Tcl_Flush(outChannel);
}
- sprintf(buffer, "exit %d", exitCode);
- Tcl_Eval(interp, buffer);
+ *promptPtr = PROMPT_NONE;
}
static int NamespaceEvalCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
+static int NamespaceExistsCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
static int NamespaceExportCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
* None.
*
* Side effects:
- * The namespace object type is registered with the Tcl compiler.
+ * None.
*
*----------------------------------------------------------------------
*/
void
TclInitNamespaceSubsystem()
{
- Tcl_RegisterObjType(&tclNsNameType);
+ /*
+ * Does nothing for now.
+ */
}
\f
/*
Tcl_Interp *interp; /* Interpreter in which a new namespace
* is being created. Also used for
* error reporting. */
- char *name; /* Name for the new namespace. May be a
+ CONST char *name; /* Name for the new namespace. May be a
* qualified name with names of ancestor
* namespaces separated by "::"s. */
ClientData clientData; /* One-word value to store with
register Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
- char *simpleName;
+ CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
int newEntry;
* variables, in case they had any traces on them.
*/
- char *str, *errorInfoStr, *errorCodeStr;
+ CONST char *str;
+ char *errorInfoStr, *errorCodeStr;
str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorInfo", TCL_GLOBAL_ONLY);
if (str != NULL) {
Tcl_Namespace *namespacePtr; /* Points to the namespace from which
* commands are to be exported. NULL for
* the current namespace. */
- char *pattern; /* String pattern indicating which commands
+ CONST char *pattern; /* String pattern indicating which commands
* to export. This pattern may not include
* any namespace qualifiers; only commands
* in the specified namespace may be
#define INIT_EXPORT_PATTERNS 5
Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
- char *simplePattern, *patternCpy;
+ CONST char *simplePattern;
+ char *patternCpy;
int neededElems, len, i;
/*
Tcl_Namespace *namespacePtr; /* Points to the namespace into which the
* commands are to be imported. NULL for
* the current namespace. */
- char *pattern; /* String pattern indicating which commands
+ CONST char *pattern; /* String pattern indicating which commands
* to import. This pattern should be
* qualified by the name of the namespace
* from which to import the command(s). */
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr, *importNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
- char *simplePattern, *cmdName;
+ CONST char *simplePattern;
+ char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
"import pattern \"", pattern,
"\" would create a loop containing command \"",
Tcl_DStringValue(&ds), "\"", (char *) NULL);
+ Tcl_DStringFree(&ds);
return TCL_ERROR;
}
}
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
+ Tcl_DStringFree(&ds);
/*
* Create an ImportRef structure describing this new import
Tcl_Namespace *namespacePtr; /* Points to the namespace from which
* previously imported commands should be
* removed. NULL for current namespace. */
- char *pattern; /* String pattern indicating which imported
+ CONST char *pattern; /* String pattern indicating which imported
* commands to remove. This pattern should
* be qualified by the name of the
* namespace from which the command(s) were
* imported. */
{
Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr;
- char *simplePattern, *cmdName;
+ CONST char *simplePattern;
+ char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Command *cmdPtr;
nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
Tcl_Interp *interp; /* Interpreter in which to find the
* namespace containing qualName. */
- register char *qualName; /* A namespace-qualified name of an
+ CONST char *qualName; /* A namespace-qualified name of an
* command, variable, or namespace. */
Namespace *cxtNsPtr; /* The namespace in which to start the
* search for qualName's namespace. If NULL
* the :: namespace if TCL_GLOBAL_ONLY was
* specified, or the current namespace if
* cxtNsPtr was NULL. */
- char **simpleNamePtr; /* Address where procedure stores the
+ CONST char **simpleNamePtr; /* Address where procedure stores the
* simple name at end of the qualName, or
* NULL if qualName is "::" or the flag
* FIND_ONLY_NS was specified. */
Namespace *nsPtr = cxtNsPtr;
Namespace *altNsPtr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
- register char *start, *end;
- char *nsName;
+ CONST char *start, *end;
+ CONST char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
Tcl_FindNamespace(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* namespace. */
- char *name; /* Namespace name. If it starts with "::",
+ CONST char *name; /* Namespace name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* TCL_LEAVE_ERR_MSG flags. */
{
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
- char *dummy;
+ CONST char *dummy;
/*
* Find the namespace(s) that contain the specified namespace name.
Tcl_FindCommand(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* command and to report errors. */
- char *name; /* Command's name. If it starts with "::",
+ CONST char *name; /* Command's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
- char *simpleName;
+ CONST char *simpleName;
register Tcl_HashEntry *entryPtr;
register Command *cmdPtr;
register int search;
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* variable. */
- char *name; /* Variable's name. If it starts with "::",
+ CONST char *name; /* Variable's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
Interp *iPtr = (Interp*)interp;
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
- char *simpleName;
+ CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Var *varPtr;
register int search;
hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
if (hPtr != NULL) {
nsPtr->cmdRefEpoch++;
+
+ /*
+ * If the shadowed command was compiled to bytecodes, we
+ * invalidate all the bytecodes in nsPtr, to force a new
+ * compilation. We use the resolverEpoch to signal the need
+ * for a fresh compilation of every bytecode.
+ */
+
+ if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) {
+ nsPtr->resolverEpoch++;
+ }
}
}
* of a namespace. */
Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */
{
+ Interp *iPtr = (Interp *) interp;
register ResolvedNsName *resNamePtr;
register Namespace *nsPtr;
- Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
- int result;
+ Namespace *currNsPtr;
+ CallFrame *savedFramePtr;
+ int result = TCL_OK;
+ char *name;
/*
+ * If the namespace name is fully qualified, do as if the lookup were
+ * done from the global namespace; this helps avoid repeated lookups
+ * of fully qualified names.
+ */
+
+ savedFramePtr = iPtr->varFramePtr;
+ name = Tcl_GetString(objPtr);
+ if ((*name++ == ':') && (*name == ':')) {
+ iPtr->varFramePtr = NULL;
+ }
+
+ currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+
+ /*
* Get the internal representation, converting to a namespace type if
* needed. The internal representation is a ResolvedNsName that points
* to the actual namespace.
if (objPtr->typePtr != &tclNsNameType) {
result = tclNsNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
- return TCL_ERROR;
+ goto done;
}
}
resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
if (nsPtr == NULL) { /* try again */
result = tclNsNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
- return TCL_ERROR;
+ goto done;
}
resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
if (resNamePtr != NULL) {
}
}
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
- return TCL_OK;
+
+ done:
+ iPtr->varFramePtr = savedFramePtr;
+ return result;
}
\f
/*
* namespace current
* namespace delete ?name name...?
* namespace eval name arg ?arg...?
+ * namespace exists name
* namespace export ?-clear? ?pattern pattern...?
* namespace forget ?pattern pattern...?
* namespace import ?-force? ?pattern pattern...?
register int objc; /* Number of arguments. */
register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- static char *subCmds[] = {
- "children", "code", "current", "delete",
- "eval", "export", "forget", "import",
- "inscope", "origin", "parent", "qualifiers",
- "tail", "which", (char *) NULL};
+ static CONST char *subCmds[] = {
+ "children", "code", "current", "delete",
+ "eval", "exists", "export", "forget", "import",
+ "inscope", "origin", "parent", "qualifiers",
+ "tail", "which", (char *) NULL
+ };
enum NSSubCmdIdx {
- NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx,
- NSEvalIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
- NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
- NSTailIdx, NSWhichIdx
+ NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx,
+ NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
+ NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
+ NSTailIdx, NSWhichIdx
};
int index, result;
case NSEvalIdx:
result = NamespaceEvalCmd(clientData, interp, objc, objv);
break;
+ case NSExistsIdx:
+ result = NamespaceExistsCmd(clientData, interp, objc, objv);
+ break;
case NSExportIdx:
result = NamespaceExportCmd(clientData, interp, objc, objv);
break;
* Here "arg" can be a list. "namespace code arg" produces a result
* equivalent to that produced by the command
*
- * list namespace inscope [namespace current] $arg
+ * list ::namespace inscope [namespace current] $arg
*
* However, if "arg" is itself a scoped value starting with
- * "namespace inscope", then the result is just "arg".
+ * "::namespace inscope", then the result is just "arg".
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*/
arg = Tcl_GetStringFromObj(objv[2], &length);
+ while (*arg == ':') {
+ arg++;
+ length--;
+ }
if ((*arg == 'n') && (length > 17)
&& (strncmp(arg, "namespace", 9) == 0)) {
for (p = (arg + 9); (*p == ' '); p++) {
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj("namespace", -1));
+ Tcl_NewStringObj("::namespace", -1));
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj("inscope", -1));
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
- Tcl_CallFrame frame;
+ CallFrame frame;
Tcl_Obj *objPtr;
char *name;
int length, result;
* the command(s).
*/
- result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
- /*isProcCallFrame*/ 0);
+ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame,
+ namespacePtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return TCL_ERROR;
}
+ frame.objc = objc;
+ frame.objv = objv; /* ref counts do not need to be incremented here */
if (objc == 4) {
result = Tcl_EvalObjEx(interp, objv[3], 0);
/*
*----------------------------------------------------------------------
*
+ * NamespaceExistsCmd --
+ *
+ * Invoked to implement the "namespace exists" command that returns
+ * true if the given namespace currently exists, and false otherwise.
+ * Handles the following syntax:
+ *
+ * namespace exists name
+ *
+ * Results:
+ * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ * Returns a result in the interpreter's result object. If anything
+ * goes wrong, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NamespaceExistsCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Tcl_Namespace *namespacePtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check whether the given namespace exists
+ */
+
+ if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL));
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* NamespaceExportCmd --
*
* Invoked to implement the "namespace export" command that specifies
register Tcl_Obj *objPtr; /* The object to convert. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
- char *name, *dummy;
+ char *name;
+ CONST char *dummy;
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
register ResolvedNsName *resNamePtr;
}
objPtr->length = length;
}
-
Tcl_MutexLock(&listLock);
tsdPtr->threadId = Tcl_GetCurrentThread();
- tsdPtr->clientData = Tcl_InitNotifier();
+ tsdPtr->clientData = tclStubs.tcl_InitNotifier();
tsdPtr->nextPtr = firstNotifierPtr;
firstNotifierPtr = tsdPtr;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadSpecificData **prevPtrPtr;
+ Tcl_Event *evPtr, *hold;
+
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
+ for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) {
+ hold = evPtr;
+ evPtr = evPtr->nextPtr;
+ ckfree((char *) hold);
+ }
+ tsdPtr->firstEventPtr = NULL;
+ tsdPtr->lastEventPtr = NULL;
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
- Tcl_FinalizeNotifier(tsdPtr->clientData);
+ tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);
Tcl_MutexFinalize(&(tsdPtr->queueMutex));
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
#endif
tclStubs.tcl_SetTimer = notifierProcPtr->setTimerProc;
tclStubs.tcl_WaitForEvent = notifierProcPtr->waitForEventProc;
+ tclStubs.tcl_InitNotifier = notifierProcPtr->initNotifierProc;
+ tclStubs.tcl_FinalizeNotifier = notifierProcPtr->finalizeNotifierProc;
+ tclStubs.tcl_AlertNotifier = notifierProcPtr->alertNotifierProc;
+ tclStubs.tcl_ServiceModeHook = notifierProcPtr->serviceModeHookProc;
}
\f
/*
oldMode = tsdPtr->serviceMode;
tsdPtr->serviceMode = mode;
- Tcl_ServiceModeHook(mode);
+ tclStubs.tcl_ServiceModeHook(mode);
return oldMode;
}
\f
Tcl_MutexLock(&listLock);
for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
if (tsdPtr->threadId == threadId) {
- Tcl_AlertNotifier(tsdPtr->clientData);
+ tclStubs.tcl_AlertNotifier(tsdPtr->clientData);
break;
}
}
Tcl_MutexUnlock(&listLock);
}
-
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
+#include "tclCompile.h"
#include "tclPort.h"
/*
* is shared by all new objects allocated by Tcl_NewObj.
*/
-static char emptyString;
-char *tclEmptyStringRep = &emptyString;
-
-/*
- * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed
- * (by TclFreeObj).
- */
-
-#ifdef TCL_COMPILE_STATS
-long tclObjsAlloced = 0;
-long tclObjsFreed = 0;
-#endif /* TCL_COMPILE_STATS */
+char tclEmptyString = '\0';
+char *tclEmptyStringRep = &tclEmptyString;
/*
* Prototypes for procedures defined later in this file:
static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr));
static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr));
static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
+#ifndef TCL_WIDE_INT_IS_LONG
+static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr));
+#endif
+
+/*
+ * Prototypes for the array hash key methods.
+ */
+
+static Tcl_HashEntry * AllocObjEntry _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr, VOID *keyPtr));
+static int CompareObjKeys _ANSI_ARGS_((
+ VOID *keyPtr, Tcl_HashEntry *hPtr));
+static void FreeObjEntry _ANSI_ARGS_((
+ Tcl_HashEntry *hPtr));
+static unsigned int HashObjKey _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ VOID *keyPtr));
+
+/*
+ * Prototypes for the CommandName object type.
+ */
+
+static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
+ Tcl_Obj *copyPtr));
+static void FreeCmdNameInternalRep _ANSI_ARGS_((
+ Tcl_Obj *objPtr));
+static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+
/*
* The structures below defines the Tcl object types defined in this file by
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
+
+#ifndef TCL_WIDE_INT_IS_LONG
+Tcl_ObjType tclWideIntType = {
+ "wideInt", /* name */
+ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
+ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
+ UpdateStringOfWideInt, /* updateStringProc */
+ SetWideIntFromAny /* setFromAnyProc */
+};
+#endif
+
+/*
+ * The structure below defines the Tcl obj hash key type.
+ */
+Tcl_HashKeyType tclObjHashKeyType = {
+ TCL_HASH_KEY_TYPE_VERSION, /* version */
+ 0, /* flags */
+ HashObjKey, /* hashKeyProc */
+ CompareObjKeys, /* compareKeysProc */
+ AllocObjEntry, /* allocEntryProc */
+ FreeObjEntry /* freeEntryProc */
+};
+
+/*
+ * The structure below defines the command name Tcl object type by means of
+ * procedures that can be invoked by generic object code. Objects of this
+ * type cache the Command pointer that results from looking up command names
+ * in the command hashtable. Such objects appear as the zeroth ("command
+ * name") argument in a Tcl command.
+ */
+
+static Tcl_ObjType tclCmdNameType = {
+ "cmdName", /* name */
+ FreeCmdNameInternalRep, /* freeIntRepProc */
+ DupCmdNameInternalRep, /* dupIntRepProc */
+ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
+ SetCmdNameFromAny /* setFromAnyProc */
+};
+
+
+/*
+ * Structure containing a cached pointer to a command that is the result
+ * of resolving the command's name in some namespace. It is the internal
+ * representation for a cmdName object. It contains the pointer along
+ * with some information that is used to check the pointer's validity.
+ */
+
+typedef struct ResolvedCmdName {
+ Command *cmdPtr; /* A cached Command pointer. */
+ Namespace *refNsPtr; /* Points to the namespace containing the
+ * reference (not the namespace that
+ * contains the referenced command). */
+ long refNsId; /* refNsPtr's unique namespace id. Used to
+ * verify that refNsPtr is still valid
+ * (e.g., it's possible that the cmd's
+ * containing namespace was deleted and a
+ * new one created at the same address). */
+ int refNsCmdEpoch; /* Value of the referencing namespace's
+ * cmdRefEpoch when the pointer was cached.
+ * Before using the cached pointer, we check
+ * if the namespace's epoch was incremented;
+ * if so, this cached pointer is invalid. */
+ int cmdEpoch; /* Value of the command's cmdEpoch when this
+ * pointer was cached. Before using the
+ * cached pointer, we check if the cmd's
+ * epoch was incremented; if so, the cmd was
+ * renamed, deleted, hidden, or exposed, and
+ * so the pointer is invalid. */
+ int refCount; /* Reference count: 1 for each cmdName
+ * object that has a pointer to this
+ * ResolvedCmdName structure as its internal
+ * rep. This structure can be freed when
+ * refCount becomes zero. */
+} ResolvedCmdName;
+
\f
/*
*-------------------------------------------------------------------------
Tcl_RegisterObjType(&tclBooleanType);
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
+ Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_RegisterObjType(&tclWideIntType);
+#endif
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclProcBodyType);
+ Tcl_RegisterObjType(&tclArraySearchType);
+ Tcl_RegisterObjType(&tclIndexType);
+ Tcl_RegisterObjType(&tclNsNameType);
+ Tcl_RegisterObjType(&tclCmdNameType);
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
tclObjsFreed = 0;
+ {
+ int i;
+ for (i = 0; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
+ tclObjsShared[i] = 0;
+ }
+ }
Tcl_MutexUnlock(&tclObjMutex);
#endif
}
Tcl_ObjType *
Tcl_GetObjType(typeName)
- char *typeName; /* Name of Tcl object type to look up. */
+ CONST char *typeName; /* Name of Tcl object type to look up. */
{
register Tcl_HashEntry *hPtr;
Tcl_ObjType *typePtr;
register Tcl_Obj *objPtr;
/*
- * Allocate the object using the list of free Tcl_Obj structs
- * we maintain.
+ * Use the macro defined in tclInt.h - it will use the
+ * correct allocator.
*/
- Tcl_MutexLock(&tclObjMutex);
- if (tclFreeObjList == NULL) {
- TclAllocateFreeObjects();
- }
- objPtr = tclFreeObjList;
- tclFreeObjList = (Tcl_Obj *) tclFreeObjList->internalRep.otherValuePtr;
-
- objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
- objPtr->typePtr = NULL;
-#ifdef TCL_COMPILE_STATS
- tclObjsAlloced++;
-#endif /* TCL_COMPILE_STATS */
- Tcl_MutexUnlock(&tclObjMutex);
+ TclNewObj(objPtr);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
* empty string. It is the same as the Tcl_NewObj procedure above
* except that it calls Tcl_DbCkalloc directly with the file name and
* line number from its caller. This simplifies debugging since then
- * the checkmem command will report the correct file name and line
+ * the [memory active] command will report the correct file name and line
* number when reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
Tcl_Obj *
Tcl_DbNewObj(file, line)
- register char *file; /* The name of the source file calling this
+ register CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
register int line; /* Line number in the source file; used
* for debugging. */
register Tcl_Obj *objPtr;
/*
- * If debugging Tcl's memory usage, allocate the object using ckalloc.
- * Otherwise, allocate it using the list of free Tcl_Obj structs we
- * maintain.
+ * Use the macro defined in tclInt.h - it will use the
+ * correct allocator.
*/
- objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
- objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
- objPtr->length = 0;
- objPtr->typePtr = NULL;
-#ifdef TCL_COMPILE_STATS
- Tcl_MutexLock(&tclObjMutex);
- tclObjsAlloced++;
- Tcl_MutexUnlock(&tclObjMutex);
-#endif /* TCL_COMPILE_STATS */
+ TclDbNewObj(objPtr, file, line);
return objPtr;
}
-
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewObj(file, line)
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
void
TclAllocateFreeObjects()
{
- Tcl_Obj tmp[2];
- size_t objSizePlusPadding = /* NB: this assumes byte addressing. */
- ((int)(&(tmp[1])) - (int)(&(tmp[0])));
- size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * objSizePlusPadding);
+ size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
char *basePtr;
register Tcl_Obj *prevPtr, *objPtr;
register int i;
+ /*
+ * This has been noted by Purify to be a potential leak. The problem is
+ * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
+ * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
+ * actually freeing the memory. These never do get freed properly.
+ */
+
basePtr = (char *) ckalloc(bytesToAlloc);
memset(basePtr, 0, bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
- for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
+ for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
objPtr->internalRep.otherValuePtr = (VOID *) prevPtr;
prevPtr = objPtr;
- objPtr = (Tcl_Obj *) (((char *)objPtr) + objSizePlusPadding);
+ objPtr++;
}
tclFreeObjList = prevPtr;
}
* Tcl_Obj structs we maintain.
*/
+#if defined(TCL_MEM_DEBUG) || defined(PURIFY)
Tcl_MutexLock(&tclObjMutex);
-#ifdef TCL_MEM_DEBUG
ckfree((char *) objPtr);
-#else
+ Tcl_MutexUnlock(&tclObjMutex);
+#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+ TclThreadFreeObj(objPtr);
+#else
+ Tcl_MutexLock(&tclObjMutex);
objPtr->internalRep.otherValuePtr = (VOID *) tclFreeObjList;
tclFreeObjList = objPtr;
+ Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_MEM_DEBUG */
#ifdef TCL_COMPILE_STATS
tclObjsFreed++;
#endif /* TCL_COMPILE_STATS */
- Tcl_MutexUnlock(&tclObjMutex);
}
\f
/*
if (objPtr->bytes == NULL) {
dupPtr->bytes = NULL;
} else if (objPtr->bytes != tclEmptyStringRep) {
- int len = objPtr->length;
-
- dupPtr->bytes = (char *) ckalloc((unsigned) len+1);
- if (len > 0) {
- memcpy((VOID *) dupPtr->bytes, (VOID *) objPtr->bytes,
- (unsigned) len);
- }
- dupPtr->bytes[len] = '\0';
- dupPtr->length = len;
+ TclInitStringRep(dupPtr, objPtr->bytes, objPtr->length);
}
if (typePtr != NULL) {
char *
Tcl_GetStringFromObj(objPtr, lengthPtr)
- register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
- * should be returned. */
- register int *lengthPtr; /* If non-NULL, the location where the
- * string rep's byte array length should be
- * stored. If NULL, no length is stored. */
+ register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should
+ * be returned. */
+ register int *lengthPtr; /* If non-NULL, the location where the string
+ * rep's byte array length should * be stored.
+ * If NULL, no length is stored. */
{
- if (objPtr->bytes != NULL) {
- if (lengthPtr != NULL) {
- *lengthPtr = objPtr->length;
+ if (objPtr->bytes == NULL) {
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
}
- return objPtr->bytes;
+ (*objPtr->typePtr->updateStringProc)(objPtr);
}
- if (objPtr->typePtr->updateStringProc == NULL) {
- panic("UpdateStringProc should not be invoked for type %s",
- objPtr->typePtr->name);
- }
- (*objPtr->typePtr->updateStringProc)(objPtr);
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
* same as the Tcl_NewBooleanObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
- * caller. This simplifies debugging since then the checkmem command
- * will report the correct file name and line number when reporting
- * objects that haven't been freed.
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewBooleanObj.
Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
register int boolValue; /* Boolean used to initialize new object. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
Tcl_Obj *
Tcl_DbNewBooleanObj(boolValue, file, line)
register int boolValue; /* Boolean used to initialize new object. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
{
register int result;
- result = SetBooleanFromAny(interp, objPtr);
+ if (objPtr->typePtr == &tclBooleanType) {
+ result = TCL_OK;
+ } else {
+ result = SetBooleanFromAny(interp, objPtr);
+ }
+
if (result == TCL_OK) {
*boolPtr = (int) objPtr->internalRep.longValue;
}
char lowerCase[10];
int newBool, length;
register int i;
- double dbl;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
-
+
string = Tcl_GetStringFromObj(objPtr, &length);
/*
- * Copy the string converting its characters to lower case.
+ * Use the obvious shortcuts for numerical values; if objPtr is not
+ * of numerical type, parse its string rep.
*/
-
- for (i = 0; (i < 9) && (i < length); i++) {
- c = string[i];
- /*
- * Weed out international characters so we can safely operate
- * on single bytes.
- */
-
- if (c & 0x80) {
- goto badBoolean;
- }
- if (Tcl_UniCharIsUpper(UCHAR(c))) {
- c = (char) Tcl_UniCharToLower(UCHAR(c));
- }
- lowerCase[i] = c;
- }
- lowerCase[i] = 0;
-
- /*
- * Parse the string as a boolean. We use an implementation here that
- * doesn't report errors in interp if interp is NULL.
- */
-
- c = lowerCase[0];
- if ((c == '0') && (lowerCase[1] == '\0')) {
- newBool = 0;
- } else if ((c == '1') && (lowerCase[1] == '\0')) {
- newBool = 1;
- } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
- newBool = 1;
- } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
- newBool = 0;
- } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
- newBool = 1;
- } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
- newBool = 0;
- } else if ((c == 'o') && (length >= 2)) {
- if (strncmp(lowerCase, "on", (size_t) length) == 0) {
- newBool = 1;
- } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
- newBool = 0;
- } else {
- goto badBoolean;
- }
+
+ if (objPtr->typePtr == &tclIntType) {
+ newBool = (objPtr->internalRep.longValue != 0);
+ } else if (objPtr->typePtr == &tclDoubleType) {
+ newBool = (objPtr->internalRep.doubleValue != 0.0);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (objPtr->typePtr == &tclWideIntType) {
+ newBool = (objPtr->internalRep.wideValue != Tcl_LongAsWide(0));
+#endif /* TCL_WIDE_INT_IS_LONG */
} else {
- /*
- * Still might be a string containing the characters representing an
- * int or double that wasn't handled above. This would be a string
- * like "27" or "1.0" that is non-zero and not "1". Such a string
- * whould result in the boolean value true. We try converting to
- * double. If that succeeds and the resulting double is non-zero, we
- * have a "true". Note that numbers can't have embedded NULLs.
+ /*
+ * Copy the string converting its characters to lower case.
*/
-
- dbl = strtod(string, &end);
- if (end == string) {
- goto badBoolean;
+
+ for (i = 0; (i < 9) && (i < length); i++) {
+ c = string[i];
+ /*
+ * Weed out international characters so we can safely operate
+ * on single bytes.
+ */
+
+ if (c & 0x80) {
+ goto badBoolean;
+ }
+ if (Tcl_UniCharIsUpper(UCHAR(c))) {
+ c = (char) Tcl_UniCharToLower(UCHAR(c));
+ }
+ lowerCase[i] = c;
}
-
+ lowerCase[i] = 0;
+
/*
- * Make sure the string has no garbage after the end of the double.
+ * Parse the string as a boolean. We use an implementation here that
+ * doesn't report errors in interp if interp is NULL.
*/
- while ((end < (string+length))
- && isspace(UCHAR(*end))) { /* INTL: ISO only */
- end++;
- }
- if (end != (string+length)) {
- goto badBoolean;
+ c = lowerCase[0];
+ if ((c == '0') && (lowerCase[1] == '\0')) {
+ newBool = 0;
+ } else if ((c == '1') && (lowerCase[1] == '\0')) {
+ newBool = 1;
+ } else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
+ newBool = 1;
+ } else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
+ newBool = 0;
+ } else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
+ newBool = 1;
+ } else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
+ newBool = 0;
+ } else if ((c == 'o') && (length >= 2)) {
+ if (strncmp(lowerCase, "on", (size_t) length) == 0) {
+ newBool = 1;
+ } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
+ newBool = 0;
+ } else {
+ goto badBoolean;
+ }
+ } else {
+ double dbl;
+ /*
+ * Boolean values can be extracted from ints or doubles. Note
+ * that we don't use strtoul or strtoull here because we don't
+ * care about what the value is, just whether it is equal to
+ * zero or not.
+ */
+#ifdef TCL_WIDE_INT_IS_LONG
+ newBool = strtol(string, &end, 0);
+ if (end != string) {
+ /*
+ * Make sure the string has no garbage after the end of
+ * the int.
+ */
+ while ((end < (string+length))
+ && isspace(UCHAR(*end))) { /* INTL: ISO only */
+ end++;
+ }
+ if (end == (string+length)) {
+ newBool = (newBool != 0);
+ goto goodBoolean;
+ }
+ }
+#else /* !TCL_WIDE_INT_IS_LONG */
+ Tcl_WideInt wide = strtoll(string, &end, 0);
+ if (end != string) {
+ /*
+ * Make sure the string has no garbage after the end of
+ * the wide int.
+ */
+ while ((end < (string+length))
+ && isspace(UCHAR(*end))) { /* INTL: ISO only */
+ end++;
+ }
+ if (end == (string+length)) {
+ newBool = (wide != Tcl_LongAsWide(0));
+ goto goodBoolean;
+ }
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
+ /*
+ * Still might be a string containing the characters representing an
+ * int or double that wasn't handled above. This would be a string
+ * like "27" or "1.0" that is non-zero and not "1". Such a string
+ * would result in the boolean value true. We try converting to
+ * double. If that succeeds and the resulting double is non-zero, we
+ * have a "true". Note that numbers can't have embedded NULLs.
+ */
+
+ dbl = strtod(string, &end);
+ if (end == string) {
+ goto badBoolean;
+ }
+
+ /*
+ * Make sure the string has no garbage after the end of the double.
+ */
+
+ while ((end < (string+length))
+ && isspace(UCHAR(*end))) { /* INTL: ISO only */
+ end++;
+ }
+ if (end != (string+length)) {
+ goto badBoolean;
+ }
+ newBool = (dbl != 0.0);
}
- newBool = (dbl != 0.0);
}
/*
* Tcl_GetStringFromObj, to use that old internalRep.
*/
+ goodBoolean:
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
* TCL_MEM_DEBUG is defined. It creates new double objects. It is the
* same as the Tcl_NewDoubleObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
- * caller. This simplifies debugging since then the checkmem command
- * will report the correct file name and line number when reporting
- * objects that haven't been freed.
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewDoubleObj.
Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
register double dblValue; /* Double used to initialize the object. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
Tcl_Obj *
Tcl_DbNewDoubleObj(dblValue, file, line)
register double dblValue; /* Double used to initialize the object. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
* When the core is compiled with TCL_MEM_DEBUG defined,
* Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and
* line number from its caller. This simplifies debugging since then
- * the checkmem command will report the caller's file name and line
- * number when reporting objects that haven't been freed.
+ * the [memory active] command will report the caller's file name and
+ * line number when reporting objects that haven't been freed.
*
* Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
* this procedure just returns the result of calling Tcl_NewLongObj.
Tcl_DbNewLongObj(longValue, file, line)
register long longValue; /* Long integer used to initialize the
* new object. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
Tcl_DbNewLongObj(longValue, file, line)
register long longValue; /* Long integer used to initialize the
* new object. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
/*
*----------------------------------------------------------------------
*
- * Tcl_DbIncrRefCount --
- *
- * This procedure is normally called when debugging: i.e., when
- * TCL_MEM_DEBUG is defined. This checks to see whether or not
- * the memory has been freed before incrementing the ref count.
+ * SetWideIntFromAny --
*
- * When TCL_MEM_DEBUG is not defined, this procedure just increments
- * the reference count of the object.
+ * Attempt to generate an integer internal form for the Tcl object
+ * "objPtr".
*
* Results:
- * None.
+ * The return value is a standard object Tcl result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
*
* Side effects:
- * The object's ref count is incremented.
+ * If no error occurs, an int is stored as "objPtr"s internal
+ * representation.
*
*----------------------------------------------------------------------
*/
-void
-Tcl_DbIncrRefCount(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object we are registering a
- * reference to. */
- char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+#ifndef TCL_WIDE_INT_IS_LONG
+static int
+SetWideIntFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr; /* The object to convert. */
{
-#ifdef TCL_MEM_DEBUG
- if (objPtr->refCount == 0x61616161) {
- fprintf(stderr, "file = %s, line = %d\n", file, line);
- fflush(stderr);
- panic("Trying to increment refCount of previously disposed object.");
+ Tcl_ObjType *oldTypePtr = objPtr->typePtr;
+ char *string, *end;
+ int length;
+ register char *p;
+ Tcl_WideInt newWide;
+
+ /*
+ * Get the string representation. Make it up-to-date if necessary.
+ */
+
+ string = Tcl_GetStringFromObj(objPtr, &length);
+
+ /*
+ * Now parse "objPtr"s string as an int. We use an implementation here
+ * that doesn't report errors in interp if interp is NULL. Note: use
+ * strtoull instead of strtoll for integer conversions to allow full-size
+ * unsigned numbers, but don't depend on strtoull to handle sign
+ * characters; it won't in some implementations.
+ */
+
+ errno = 0;
+ for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
+ /* Empty loop body. */
}
-#endif
- ++(objPtr)->refCount;
+ if (*p == '-') {
+ p++;
+ newWide = -((Tcl_WideInt)strtoull(p, &end, 0));
+ } else if (*p == '+') {
+ p++;
+ newWide = strtoull(p, &end, 0);
+ } else {
+ newWide = strtoull(p, &end, 0);
+ }
+ if (end == p) {
+ badInteger:
+ if (interp != NULL) {
+ /*
+ * Must copy string before resetting the result in case a caller
+ * is trying to convert the interpreter's result to an int.
+ */
+
+ char buf[100];
+ sprintf(buf, "expected integer but got \"%.50s\"", string);
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ TclCheckBadOctal(interp, string);
+ }
+ return TCL_ERROR;
+ }
+ if (errno == ERANGE) {
+ if (interp != NULL) {
+ char *s = "integer value too large to represent";
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make sure that the string has no garbage after the end of the int.
+ */
+
+ while ((end < (string+length))
+ && isspace(UCHAR(*end))) { /* INTL: ISO space. */
+ end++;
+ }
+ if (end != (string+length)) {
+ goto badInteger;
+ }
+
+ /*
+ * The conversion to int succeeded. Free the old internalRep before
+ * setting the new one. We do this as late as possible to allow the
+ * conversion code, in particular Tcl_GetStringFromObj, to use that old
+ * internalRep.
+ */
+
+ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+ oldTypePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->internalRep.wideValue = newWide;
+ objPtr->typePtr = &tclWideIntType;
+ return TCL_OK;
}
+#endif
\f
/*
*----------------------------------------------------------------------
*
- * Tcl_DbDecrRefCount --
- *
- * This procedure is normally called when debugging: i.e., when
- * TCL_MEM_DEBUG is defined. This checks to see whether or not
- * the memory has been freed before decrementing the ref count.
+ * UpdateStringOfWideInt --
*
- * When TCL_MEM_DEBUG is not defined, this procedure just decrements
- * the reference count of the object.
+ * Update the string representation for a wide integer object.
+ * Note: This procedure does not free an existing old string rep
+ * so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
- * The object's ref count is incremented.
+ * The object's string is set to a valid string that results from
+ * the wideInt-to-string conversion.
*
*----------------------------------------------------------------------
*/
-void
-Tcl_DbDecrRefCount(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object we are releasing a reference
- * to. */
- char *file; /* The name of the source file calling this
- * procedure; used for debugging. */
- int line; /* Line number in the source file; used
- * for debugging. */
+#ifndef TCL_WIDE_INT_IS_LONG
+static void
+UpdateStringOfWideInt(objPtr)
+ register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
{
-#ifdef TCL_MEM_DEBUG
- if (objPtr->refCount == 0x61616161) {
- fprintf(stderr, "file = %s, line = %d\n", file, line);
+ char buffer[TCL_INTEGER_SPACE+2];
+ register unsigned len;
+ register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
+
+ sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
+ len = strlen(buffer);
+ objPtr->bytes = ckalloc((unsigned) len + 1);
+ memcpy(objPtr->bytes, buffer, len + 1);
+ objPtr->length = len;
+}
+#endif /* TCL_WIDE_INT_IS_LONG */
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NewWideIntObj --
+ *
+ * If a client is compiled with TCL_MEM_DEBUG defined, calls to
+ * Tcl_NewWideIntObj to create a new 64-bit integer object end up calling
+ * the debugging procedure Tcl_DbNewWideIntObj instead.
+ *
+ * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
+ * calls to Tcl_NewWideIntObj result in a call to one of the two
+ * Tcl_NewWideIntObj implementations below. We provide two implementations
+ * so that the Tcl core can be compiled to do memory debugging of the
+ * core even if a client does not request it for itself.
+ *
+ * Results:
+ * The newly created object is returned. This object will have an
+ * invalid string representation. The returned object has ref count 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+#undef Tcl_NewWideIntObj
+
+Tcl_Obj *
+Tcl_NewWideIntObj(wideValue)
+ register Tcl_WideInt wideValue; /* Wide integer used to initialize
+ * the new object. */
+{
+ return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
+}
+
+#else /* if not TCL_MEM_DEBUG */
+
+Tcl_Obj *
+Tcl_NewWideIntObj(wideValue)
+ register Tcl_WideInt wideValue; /* Wide integer used to initialize
+ * the new object. */
+{
+#ifdef TCL_WIDE_INT_IS_LONG
+ return Tcl_NewLongObj(wideValue);
+#else
+ register Tcl_Obj *objPtr;
+
+ TclNewObj(objPtr);
+ objPtr->bytes = NULL;
+
+ objPtr->internalRep.wideValue = wideValue;
+ objPtr->typePtr = &tclWideIntType;
+ return objPtr;
+#endif /* TCL_WIDE_INT_IS_LONG */
+}
+#endif /* if TCL_MEM_DEBUG */
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbNewWideIntObj --
+ *
+ * If a client is compiled with TCL_MEM_DEBUG defined, calls to
+ * Tcl_NewWideIntObj to create new wide integer end up calling
+ * the debugging procedure Tcl_DbNewWideIntObj instead. We
+ * provide two implementations of Tcl_DbNewWideIntObj so that
+ * whether the Tcl core is compiled to do memory debugging of the
+ * core is independent of whether a client requests debugging for
+ * itself.
+ *
+ * When the core is compiled with TCL_MEM_DEBUG defined,
+ * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file
+ * name and line number from its caller. This simplifies
+ * debugging since then the checkmem command will report the
+ * caller's file name and line number when reporting objects that
+ * haven't been freed.
+ *
+ * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined,
+ * this procedure just returns the result of calling Tcl_NewWideIntObj.
+ *
+ * Results:
+ * The newly created wide integer object is returned. This object
+ * will have an invalid string representation. The returned object has
+ * ref count 0.
+ *
+ * Side effects:
+ * Allocates memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_MEM_DEBUG
+
+Tcl_Obj *
+Tcl_DbNewWideIntObj(wideValue, file, line)
+ register Tcl_WideInt wideValue; /* Wide integer used to initialize
+ * the new object. */
+ CONST char *file; /* The name of the source file
+ * calling this procedure; used for
+ * debugging. */
+ int line; /* Line number in the source file;
+ * used for debugging. */
+{
+#ifdef TCL_WIDE_INT_IS_LONG
+ return Tcl_DbNewLongObj(wideValue, file, line);
+#else
+ register Tcl_Obj *objPtr;
+
+ TclDbNewObj(objPtr, file, line);
+ objPtr->bytes = NULL;
+
+ objPtr->internalRep.wideValue = wideValue;
+ objPtr->typePtr = &tclWideIntType;
+ return objPtr;
+#endif
+}
+
+#else /* if not TCL_MEM_DEBUG */
+
+Tcl_Obj *
+Tcl_DbNewWideIntObj(wideValue, file, line)
+ register Tcl_WideInt wideValue; /* Long integer used to initialize
+ * the new object. */
+ CONST char *file; /* The name of the source file
+ * calling this procedure; used for
+ * debugging. */
+ int line; /* Line number in the source file;
+ * used for debugging. */
+{
+ return Tcl_NewWideIntObj(wideValue);
+}
+#endif /* TCL_MEM_DEBUG */
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetWideIntObj --
+ *
+ * Modify an object to be a wide integer object and to have the
+ * specified wide integer value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's old string rep, if any, is freed. Also, any old
+ * internal rep is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetWideIntObj(objPtr, wideValue)
+ register Tcl_Obj *objPtr; /* Object w. internal rep to init. */
+ register Tcl_WideInt wideValue; /* Wide integer used to initialize
+ * the object's value. */
+{
+#ifdef TCL_WIDE_INT_IS_LONG
+ Tcl_SetLongObj(objPtr, wideValue);
+#else
+ register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
+
+ if (Tcl_IsShared(objPtr)) {
+ panic("Tcl_SetWideIntObj called with shared object");
+ }
+
+ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+ oldTypePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->internalRep.wideValue = wideValue;
+ objPtr->typePtr = &tclWideIntType;
+ Tcl_InvalidateStringRep(objPtr);
+#endif
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetWideIntFromObj --
+ *
+ * Attempt to return a wide integer from the Tcl object "objPtr". If
+ * the object is not already a wide int object, an attempt will be made
+ * to convert it to one.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already an int object, the conversion will free
+ * any old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr; /* Object from which to get a wide int. */
+ register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
+{
+#ifdef TCL_WIDE_INT_IS_LONG
+ /*
+ * Next line is type-safe because we only do this when long = Tcl_WideInt
+ */
+ return Tcl_GetLongFromObj(interp, objPtr, wideIntPtr);
+#else
+ register int result;
+
+ if (objPtr->typePtr == &tclWideIntType) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+ result = SetWideIntFromAny(interp, objPtr);
+ if (result == TCL_OK) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ }
+ return result;
+#endif
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbIncrRefCount --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before incrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just increments
+ * the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbIncrRefCount(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are registering a
+ * reference to. */
+ CONST char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
+ fflush(stderr);
+ panic("Trying to increment refCount of previously disposed object.");
+ }
+#endif
+ ++(objPtr)->refCount;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbDecrRefCount --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before decrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just decrements
+ * the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbDecrRefCount(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are releasing a reference
+ * to. */
+ CONST char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
panic("Trying to decrement refCount of previously disposed object.");
}
int
Tcl_DbIsShared(objPtr, file, line)
register Tcl_Obj *objPtr; /* The object to test for being shared. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
panic("Trying to check whether previously disposed object is shared.");
}
#endif
+#ifdef TCL_COMPILE_STATS
+ Tcl_MutexLock(&tclObjMutex);
+ if ((objPtr)->refCount <= 1) {
+ tclObjsShared[1]++;
+ } else if ((objPtr)->refCount < TCL_MAX_SHARED_OBJ_STATS) {
+ tclObjsShared[(objPtr)->refCount]++;
+ } else {
+ tclObjsShared[0]++;
+ }
+ Tcl_MutexUnlock(&tclObjMutex);
+#endif
return ((objPtr)->refCount > 1);
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitObjHashTable --
+ *
+ * Given storage for a hash table, set up the fields to prepare
+ * the hash table for use, the keys are Tcl_Obj *.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * TablePtr is now ready to be passed to Tcl_FindHashEntry and
+ * Tcl_CreateHashEntry.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_InitObjHashTable(tablePtr)
+ register Tcl_HashTable *tablePtr; /* Pointer to table record, which
+ * is supplied by the caller. */
+{
+ Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
+ &tclObjHashKeyType);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * AllocObjEntry --
+ *
+ * Allocate space for a Tcl_HashEntry containing the Tcl_Obj * key.
+ *
+ * Results:
+ * The return value is a pointer to the created entry.
+ *
+ * Side effects:
+ * Increments the reference count on the object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashEntry *
+AllocObjEntry(tablePtr, keyPtr)
+ Tcl_HashTable *tablePtr; /* Hash table. */
+ VOID *keyPtr; /* Key to store in the hash table entry. */
+{
+ Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
+ Tcl_HashEntry *hPtr;
+
+ hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
+ hPtr->key.oneWordValue = (char *) objPtr;
+ Tcl_IncrRefCount (objPtr);
+
+ return hPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompareObjKeys --
+ *
+ * Compares two Tcl_Obj * keys.
+ *
+ * Results:
+ * The return value is 0 if they are different and 1 if they are
+ * the same.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompareObjKeys(keyPtr, hPtr)
+ VOID *keyPtr; /* New key to compare. */
+ Tcl_HashEntry *hPtr; /* Existing key to compare. */
+{
+ Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr;
+ Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
+ register CONST char *p1, *p2;
+ register int l1, l2;
+
+ /*
+ * If the object pointers are the same then they match.
+ */
+ if (objPtr1 == objPtr2) {
+ return 1;
+ }
+
+ /*
+ * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
+ * in a register.
+ */
+ p1 = Tcl_GetString (objPtr1);
+ l1 = objPtr1->length;
+ p2 = Tcl_GetString (objPtr2);
+ l2 = objPtr2->length;
+
+ /*
+ * Only compare if the string representations are of the same length.
+ */
+ if (l1 == l2) {
+ for (;; p1++, p2++, l1--) {
+ if (*p1 != *p2) {
+ break;
+ }
+ if (l1 == 0) {
+ return 1;
+ }
+ }
+ }
+
+ return 0;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeObjEntry --
+ *
+ * Frees space for a Tcl_HashEntry containing the Tcl_Obj * key.
+ *
+ * Results:
+ * The return value is a pointer to the created entry.
+ *
+ * Side effects:
+ * Decrements the reference count of the object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeObjEntry(hPtr)
+ Tcl_HashEntry *hPtr; /* Hash entry to free. */
+{
+ Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
+
+ Tcl_DecrRefCount (objPtr);
+ ckfree ((char *) hPtr);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * HashObjKey --
+ *
+ * Compute a one-word summary of the string representation of the
+ * Tcl_Obj, which can be used to generate a hash index.
+ *
+ * Results:
+ * The return value is a one-word summary of the information in
+ * the string representation of the Tcl_Obj.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned int
+HashObjKey(tablePtr, keyPtr)
+ Tcl_HashTable *tablePtr; /* Hash table. */
+ VOID *keyPtr; /* Key from which to compute hash value. */
+{
+ Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
+ register CONST char *string;
+ register int length;
+ register unsigned int result;
+ register int c;
+
+ string = Tcl_GetString (objPtr);
+ length = objPtr->length;
+
+ /*
+ * I tried a zillion different hash functions and asked many other
+ * people for advice. Many people had their own favorite functions,
+ * all different, but no-one had much idea why they were good ones.
+ * I chose the one below (multiply by 9 and add new character)
+ * because of the following reasons:
+ *
+ * 1. Multiplying by 10 is perfect for keys that are decimal strings,
+ * and multiplying by 9 is just about as good.
+ * 2. Times-9 is (shift-left-3) plus (old). This means that each
+ * character's bits hang around in the low-order bits of the
+ * hash value for ever, plus they spread fairly rapidly up to
+ * the high-order bits to fill out the hash value. This seems
+ * works well both for decimal and non-decimal strings.
+ */
+
+ result = 0;
+ while (length) {
+ c = *string;
+ string++;
+ length--;
+ if (length == 0) {
+ break;
+ }
+ result += (result<<3) + c;
+ }
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetCommandFromObj --
+ *
+ * Returns the command specified by the name in a Tcl_Obj.
+ *
+ * Results:
+ * Returns a token for the command if it is found. Otherwise, if it
+ * can't be found or there is an error, returns NULL.
+ *
+ * Side effects:
+ * May update the internal representation for the object, caching
+ * the command reference so that the next time this procedure is
+ * called with the same object, the command can be found quickly.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+Tcl_GetCommandFromObj(interp, objPtr)
+ Tcl_Interp *interp; /* The interpreter in which to resolve the
+ * command and to report errors. */
+ register Tcl_Obj *objPtr; /* The object containing the command's
+ * name. If the name starts with "::", will
+ * be looked up in global namespace. Else,
+ * looked up first in the current namespace,
+ * then in global namespace. */
+{
+ Interp *iPtr = (Interp *) interp;
+ register ResolvedCmdName *resPtr;
+ register Command *cmdPtr;
+ Namespace *currNsPtr;
+ int result;
+ CallFrame *savedFramePtr;
+ char *name;
+
+ /*
+ * If the variable name is fully qualified, do as if the lookup were
+ * done from the global namespace; this helps avoid repeated lookups
+ * of fully qualified names. It costs close to nothing, and may be very
+ * helpful for OO applications which pass along a command name ("this"),
+ * [Patch 456668]
+ */
+
+ savedFramePtr = iPtr->varFramePtr;
+ name = Tcl_GetString(objPtr);
+ if ((*name++ == ':') && (*name == ':')) {
+ iPtr->varFramePtr = NULL;
+ }
+
+ /*
+ * Get the internal representation, converting to a command type if
+ * needed. The internal representation is a ResolvedCmdName that points
+ * to the actual command.
+ */
+
+ if (objPtr->typePtr != &tclCmdNameType) {
+ result = tclCmdNameType.setFromAnyProc(interp, objPtr);
+ if (result != TCL_OK) {
+ iPtr->varFramePtr = savedFramePtr;
+ return (Tcl_Command) NULL;
+ }
+ }
+ resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+
+ /*
+ * Get the current namespace.
+ */
+
+ if (iPtr->varFramePtr != NULL) {
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ currNsPtr = iPtr->globalNsPtr;
+ }
+
+ /*
+ * Check the context namespace and the namespace epoch of the resolved
+ * symbol to make sure that it is fresh. If not, then force another
+ * conversion to the command type, to discard the old rep and create a
+ * new one. Note that we verify that the namespace id of the context
+ * namespace is the same as the one we cached; this insures that the
+ * namespace wasn't deleted and a new one created at the same address
+ * with the same command epoch.
+ */
+
+ cmdPtr = NULL;
+ if ((resPtr != NULL)
+ && (resPtr->refNsPtr == currNsPtr)
+ && (resPtr->refNsId == currNsPtr->nsId)
+ && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
+ cmdPtr = resPtr->cmdPtr;
+ if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
+ cmdPtr = NULL;
+ }
+ }
+
+ if (cmdPtr == NULL) {
+ result = tclCmdNameType.setFromAnyProc(interp, objPtr);
+ if (result != TCL_OK) {
+ iPtr->varFramePtr = savedFramePtr;
+ return (Tcl_Command) NULL;
+ }
+ resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+ if (resPtr != NULL) {
+ cmdPtr = resPtr->cmdPtr;
+ }
+ }
+ iPtr->varFramePtr = savedFramePtr;
+ return (Tcl_Command) cmdPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetCmdNameObj --
+ *
+ * Modify an object to be an CmdName object that refers to the argument
+ * Command structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's old internal rep is freed. It's string rep is not
+ * changed. The refcount in the Command structure is incremented to
+ * keep it from being freed if the command is later deleted until
+ * TclExecuteByteCode has a chance to recognize that it was deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetCmdNameObj(interp, objPtr, cmdPtr)
+ Tcl_Interp *interp; /* Points to interpreter containing command
+ * that should be cached in objPtr. */
+ register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
+ * a CmdName object. */
+ Command *cmdPtr; /* Points to Command structure that the
+ * CmdName object should refer to. */
+{
+ Interp *iPtr = (Interp *) interp;
+ register ResolvedCmdName *resPtr;
+ Tcl_ObjType *oldTypePtr = objPtr->typePtr;
+ register Namespace *currNsPtr;
+
+ if (oldTypePtr == &tclCmdNameType) {
+ return;
+ }
+
+ /*
+ * Get the current namespace.
+ */
+
+ if (iPtr->varFramePtr != NULL) {
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ currNsPtr = iPtr->globalNsPtr;
+ }
+
+ cmdPtr->refCount++;
+ resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr->cmdPtr = cmdPtr;
+ resPtr->refNsPtr = currNsPtr;
+ resPtr->refNsId = currNsPtr->nsId;
+ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ resPtr->cmdEpoch = cmdPtr->cmdEpoch;
+ resPtr->refCount = 1;
+
+ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+ oldTypePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeCmdNameInternalRep --
+ *
+ * Frees the resources associated with a cmdName object's internal
+ * representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Decrements the ref count of any cached ResolvedCmdName structure
+ * pointed to by the cmdName's internal representation. If this is
+ * the last use of the ResolvedCmdName, it is freed. This in turn
+ * decrements the ref count of the Command structure pointed to by
+ * the ResolvedSymbol, which may free the Command structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeCmdNameInternalRep(objPtr)
+ register Tcl_Obj *objPtr; /* CmdName object with internal
+ * representation to free. */
+{
+ register ResolvedCmdName *resPtr =
+ (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+
+ if (resPtr != NULL) {
+ /*
+ * Decrement the reference count of the ResolvedCmdName structure.
+ * If there are no more uses, free the ResolvedCmdName structure.
+ */
+
+ resPtr->refCount--;
+ if (resPtr->refCount == 0) {
+ /*
+ * Now free the cached command, unless it is still in its
+ * hash table or if there are other references to it
+ * from other cmdName objects.
+ */
+
+ Command *cmdPtr = resPtr->cmdPtr;
+ TclCleanupCommand(cmdPtr);
+ ckfree((char *) resPtr);
+ }
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupCmdNameInternalRep --
+ *
+ * Initialize the internal representation of an cmdName Tcl_Obj to a
+ * copy of the internal representation of an existing cmdName object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * "copyPtr"s internal rep is set to point to the ResolvedCmdName
+ * structure corresponding to "srcPtr"s internal rep. Increments the
+ * ref count of the ResolvedCmdName structure pointed to by the
+ * cmdName's internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupCmdNameInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
+ register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+{
+ register ResolvedCmdName *resPtr =
+ (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
+
+ copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ if (resPtr != NULL) {
+ resPtr->refCount++;
+ }
+ copyPtr->typePtr = &tclCmdNameType;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetCmdNameFromAny --
+ *
+ * Generate an cmdName internal form for the Tcl object "objPtr".
+ *
+ * Results:
+ * The return value is a standard Tcl result. The conversion always
+ * succeeds and TCL_OK is returned.
+ *
+ * Side effects:
+ * A pointer to a ResolvedCmdName structure that holds a cached pointer
+ * to the command with a name that matches objPtr's string rep is
+ * stored as objPtr's internal representation. This ResolvedCmdName
+ * pointer will be NULL if no matching command was found. The ref count
+ * of the cached Command's structure (if any) is also incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetCmdNameFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ register Tcl_Obj *objPtr; /* The object to convert. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *name;
+ Tcl_Command cmd;
+ register Command *cmdPtr;
+ Namespace *currNsPtr;
+ register ResolvedCmdName *resPtr;
+
+ /*
+ * Get "objPtr"s string representation. Make it up-to-date if necessary.
+ */
+
+ name = objPtr->bytes;
+ if (name == NULL) {
+ name = Tcl_GetString(objPtr);
+ }
+
+ /*
+ * Find the Command structure, if any, that describes the command called
+ * "name". Build a ResolvedCmdName that holds a cached pointer to this
+ * Command, and bump the reference count in the referenced Command
+ * structure. A Command structure will not be deleted as long as it is
+ * referenced from a CmdName object.
+ */
+
+ cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
+ /*flags*/ 0);
+ cmdPtr = (Command *) cmd;
+ if (cmdPtr != NULL) {
+ /*
+ * Get the current namespace.
+ */
+
+ if (iPtr->varFramePtr != NULL) {
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ currNsPtr = iPtr->globalNsPtr;
+ }
+
+ cmdPtr->refCount++;
+ resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr->cmdPtr = cmdPtr;
+ resPtr->refNsPtr = currNsPtr;
+ resPtr->refNsId = currNsPtr->nsId;
+ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ resPtr->cmdEpoch = cmdPtr->cmdEpoch;
+ resPtr->refCount = 1;
+ } else {
+ resPtr = NULL; /* no command named "name" was found */
+ }
+
+ /*
+ * Free the old internalRep before setting the new one. We do this as
+ * late as possible to allow the conversion code, in particular
+ * GetStringFromObj, to use that old internalRep. If no Command
+ * structure was found, leave NULL as the cached value.
+ */
+
+ if ((objPtr->typePtr != NULL)
+ && (objPtr->typePtr->freeIntRepProc != NULL)) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
+ return TCL_OK;
+}
* tclPanic.c --
*
* Source code for the "Tcl_Panic" library procedure for Tcl;
- * individual applications will probably override this with
- * an application-specific panic procedure.
+ * individual applications will probably call Tcl_SetPanicProc()
+ * to set an application-specific panic procedure.
*
* Copyright (c) 1988-1993 The Regents of the University of California.
* Copyright (c) 1994 Sun Microsystems, Inc.
*/
#include "tclInt.h"
+#include "tclPort.h"
/*
* The panicProc variable contains a pointer to an application
* specific panic procedure.
*/
-void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL;
+static Tcl_PanicProc *panicProc = NULL;
+
+/*
+ * The platformPanicProc variable contains a pointer to a platform
+ * specific panic procedure, if any. ( TclpPanic may be NULL via
+ * a macro. )
+ */
+
+static Tcl_PanicProc * CONST platformPanicProc = TclpPanic;
+
\f
/*
*----------------------------------------------------------------------
void
Tcl_SetPanicProc(proc)
- void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format));
+ Tcl_PanicProc *proc;
{
panicProc = proc;
}
void
Tcl_PanicVA (format, argList)
- char *format; /* Format string, suitable for passing to
+ CONST char *format; /* Format string, suitable for passing to
* fprintf. */
va_list argList; /* Variable argument list. */
{
if (panicProc != NULL) {
(void) (*panicProc)(format, arg1, arg2, arg3, arg4,
arg5, arg6, arg7, arg8);
+ } else if (platformPanicProc != NULL) {
+ (void) (*platformPanicProc)(format, arg1, arg2, arg3, arg4,
+ arg5, arg6, arg7, arg8);
} else {
(void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6,
arg7, arg8);
/*
*----------------------------------------------------------------------
*
- * panic --
+ * Tcl_Panic --
*
* Print an error message and kill the process.
*
/* VARARGS ARGSUSED */
void
-panic TCL_VARARGS_DEF(char *,arg1)
+Tcl_Panic TCL_VARARGS_DEF(CONST char *,arg1)
{
va_list argList;
- char *format;
+ CONST char *format;
- format = TCL_VARARGS_START(char *,arg1,argList);
+ format = TCL_VARARGS_START(CONST char *,arg1,argList);
Tcl_PanicVA(format, argList);
va_end (argList);
}
* This file contains procedures that parse Tcl scripts. They
* do so in a general-purpose fashion that can be used for many
* different purposes, including compilation, direct execution,
- * code analysis, etc. This file also includes a few additional
- * procedures such as Tcl_EvalObjv, Tcl_Eval, and Tcl_EvalEx, which
- * allow scripts to be evaluated directly, without compiling.
+ * code analysis, etc.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
- * Copyright (c) 1998 by Scriptics Corporation.
+ * Copyright (c) 1998-2000 Ajuba Solutions.
+ * Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* information about its character argument. The following return
* values are defined.
*
- * TYPE_NORMAL - All characters that don't have special significance
- * to the Tcl parser.
- * TYPE_SPACE - The character is a whitespace character other
- * than newline.
- * TYPE_COMMAND_END - Character is newline or semicolon.
- * TYPE_SUBS - Character begins a substitution or has other
- * special meaning in ParseTokens: backslash, dollar
- * sign, open bracket, or null.
- * TYPE_QUOTE - Character is a double quote.
- * TYPE_CLOSE_PAREN - Character is a right parenthesis.
- * TYPE_CLOSE_BRACK - Character is a right square bracket.
- * TYPE_BRACE - Character is a curly brace (either left or right).
+ * TYPE_NORMAL - All characters that don't have special significance
+ * to the Tcl parser.
+ * TYPE_SPACE - The character is a whitespace character other
+ * than newline.
+ * TYPE_COMMAND_END - Character is newline or semicolon.
+ * TYPE_SUBS - Character begins a substitution or has other
+ * special meaning in ParseTokens: backslash, dollar
+ * sign, or open bracket.
+ * TYPE_QUOTE - Character is a double quote.
+ * TYPE_CLOSE_PAREN - Character is a right parenthesis.
+ * TYPE_CLOSE_BRACK - Character is a right square bracket.
+ * TYPE_BRACE - Character is a curly brace (either left or right).
*/
-#define TYPE_NORMAL 0
-#define TYPE_SPACE 0x1
-#define TYPE_COMMAND_END 0x2
-#define TYPE_SUBS 0x4
-#define TYPE_QUOTE 0x8
-#define TYPE_CLOSE_PAREN 0x10
-#define TYPE_CLOSE_BRACK 0x20
-#define TYPE_BRACE 0x40
+#define TYPE_NORMAL 0
+#define TYPE_SPACE 0x1
+#define TYPE_COMMAND_END 0x2
+#define TYPE_SUBS 0x4
+#define TYPE_QUOTE 0x8
+#define TYPE_CLOSE_PAREN 0x10
+#define TYPE_CLOSE_BRACK 0x20
+#define TYPE_BRACE 0x40
-#define CHAR_TYPE(c) (typeTable+128)[(int)(c)]
+#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]
-char typeTable[] = {
+static CONST char charTypeTable[] = {
/*
* Negative character values, from -128 to -1:
*/
* Prototypes for local procedures defined in this file:
*/
-static int CommandComplete _ANSI_ARGS_((char *script,
- int length));
-static int ParseTokens _ANSI_ARGS_((char *src, int mask,
+static int CommandComplete _ANSI_ARGS_((CONST char *script,
+ int numBytes));
+static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_Parse *parsePtr));
-static int EvalObjv _ANSI_ARGS_((Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[], char *command, int length,
- int flags));
-\f
+static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
+ int mask, Tcl_Parse *parsePtr));
+
/*
*----------------------------------------------------------------------
*
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
- char *string; /* First character of string containing
- * one or more Tcl commands. The string
- * must be in writable memory and must
- * have one additional byte of space at
- * string[length] where we can
- * temporarily store a 0 sentinel
- * character. */
- int numBytes; /* Total number of bytes in string. If < 0,
+ CONST char *string; /* First character of string containing
+ * one or more Tcl commands. */
+ register int numBytes; /* Total number of bytes in string. If < 0,
* the script consists of all bytes up to
* the first null character. */
int nested; /* Non-zero means this is a nested command:
* information in the structure is
* ignored. */
{
- register char *src; /* Points to current character
+ register CONST char *src; /* Points to current character
* in the command. */
- int type; /* Result returned by CHAR_TYPE(*src). */
+ char type; /* Result returned by CHAR_TYPE(*src). */
Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
int wordIndex; /* Index of word token for current word. */
- char utfBytes[TCL_UTF_MAX]; /* Holds result of backslash substitution. */
int terminators; /* CHAR_TYPE bits that indicate the end
* of a command. */
- char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
+ CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
- int length, savedChar;
-
-
+ int scanned;
+
+ if ((string == NULL) && (numBytes>0)) {
+ if (interp != NULL) {
+ Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
+ }
+ return TCL_ERROR;
+ }
if (numBytes < 0) {
- numBytes = (string? strlen(string) : 0);
+ numBytes = strlen(string);
}
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
}
/*
- * Temporarily overwrite the character just after the end of the
- * string with a 0 byte. This acts as a sentinel and reduces the
- * number of places where we have to check for the end of the
- * input string. The original value of the byte is restored at
- * the end of the parse.
- */
-
- savedChar = string[numBytes];
- if (savedChar != 0) {
- string[numBytes] = 0;
- }
-
- /*
* Parse any leading space and comments before the first word of the
* command.
*/
- src = string;
- while (1) {
- while ((CHAR_TYPE(*src) == TYPE_SPACE) || (*src == '\n')) {
- src++;
- }
- if ((*src == '\\') && (src[1] == '\n')) {
- /*
- * Skip backslash-newline sequence: it should be treated
- * just like white space.
- */
-
- if ((src + 2) == parsePtr->end) {
- parsePtr->incomplete = 1;
- }
- src += 2;
- continue;
- }
- if (*src != '#') {
- break;
- }
- if (parsePtr->commentStart == NULL) {
- parsePtr->commentStart = src;
- }
- while (1) {
- if (src == parsePtr->end) {
- if (nested) {
- parsePtr->incomplete = nested;
- }
- parsePtr->commentSize = src - parsePtr->commentStart;
- break;
- } else if (*src == '\\') {
- if ((src[1] == '\n') && ((src + 2) == parsePtr->end)) {
- parsePtr->incomplete = 1;
- }
- Tcl_UtfBackslash(src, &length, utfBytes);
- src += length;
- } else if (*src == '\n') {
- src++;
- parsePtr->commentSize = src - parsePtr->commentStart;
- break;
- } else {
- src++;
- }
+ scanned = ParseComment(string, numBytes, parsePtr);
+ src = (string + scanned); numBytes -= scanned;
+ if (numBytes == 0) {
+ if (nested) {
+ parsePtr->incomplete = nested;
}
}
* sequence: it should be treated just like white space.
*/
- while (1) {
- type = CHAR_TYPE(*src);
- if (type == TYPE_SPACE) {
- src++;
- continue;
- } else if ((*src == '\\') && (src[1] == '\n')) {
- if ((src + 2) == parsePtr->end) {
- parsePtr->incomplete = 1;
- }
- Tcl_UtfBackslash(src, &length, utfBytes);
- src += length;
- continue;
- }
+ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
+ src += scanned; numBytes -= scanned;
+ if (numBytes == 0) {
break;
}
if ((type & terminators) != 0) {
src++;
break;
}
- if (src == parsePtr->end) {
- break;
- }
tokenPtr->start = src;
parsePtr->numTokens++;
parsePtr->numWords++;
*/
if (*src == '"') {
- if (Tcl_ParseQuotedString(interp, src, (parsePtr->end - src),
- parsePtr, 1, &termPtr) != TCL_OK) {
+ if (Tcl_ParseQuotedString(interp, src, numBytes,
+ parsePtr, 1, &termPtr) != TCL_OK) {
goto error;
}
- src = termPtr;
+ src = termPtr; numBytes = parsePtr->end - src;
} else if (*src == '{') {
- if (Tcl_ParseBraces(interp, src, (parsePtr->end - src),
- parsePtr, 1, &termPtr) != TCL_OK) {
+ if (Tcl_ParseBraces(interp, src, numBytes,
+ parsePtr, 1, &termPtr) != TCL_OK) {
goto error;
}
- src = termPtr;
+ src = termPtr; numBytes = parsePtr->end - src;
} else {
/*
* This is an unquoted word. Call ParseTokens and let it do
* all of the work.
*/
- if (ParseTokens(src, TYPE_SPACE|terminators,
+ if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
parsePtr) != TCL_OK) {
goto error;
}
- src = parsePtr->term;
+ src = parsePtr->term; numBytes = parsePtr->end - src;
}
/*
* command.
*/
- type = CHAR_TYPE(*src);
- if (type == TYPE_SPACE) {
- src++;
+ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
+ if (scanned) {
+ src += scanned; numBytes -= scanned;
continue;
- } else {
- /*
- * Backslash-newline (and any following white space) must be
- * treated as if it were a space character.
- */
-
- if ((*src == '\\') && (src[1] == '\n')) {
- if ((src + 2) == parsePtr->end) {
- parsePtr->incomplete = 1;
- }
- Tcl_UtfBackslash(src, &length, utfBytes);
- src += length;
- continue;
- }
}
- if ((type & terminators) != 0) {
- parsePtr->term = src;
- src++;
+ if (numBytes == 0) {
break;
}
- if (src == parsePtr->end) {
+ if ((type & terminators) != 0) {
+ parsePtr->term = src;
+ src++;
break;
}
if (src[-1] == '"') {
goto error;
}
-
parsePtr->commandSize = src - parsePtr->commandStart;
- if (savedChar != 0) {
- string[numBytes] = (char) savedChar;
- }
return TCL_OK;
error:
- if (savedChar != 0) {
- string[numBytes] = (char) savedChar;
- }
Tcl_FreeParse(parsePtr);
if (parsePtr->commandStart == NULL) {
parsePtr->commandStart = string;
parsePtr->commandSize = parsePtr->term - parsePtr->commandStart;
return TCL_ERROR;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclParseWhiteSpace --
+ *
+ * Scans up to numBytes bytes starting at src, consuming white
+ * space as defined by Tcl's parsing rules.
+ *
+ * Results:
+ * Returns the number of bytes recognized as white space. Records
+ * at parsePtr, information about the parse. Records at typePtr
+ * the character type of the non-whitespace character that terminated
+ * the scan.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclParseWhiteSpace(src, numBytes, parsePtr, typePtr)
+ CONST char *src; /* First character to parse. */
+ register int numBytes; /* Max number of bytes to scan. */
+ Tcl_Parse *parsePtr; /* Information about parse in progress.
+ * Updated if parsing indicates
+ * an incomplete command. */
+ char *typePtr; /* Points to location to store character
+ * type of character that ends run
+ * of whitespace */
+{
+ register char type = TYPE_NORMAL;
+ register CONST char *p = src;
+
+ while (1) {
+ while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
+ numBytes--; p++;
+ }
+ if (numBytes && (type & TYPE_SUBS)) {
+ if (*p != '\\') {
+ break;
+ }
+ if (--numBytes == 0) {
+ break;
+ }
+ if (p[1] != '\n') {
+ break;
+ }
+ p+=2;
+ if (--numBytes == 0) {
+ parsePtr->incomplete = 1;
+ break;
+ }
+ continue;
+ }
+ break;
+ }
+ *typePtr = type;
+ return (p - src);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclParseHex --
+ *
+ * Scans a hexadecimal number as a Tcl_UniChar value.
+ * (e.g., for parsing \x and \u escape sequences).
+ * At most numBytes bytes are scanned.
+ *
+ * Results:
+ * The numeric value is stored in *resultPtr.
+ * Returns the number of bytes consumed.
+ *
+ * Notes:
+ * Relies on the following properties of the ASCII
+ * character set, with which UTF-8 is compatible:
+ *
+ * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z'
+ * occupy consecutive code points, and '0' < 'A' < 'a'.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclParseHex(src, numBytes, resultPtr)
+ CONST char *src; /* First character to parse. */
+ int numBytes; /* Max number of byes to scan */
+ Tcl_UniChar *resultPtr; /* Points to storage provided by
+ * caller where the Tcl_UniChar
+ * resulting from the conversion is
+ * to be written. */
+{
+ Tcl_UniChar result = 0;
+ register CONST char *p = src;
+
+ while (numBytes--) {
+ unsigned char digit = UCHAR(*p);
+
+ if (!isxdigit(digit))
+ break;
+
+ ++p;
+ result <<= 4;
+
+ if (digit >= 'a') {
+ result |= (10 + digit - 'a');
+ } else if (digit >= 'A') {
+ result |= (10 + digit - 'A');
+ } else {
+ result |= (digit - '0');
+ }
+ }
+
+ *resultPtr = result;
+ return (p - src);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclParseBackslash --
+ *
+ * Scans up to numBytes bytes starting at src, consuming a
+ * backslash sequence as defined by Tcl's parsing rules.
+ *
+ * Results:
+ * Records at readPtr the number of bytes making up the backslash
+ * sequence. Records at dst the UTF-8 encoded equivalent of
+ * that backslash sequence. Returns the number of bytes written
+ * to dst, at most TCL_UTF_MAX. Either readPtr or dst may be
+ * NULL, if the results are not needed, but the return value is
+ * the same either way.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclParseBackslash(src, numBytes, readPtr, dst)
+ CONST char * src; /* Points to the backslash character of a
+ * a backslash sequence */
+ int numBytes; /* Max number of bytes to scan */
+ int *readPtr; /* NULL, or points to storage where the
+ * number of bytes scanned should be written. */
+ char *dst; /* NULL, or points to buffer where the UTF-8
+ * encoding of the backslash sequence is to be
+ * written. At most TCL_UTF_MAX bytes will be
+ * written there. */
+{
+ register CONST char *p = src+1;
+ Tcl_UniChar result;
+ int count;
+ char buf[TCL_UTF_MAX];
+
+ if (numBytes == 0) {
+ if (readPtr != NULL) {
+ *readPtr = 0;
+ }
+ return 0;
+ }
+
+ if (dst == NULL) {
+ dst = buf;
+ }
+
+ if (numBytes == 1) {
+ /* Can only scan the backslash. Return it. */
+ result = '\\';
+ count = 1;
+ goto done;
+ }
+
+ count = 2;
+ switch (*p) {
+ /*
+ * Note: in the conversions below, use absolute values (e.g.,
+ * 0xa) rather than symbolic values (e.g. \n) that get converted
+ * by the compiler. It's possible that compilers on some
+ * platforms will do the symbolic conversions differently, which
+ * could result in non-portable Tcl scripts.
+ */
+
+ case 'a':
+ result = 0x7;
+ break;
+ case 'b':
+ result = 0x8;
+ break;
+ case 'f':
+ result = 0xc;
+ break;
+ case 'n':
+ result = 0xa;
+ break;
+ case 'r':
+ result = 0xd;
+ break;
+ case 't':
+ result = 0x9;
+ break;
+ case 'v':
+ result = 0xb;
+ break;
+ case 'x':
+ count += TclParseHex(p+1, numBytes-1, &result);
+ if (count == 2) {
+ /* No hexadigits -> This is just "x". */
+ result = 'x';
+ } else {
+ /* Keep only the last byte (2 hex digits) */
+ result = (unsigned char) result;
+ }
+ break;
+ case 'u':
+ count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result);
+ if (count == 2) {
+ /* No hexadigits -> This is just "u". */
+ result = 'u';
+ }
+ break;
+ case '\n':
+ count--;
+ do {
+ p++; count++;
+ } while ((count < numBytes) && ((*p == ' ') || (*p == '\t')));
+ result = ' ';
+ break;
+ case 0:
+ result = '\\';
+ count = 1;
+ break;
+ default:
+ /*
+ * Check for an octal number \oo?o?
+ */
+ if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */
+ result = (unsigned char)(*p - '0');
+ p++;
+ if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */
+ || (UCHAR(*p) >= '8')) {
+ break;
+ }
+ count = 3;
+ result = (unsigned char)((result << 3) + (*p - '0'));
+ p++;
+ if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */
+ || (UCHAR(*p) >= '8')) {
+ break;
+ }
+ count = 4;
+ result = (unsigned char)((result << 3) + (*p - '0'));
+ break;
+ }
+ /*
+ * We have to convert here in case the user has put a
+ * backslash in front of a multi-byte utf-8 character.
+ * While this means nothing special, we shouldn't break up
+ * a correct utf-8 character. [Bug #217987] test subst-3.2
+ */
+ if (Tcl_UtfCharComplete(p, numBytes - 1)) {
+ count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
+ } else {
+ char utfBytes[TCL_UTF_MAX];
+ memcpy(utfBytes, p, (size_t) (numBytes - 1));
+ utfBytes[numBytes - 1] = '\0';
+ count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
+ }
+ break;
+ }
+
+ done:
+ if (readPtr != NULL) {
+ *readPtr = count;
+ }
+ return Tcl_UniCharToUtf((int) result, dst);
+}
\f
/*
*----------------------------------------------------------------------
*
+ * ParseComment --
+ *
+ * Scans up to numBytes bytes starting at src, consuming a
+ * Tcl comment as defined by Tcl's parsing rules.
+ *
+ * Results:
+ * Records in parsePtr information about the parse. Returns the
+ * number of bytes consumed.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+ParseComment(src, numBytes, parsePtr)
+ CONST char *src; /* First character to parse. */
+ register int numBytes; /* Max number of bytes to scan. */
+ Tcl_Parse *parsePtr; /* Information about parse in progress.
+ * Updated if parsing indicates
+ * an incomplete command. */
+{
+ register CONST char *p = src;
+ while (numBytes) {
+ char type;
+ int scanned;
+ do {
+ scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
+ p += scanned; numBytes -= scanned;
+ } while (numBytes && (*p == '\n') && (p++,numBytes--));
+ if ((numBytes == 0) || (*p != '#')) {
+ break;
+ }
+ if (parsePtr->commentStart == NULL) {
+ parsePtr->commentStart = p;
+ }
+ while (numBytes) {
+ if (*p == '\\') {
+ scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
+ if (scanned) {
+ p += scanned; numBytes -= scanned;
+ } else {
+ /*
+ * General backslash substitution in comments isn't
+ * part of the formal spec, but test parse-15.47
+ * and history indicate that it has been the de facto
+ * rule. Don't change it now.
+ */
+ TclParseBackslash(p, numBytes, &scanned, NULL);
+ p += scanned; numBytes -= scanned;
+ }
+ } else {
+ p++; numBytes--;
+ if (p[-1] == '\n') {
+ break;
+ }
+ }
+ }
+ parsePtr->commentSize = p - parsePtr->commentStart;
+ }
+ return (p - src);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ParseTokens --
*
* This procedure forms the heart of the Tcl parser. It parses one
* or more tokens from a string, up to a termination point
* specified by the caller. This procedure is used to parse
* unquoted command words (those not in quotes or braces), words in
- * quotes, and array indices for variables.
+ * quotes, and array indices for variables. No more than numBytes
+ * bytes will be scanned.
*
* Results:
* Tokens are added to parsePtr and parsePtr->term is filled in
*/
static int
-ParseTokens(src, mask, parsePtr)
- register char *src; /* First character to parse. */
+ParseTokens(src, numBytes, mask, parsePtr)
+ register CONST char *src; /* First character to parse. */
+ register int numBytes; /* Max number of bytes to scan. */
int mask; /* Specifies when to stop parsing. The
* parse stops at the first unquoted
* character whose CHAR_TYPE contains
* Updated with additional tokens and
* termination information. */
{
- int type, originalTokens, varToken;
- char utfBytes[TCL_UTF_MAX];
+ char type;
+ int originalTokens, varToken;
Tcl_Token *tokenPtr;
Tcl_Parse nested;
*/
originalTokens = parsePtr->numTokens;
- while (1) {
+ while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr->start = src;
tokenPtr->numComponents = 0;
- type = CHAR_TYPE(*src);
- if (type & mask) {
- break;
- }
-
if ((type & TYPE_SUBS) == 0) {
/*
* This is a simple range of characters. Scan to find the end
* of the range.
*/
- while (1) {
- src++;
- if (CHAR_TYPE(*src) & (mask | TYPE_SUBS)) {
- break;
- }
+ while ((++src, --numBytes)
+ && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) {
+ /* empty loop */
}
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = src - tokenPtr->start;
*/
varToken = parsePtr->numTokens;
- if (Tcl_ParseVarName(parsePtr->interp, src, parsePtr->end - src,
+ if (Tcl_ParseVarName(parsePtr->interp, src, numBytes,
parsePtr, 1) != TCL_OK) {
return TCL_ERROR;
}
src += parsePtr->tokenPtr[varToken].size;
+ numBytes -= parsePtr->tokenPtr[varToken].size;
} else if (*src == '[') {
/*
* Command substitution. Call Tcl_ParseCommand recursively
* throw away the parse information.
*/
- src++;
+ src++; numBytes--;
while (1) {
if (Tcl_ParseCommand(parsePtr->interp, src,
- parsePtr->end - src, 1, &nested) != TCL_OK) {
+ numBytes, 1, &nested) != TCL_OK) {
parsePtr->errorType = nested.errorType;
parsePtr->term = nested.term;
parsePtr->incomplete = nested.incomplete;
return TCL_ERROR;
}
- src = nested.commandStart + nested.commandSize;
- if (nested.tokenPtr != nested.staticTokens) {
- ckfree((char *) nested.tokenPtr);
- }
- if ((*nested.term == ']') && !nested.incomplete) {
- break;
- }
- if (src == parsePtr->end) {
- if (parsePtr->interp != NULL) {
- Tcl_SetResult(parsePtr->interp,
- "missing close-bracket", TCL_STATIC);
- }
- parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
- parsePtr->term = tokenPtr->start;
- parsePtr->incomplete = 1;
- return TCL_ERROR;
- }
- }
- tokenPtr->type = TCL_TOKEN_COMMAND;
- tokenPtr->size = src - tokenPtr->start;
- parsePtr->numTokens++;
- } else if (*src == '\\') {
- /*
- * Backslash substitution.
- */
-
- if (src[1] == '\n') {
- if ((src + 2) == parsePtr->end) {
- parsePtr->incomplete = 1;
- }
-
- /*
- * Note: backslash-newline is special in that it is
- * treated the same as a space character would be. This
- * means that it could terminate the token.
- */
-
- if (mask & TYPE_SPACE) {
- break;
- }
- }
- tokenPtr->type = TCL_TOKEN_BS;
- Tcl_UtfBackslash(src, &tokenPtr->size, utfBytes);
- parsePtr->numTokens++;
- src += tokenPtr->size;
- } else if (*src == 0) {
- /*
- * We encountered a null character. If it is the null
- * character at the end of the string, then return.
- * Otherwise generate a text token for the single
- * character.
- */
-
- if (src == parsePtr->end) {
- break;
- }
- tokenPtr->type = TCL_TOKEN_TEXT;
- tokenPtr->size = 1;
- parsePtr->numTokens++;
- src++;
- } else {
- panic("ParseTokens encountered unknown character");
- }
- }
- if (parsePtr->numTokens == originalTokens) {
- /*
- * There was nothing in this range of text. Add an empty token
- * for the empty range, so that there is always at least one
- * token added.
- */
-
- tokenPtr->type = TCL_TOKEN_TEXT;
- tokenPtr->size = 0;
- parsePtr->numTokens++;
- }
- parsePtr->term = src;
- return TCL_OK;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_FreeParse --
- *
- * This procedure is invoked to free any dynamic storage that may
- * have been allocated by a previous call to Tcl_ParseCommand.
- *
- * Results:
- * None.
- *
- * Side effects:
- * If there is any dynamically allocated memory in *parsePtr,
- * it is freed.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_FreeParse(parsePtr)
- Tcl_Parse *parsePtr; /* Structure that was filled in by a
- * previous call to Tcl_ParseCommand. */
-{
- if (parsePtr->tokenPtr != parsePtr->staticTokens) {
- ckfree((char *) parsePtr->tokenPtr);
- parsePtr->tokenPtr = parsePtr->staticTokens;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclExpandTokenArray --
- *
- * This procedure is invoked when the current space for tokens in
- * a Tcl_Parse structure fills up; it allocates memory to grow the
- * token array
- *
- * Results:
- * None.
- *
- * Side effects:
- * Memory is allocated for a new larger token array; the memory
- * for the old array is freed, if it had been dynamically allocated.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclExpandTokenArray(parsePtr)
- Tcl_Parse *parsePtr; /* Parse structure whose token space
- * has overflowed. */
-{
- int newCount;
- Tcl_Token *newPtr;
-
- newCount = parsePtr->tokensAvailable*2;
- newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token)));
- memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr,
- (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
- if (parsePtr->tokenPtr != parsePtr->staticTokens) {
- ckfree((char *) parsePtr->tokenPtr);
- }
- parsePtr->tokenPtr = newPtr;
- parsePtr->tokensAvailable = newCount;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * EvalObjv --
- *
- * This procedure evaluates a Tcl command that has already been
- * parsed into words, with one Tcl_Obj holding each word.
- *
- * Results:
- * The return value is a standard Tcl completion code such as
- * TCL_OK or TCL_ERROR. A result or error message is left in
- * interp's result. If an error occurs, this procedure does
- * NOT add any information to the errorInfo variable.
- *
- * Side effects:
- * Depends on the command.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-EvalObjv(interp, objc, objv, command, length, flags)
- Tcl_Interp *interp; /* Interpreter in which to evaluate the
- * command. Also used for error
- * reporting. */
- int objc; /* Number of words in command. */
- Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
- * the words that make up the command. */
- char *command; /* Points to the beginning of the string
- * representation of the command; this
- * is used for traces. If the string
- * representation of the command is
- * unknown, an empty string should be
- * supplied. */
- int length; /* Number of bytes in command; if -1, all
- * characters up to the first null byte are
- * used. */
- int flags; /* Collection of OR-ed bits that control
- * the evaluation of the script. Only
- * TCL_EVAL_GLOBAL is currently
- * supported. */
-
-{
- Command *cmdPtr;
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj **newObjv;
- int i, code;
- Trace *tracePtr, *nextPtr;
- char **argv, *commandCopy;
- CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
- * in case TCL_EVAL_GLOBAL was set. */
-
- Tcl_ResetResult(interp);
- if (objc == 0) {
- return TCL_OK;
- }
-
- /*
- * If the interpreter was deleted, return an error.
- */
-
- if (iPtr->flags & DELETED) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "attempt to call eval in deleted interpreter", -1);
- Tcl_SetErrorCode(interp, "CORE", "IDELETE",
- "attempt to call eval in deleted interpreter",
- (char *) NULL);
- return TCL_ERROR;
- }
-
- /*
- * Check depth of nested calls to Tcl_Eval: if this gets too large,
- * it's probably because of an infinite loop somewhere.
- */
-
- if (iPtr->numLevels >= iPtr->maxNestingDepth) {
- iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
- return TCL_ERROR;
- }
- iPtr->numLevels++;
-
- /*
- * On the Mac, we will never reach the default recursion limit before
- * blowing the stack. So we need to do a check here.
- */
-
- if (TclpCheckStackSpace() == 0) {
- /*NOTREACHED*/
- iPtr->numLevels--;
- iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
- return TCL_ERROR;
- }
-
- /*
- * Find the procedure to execute this command. If there isn't one,
- * then see if there is a command "unknown". If so, create a new
- * word array with "unknown" as the first word and the original
- * command words as arguments. Then call ourselves recursively
- * to execute it.
- */
-
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
- if (cmdPtr == NULL) {
- newObjv = (Tcl_Obj **) ckalloc((unsigned)
- ((objc + 1) * sizeof (Tcl_Obj *)));
- for (i = objc-1; i >= 0; i--) {
- newObjv[i+1] = objv[i];
- }
- newObjv[0] = Tcl_NewStringObj("unknown", -1);
- Tcl_IncrRefCount(newObjv[0]);
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
- if (cmdPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "invalid command name \"", Tcl_GetString(objv[0]), "\"",
- (char *) NULL);
- code = TCL_ERROR;
- } else {
- code = EvalObjv(interp, objc+1, newObjv, command, length, 0);
- }
- Tcl_DecrRefCount(newObjv[0]);
- ckfree((char *) newObjv);
- goto done;
- }
-
- /*
- * Call trace procedures if needed.
- */
-
- argv = NULL;
- commandCopy = command;
-
- for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) {
- nextPtr = tracePtr->nextPtr;
- if (iPtr->numLevels > tracePtr->level) {
- continue;
- }
-
- /*
- * This is a bit messy because we have to emulate the old trace
- * interface, which uses strings for everything.
- */
-
- if (argv == NULL) {
- argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *));
- for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
- }
- argv[objc] = 0;
-
- if (length < 0) {
- length = strlen(command);
- } else if ((size_t)length < strlen(command)) {
- commandCopy = (char *) ckalloc((unsigned) (length + 1));
- strncpy(commandCopy, command, (size_t) length);
- commandCopy[length] = 0;
- }
- }
- (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
- commandCopy, cmdPtr->proc, cmdPtr->clientData,
- objc, argv);
- }
- if (argv != NULL) {
- ckfree((char *) argv);
- }
- if (commandCopy != command) {
- ckfree((char *) commandCopy);
- }
-
- /*
- * Finally, invoke the command's Tcl_ObjCmdProc.
- */
-
- iPtr->cmdCount++;
- savedVarFramePtr = iPtr->varFramePtr;
- if (flags & TCL_EVAL_GLOBAL) {
- iPtr->varFramePtr = NULL;
- }
- code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
- iPtr->varFramePtr = savedVarFramePtr;
- if (Tcl_AsyncReady()) {
- code = Tcl_AsyncInvoke(interp, code);
- }
-
- /*
- * If the interpreter has a non-empty string result, the result
- * object is either empty or stale because some procedure set
- * interp->result directly. If so, move the string result to the
- * result object, then reset the string result.
- */
-
- if (*(iPtr->result) != 0) {
- (void) Tcl_GetObjResult(interp);
- }
-
- done:
- iPtr->numLevels--;
- return code;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_EvalObjv --
- *
- * This procedure evaluates a Tcl command that has already been
- * parsed into words, with one Tcl_Obj holding each word.
- *
- * Results:
- * The return value is a standard Tcl completion code such as
- * TCL_OK or TCL_ERROR. A result or error message is left in
- * interp's result.
- *
- * Side effects:
- * Depends on the command.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_EvalObjv(interp, objc, objv, flags)
- Tcl_Interp *interp; /* Interpreter in which to evaluate the
- * command. Also used for error
- * reporting. */
- int objc; /* Number of words in command. */
- Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
- * the words that make up the command. */
- int flags; /* Collection of OR-ed bits that control
- * the evaluation of the script. Only
- * TCL_EVAL_GLOBAL is currently
- * supported. */
-{
- Interp *iPtr = (Interp *)interp;
- Trace *tracePtr;
- Tcl_DString cmdBuf;
- char *cmdString = "";
- int cmdLen = 0;
- int code = TCL_OK;
-
- for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
- /*
- * EvalObjv will increment numLevels so use "<" rather than "<="
- */
- if (iPtr->numLevels < tracePtr->level) {
- int i;
- /*
- * The command will be needed for an execution trace or stack trace
- * generate a command string.
- */
- cmdtraced:
- Tcl_DStringInit(&cmdBuf);
- for (i = 0; i < objc; i++) {
- Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
- }
- cmdString = Tcl_DStringValue(&cmdBuf);
- cmdLen = Tcl_DStringLength(&cmdBuf);
- break;
- }
- }
-
- /*
- * Execute the command if we have not done so already
- */
- switch (code) {
- case TCL_OK:
- code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags);
- if (code == TCL_ERROR && cmdLen == 0)
- goto cmdtraced;
- break;
- case TCL_ERROR:
- Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
- break;
- default:
- /*NOTREACHED*/
- break;
- }
-
- if (cmdLen != 0) {
- Tcl_DStringFree(&cmdBuf);
- }
- return code;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_LogCommandInfo --
- *
- * This procedure is invoked after an error occurs in an interpreter.
- * It adds information to the "errorInfo" variable to describe the
- * command that was being executed when the error occurred.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Information about the command is added to errorInfo and the
- * line number stored internally in the interpreter is set. If this
- * is the first call to this procedure or Tcl_AddObjErrorInfo since
- * an error occurred, then old information in errorInfo is
- * deleted.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_LogCommandInfo(interp, script, command, length)
- Tcl_Interp *interp; /* Interpreter in which to log information. */
- char *script; /* First character in script containing
- * command (must be <= command). */
- char *command; /* First character in command that
- * generated the error. */
- int length; /* Number of bytes in command (-1 means
- * use all bytes up to first null byte). */
-{
- char buffer[200];
- register char *p;
- char *ellipsis = "";
- Interp *iPtr = (Interp *) interp;
-
- if (iPtr->flags & ERR_ALREADY_LOGGED) {
- /*
- * Someone else has already logged error information for this
- * command; we shouldn't add anything more.
- */
-
- return;
- }
-
- /*
- * Compute the line number where the error occurred.
- */
-
- iPtr->errorLine = 1;
- for (p = script; p != command; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-
- /*
- * Create an error message to add to errorInfo, including up to a
- * maximum number of characters of the command.
- */
-
- if (length < 0) {
- length = strlen(command);
- }
- if (length > 150) {
- length = 150;
- ellipsis = "...";
- }
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buffer, "\n while executing\n\"%.*s%s\"",
- length, command, ellipsis);
- } else {
- sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
- length, command, ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buffer, -1);
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_EvalTokens --
- *
- * Given an array of tokens parsed from a Tcl command (e.g., the
- * tokens that make up a word or the index for an array variable)
- * this procedure evaluates the tokens and concatenates their
- * values to form a single result value.
- *
- * Results:
- * The return value is a pointer to a newly allocated Tcl_Obj
- * containing the value of the array of tokens. The reference
- * count of the returned object has been incremented. If an error
- * occurs in evaluating the tokens then a NULL value is returned
- * and an error message is left in interp's result.
- *
- * Side effects:
- * A new object is allocated to hold the result.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-Tcl_EvalTokens(interp, tokenPtr, count)
- Tcl_Interp *interp; /* Interpreter in which to lookup
- * variables, execute nested commands,
- * and report errors. */
- Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
- * to evaluate and concatenate. */
- int count; /* Number of tokens to consider at tokenPtr.
- * Must be at least 1. */
-{
- Tcl_Obj *resultPtr, *indexPtr, *valuePtr, *newPtr;
- char buffer[TCL_UTF_MAX];
-#ifdef TCL_MEM_DEBUG
-# define MAX_VAR_CHARS 5
-#else
-# define MAX_VAR_CHARS 30
-#endif
- char nameBuffer[MAX_VAR_CHARS+1];
- char *varName, *index;
- char *p = NULL; /* Initialized to avoid compiler warning. */
- int length, code;
-
- /*
- * The only tricky thing about this procedure is that it attempts to
- * avoid object creation and string copying whenever possible. For
- * example, if the value is just a nested command, then use the
- * command's result object directly.
- */
-
- resultPtr = NULL;
- for ( ; count > 0; count--, tokenPtr++) {
- valuePtr = NULL;
-
- /*
- * The switch statement below computes the next value to be
- * concat to the result, as either a range of text or an
- * object.
- */
-
- switch (tokenPtr->type) {
- case TCL_TOKEN_TEXT:
- p = tokenPtr->start;
- length = tokenPtr->size;
- break;
-
- case TCL_TOKEN_BS:
- length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
- buffer);
- p = buffer;
- break;
-
- case TCL_TOKEN_COMMAND:
- code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
- 0);
- if (code != TCL_OK) {
- goto error;
- }
- valuePtr = Tcl_GetObjResult(interp);
- break;
-
- case TCL_TOKEN_VARIABLE:
- if (tokenPtr->numComponents == 1) {
- indexPtr = NULL;
- } else {
- indexPtr = Tcl_EvalTokens(interp, tokenPtr+2,
- tokenPtr->numComponents - 1);
- if (indexPtr == NULL) {
- goto error;
- }
- }
-
- /*
- * We have to make a copy of the variable name in order
- * to have a null-terminated string. We can't make a
- * temporary modification to the script to null-terminate
- * the name, because a trace callback might potentially
- * reuse the script and be affected by the null character.
- */
-
- if (tokenPtr[1].size <= MAX_VAR_CHARS) {
- varName = nameBuffer;
- } else {
- varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
- }
- strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
- varName[tokenPtr[1].size] = 0;
- if (indexPtr != NULL) {
- index = TclGetString(indexPtr);
- } else {
- index = NULL;
- }
- valuePtr = Tcl_GetVar2Ex(interp, varName, index,
- TCL_LEAVE_ERR_MSG);
- if (varName != nameBuffer) {
- ckfree(varName);
- }
- if (indexPtr != NULL) {
- Tcl_DecrRefCount(indexPtr);
- }
- if (valuePtr == NULL) {
- goto error;
- }
- count -= tokenPtr->numComponents;
- tokenPtr += tokenPtr->numComponents;
- break;
-
- default:
- panic("unexpected token type in Tcl_EvalTokens");
- }
-
- /*
- * If valuePtr isn't NULL, the next piece of text comes from that
- * object; otherwise, take length bytes starting at p.
- */
-
- if (resultPtr == NULL) {
- if (valuePtr != NULL) {
- resultPtr = valuePtr;
- } else {
- resultPtr = Tcl_NewStringObj(p, length);
- }
- Tcl_IncrRefCount(resultPtr);
- } else {
- if (Tcl_IsShared(resultPtr)) {
- newPtr = Tcl_DuplicateObj(resultPtr);
- Tcl_DecrRefCount(resultPtr);
- resultPtr = newPtr;
- Tcl_IncrRefCount(resultPtr);
- }
- if (valuePtr != NULL) {
- p = Tcl_GetStringFromObj(valuePtr, &length);
- }
- Tcl_AppendToObj(resultPtr, p, length);
- }
- }
- return resultPtr;
-
- error:
- if (resultPtr != NULL) {
- Tcl_DecrRefCount(resultPtr);
- }
- return NULL;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_EvalEx --
- *
- * This procedure evaluates a Tcl script without using the compiler
- * or byte-code interpreter. It just parses the script, creates
- * values for each word of each command, then calls EvalObjv
- * to execute each command.
- *
- * Results:
- * The return value is a standard Tcl completion code such as
- * TCL_OK or TCL_ERROR. A result or error message is left in
- * interp's result.
- *
- * Side effects:
- * Depends on the script.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_EvalEx(interp, script, numBytes, flags)
- Tcl_Interp *interp; /* Interpreter in which to evaluate the
- * script. Also used for error reporting. */
- char *script; /* First character of script to evaluate. */
- int numBytes; /* Number of bytes in script. If < 0, the
- * script consists of all bytes up to the
- * first null character. */
- int flags; /* Collection of OR-ed bits that control
- * the evaluation of the script. Only
- * TCL_EVAL_GLOBAL is currently
- * supported. */
-{
- Interp *iPtr = (Interp *) interp;
- char *p, *next;
- Tcl_Parse parse;
-#define NUM_STATIC_OBJS 20
- Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
- Tcl_Token *tokenPtr;
- int i, code, commandLength, bytesLeft, nested;
- CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
- * in case TCL_EVAL_GLOBAL was set. */
-
- /*
- * The variables below keep track of how much state has been
- * allocated while evaluating the script, so that it can be freed
- * properly if an error occurs.
- */
-
- int gotParse = 0, objectsUsed = 0;
-
- if (numBytes < 0) {
- numBytes = strlen(script);
- }
- Tcl_ResetResult(interp);
-
- savedVarFramePtr = iPtr->varFramePtr;
- if (flags & TCL_EVAL_GLOBAL) {
- iPtr->varFramePtr = NULL;
- }
-
- /*
- * Each iteration through the following loop parses the next
- * command from the script and then executes it.
- */
-
- objv = staticObjArray;
- p = script;
- bytesLeft = numBytes;
- if (iPtr->evalFlags & TCL_BRACKET_TERM) {
- nested = 1;
- } else {
- nested = 0;
- }
- iPtr->evalFlags = 0;
- do {
- if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
- != TCL_OK) {
- code = TCL_ERROR;
- goto error;
- }
- gotParse = 1;
- if (parse.numWords > 0) {
- /*
- * Generate an array of objects for the words of the command.
- */
-
- if (parse.numWords <= NUM_STATIC_OBJS) {
- objv = staticObjArray;
- } else {
- objv = (Tcl_Obj **) ckalloc((unsigned)
- (parse.numWords * sizeof (Tcl_Obj *)));
- }
- for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
- objectsUsed < parse.numWords;
- objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
- objv[objectsUsed] = Tcl_EvalTokens(interp, tokenPtr+1,
- tokenPtr->numComponents);
- if (objv[objectsUsed] == NULL) {
- code = TCL_ERROR;
- goto error;
- }
+ src = nested.commandStart + nested.commandSize;
+ numBytes = parsePtr->end - src;
+ if (nested.tokenPtr != nested.staticTokens) {
+ ckfree((char *) nested.tokenPtr);
+ }
+ if ((*nested.term == ']') && !nested.incomplete) {
+ break;
+ }
+ if (numBytes == 0) {
+ if (parsePtr->interp != NULL) {
+ Tcl_SetResult(parsePtr->interp,
+ "missing close-bracket", TCL_STATIC);
+ }
+ parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
+ parsePtr->term = tokenPtr->start;
+ parsePtr->incomplete = 1;
+ return TCL_ERROR;
+ }
}
-
+ tokenPtr->type = TCL_TOKEN_COMMAND;
+ tokenPtr->size = src - tokenPtr->start;
+ parsePtr->numTokens++;
+ } else if (*src == '\\') {
/*
- * Execute the command and free the objects for its words.
+ * Backslash substitution.
*/
-
- code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0);
- if (code != TCL_OK) {
- goto error;
- }
- for (i = 0; i < objectsUsed; i++) {
- Tcl_DecrRefCount(objv[i]);
- }
- objectsUsed = 0;
- if (objv != staticObjArray) {
- ckfree((char *) objv);
- objv = staticObjArray;
- }
- }
+ TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);
- /*
- * Advance to the next command in the script.
- */
+ if (tokenPtr->size == 1) {
+ /* Just a backslash, due to end of string */
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ continue;
+ }
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= next - p;
- p = next;
- Tcl_FreeParse(&parse);
- gotParse = 0;
- if ((nested != 0) && (p > script) && (p[-1] == ']')) {
- /*
- * We get here in the special case where the TCL_BRACKET_TERM
- * flag was set in the interpreter and we reached a close
- * bracket in the script. Return immediately.
- */
+ if (src[1] == '\n') {
+ if (numBytes == 2) {
+ parsePtr->incomplete = 1;
+ }
- iPtr->termOffset = (p - 1) - script;
- iPtr->varFramePtr = savedVarFramePtr;
- return TCL_OK;
- }
- } while (bytesLeft > 0);
- iPtr->termOffset = p - script;
- iPtr->varFramePtr = savedVarFramePtr;
- return TCL_OK;
+ /*
+ * Note: backslash-newline is special in that it is
+ * treated the same as a space character would be. This
+ * means that it could terminate the token.
+ */
- error:
- /*
- * Generate various pieces of error information, such as the line
- * number where the error occurred and information to add to the
- * errorInfo variable. Then free resources that had been allocated
- * to the command.
- */
+ if (mask & TYPE_SPACE) {
+ if (parsePtr->numTokens == originalTokens) {
+ goto finishToken;
+ }
+ break;
+ }
+ }
- if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- commandLength = parse.commandSize;
- if ((parse.commandStart + commandLength) != (script + numBytes)) {
- /*
- * The command where the error occurred didn't end at the end
- * of the script (i.e. it ended at a terminator character such
- * as ";". Reduce the length by one so that the error message
- * doesn't include the terminator character.
- */
-
- commandLength -= 1;
+ tokenPtr->type = TCL_TOKEN_BS;
+ parsePtr->numTokens++;
+ src += tokenPtr->size;
+ numBytes -= tokenPtr->size;
+ } else if (*src == 0) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++; numBytes--;
+ } else {
+ panic("ParseTokens encountered unknown character");
}
- Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
- }
-
- for (i = 0; i < objectsUsed; i++) {
- Tcl_DecrRefCount(objv[i]);
}
- if (gotParse) {
- p = parse.commandStart + parse.commandSize;
- Tcl_FreeParse(&parse);
- if ((nested != 0) && (p > script) && (p[-1] == ']')) {
- /*
- * We get here in the special case where the TCL_BRACKET_TERM
- * flag was set in the interpreter and we reached a close
- * bracket in the script. Return immediately.
- */
+ if (parsePtr->numTokens == originalTokens) {
+ /*
+ * There was nothing in this range of text. Add an empty token
+ * for the empty range, so that there is always at least one
+ * token added.
+ */
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
- iPtr->termOffset = (p - 1) - script;
- } else {
- iPtr->termOffset = p - script;
- }
- }
- if (objv != staticObjArray) {
- ckfree((char *) objv);
+ finishToken:
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 0;
+ parsePtr->numTokens++;
}
- iPtr->varFramePtr = savedVarFramePtr;
- return code;
+ parsePtr->term = src;
+ return TCL_OK;
}
-\f
+
/*
*----------------------------------------------------------------------
*
- * Tcl_Eval --
+ * Tcl_FreeParse --
*
- * Execute a Tcl command in a string. This procedure executes the
- * script directly, rather than compiling it to bytecodes. Before
- * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
- * the main procedure used for executing Tcl commands, but nowadays
- * it isn't used much.
+ * This procedure is invoked to free any dynamic storage that may
+ * have been allocated by a previous call to Tcl_ParseCommand.
*
* Results:
- * The return value is one of the return codes defined in tcl.h
- * (such as TCL_OK), and interp's result contains a value
- * to supplement the return code. The value of the result
- * will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
- * you must copy it or lose it!
+ * None.
*
* Side effects:
- * Can be almost arbitrary, depending on the commands in the script.
+ * If there is any dynamically allocated memory in *parsePtr,
+ * it is freed.
*
*----------------------------------------------------------------------
*/
-int
-Tcl_Eval(interp, string)
- Tcl_Interp *interp; /* Token for command interpreter (returned
- * by previous call to Tcl_CreateInterp). */
- char *string; /* Pointer to TCL command to execute. */
+void
+Tcl_FreeParse(parsePtr)
+ Tcl_Parse *parsePtr; /* Structure that was filled in by a
+ * previous call to Tcl_ParseCommand. */
{
- int code;
-
- code = Tcl_EvalEx(interp, string, -1, 0);
-
- /*
- * For backwards compatibility with old C code that predates the
- * object system in Tcl 8.0, we have to mirror the object result
- * back into the string result (some callers may expect it there).
- */
-
- Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
- TCL_VOLATILE);
- return code;
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
}
-\f
+
/*
*----------------------------------------------------------------------
*
- * Tcl_EvalObj, Tcl_GlobalEvalObj --
+ * TclExpandTokenArray --
*
- * These functions are deprecated but we keep them around for backwards
- * compatibility reasons.
+ * This procedure is invoked when the current space for tokens in
+ * a Tcl_Parse structure fills up; it allocates memory to grow the
+ * token array
*
* Results:
- * See the functions they call.
+ * None.
*
* Side effects:
- * See the functions they call.
+ * Memory is allocated for a new larger token array; the memory
+ * for the old array is freed, if it had been dynamically allocated.
*
*----------------------------------------------------------------------
*/
-#undef Tcl_EvalObj
-int
-Tcl_EvalObj(interp, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
+void
+TclExpandTokenArray(parsePtr)
+ Tcl_Parse *parsePtr; /* Parse structure whose token space
+ * has overflowed. */
{
- return Tcl_EvalObjEx(interp, objPtr, 0);
-}
+ int newCount;
+ Tcl_Token *newPtr;
-#undef Tcl_GlobalEvalObj
-int
-Tcl_GlobalEvalObj(interp, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
-{
- return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
+ newCount = parsePtr->tokensAvailable*2;
+ newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token)));
+ memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr,
+ (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ }
+ parsePtr->tokenPtr = newPtr;
+ parsePtr->tokensAvailable = newCount;
}
-\f
+
/*
*----------------------------------------------------------------------
*
* Tcl_ParseVarName --
*
* Given a string starting with a $ sign, parse off a variable
- * name and return information about the parse.
+ * name and return information about the parse. No more than
+ * numBytes bytes will be scanned.
*
* Results:
* The return value is TCL_OK if the command was parsed
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
- char *string; /* String containing variable name. First
+ CONST char *string; /* String containing variable name. First
* character must be "$". */
- int numBytes; /* Total number of bytes in string. If < 0,
+ register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr; /* Structure to fill in with information
* it. */
{
Tcl_Token *tokenPtr;
- char *end, *src;
+ register CONST char *src;
unsigned char c;
int varIndex, offset;
Tcl_UniChar ch;
unsigned array;
- if (numBytes >= 0) {
- end = string + numBytes;
- } else {
- end = string + strlen(string);
+ if ((numBytes == 0) || (string == NULL)) {
+ return TCL_ERROR;
+ }
+ if (numBytes < 0) {
+ numBytes = strlen(string);
}
if (!append) {
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
- parsePtr->end = end;
+ parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
parsePtr->incomplete = 0;
varIndex = parsePtr->numTokens;
parsePtr->numTokens++;
tokenPtr++;
- src++;
- if (src >= end) {
+ src++; numBytes--;
+ if (numBytes == 0) {
goto justADollarSign;
}
tokenPtr->type = TCL_TOKEN_TEXT;
*/
if (*src == '{') {
- src++;
+ src++; numBytes--;
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
- while (1) {
- if (src == end) {
- if (interp != NULL) {
- Tcl_SetResult(interp,
- "missing close-brace for variable name",
+
+ while (numBytes && (*src != '}')) {
+ numBytes--; src++;
+ }
+ if (numBytes == 0) {
+ if (interp != NULL) {
+ Tcl_SetResult(interp, "missing close-brace for variable name",
TCL_STATIC);
- }
- parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
- parsePtr->term = tokenPtr->start-1;
- parsePtr->incomplete = 1;
- goto error;
- }
- if (*src == '}') {
- break;
}
- src++;
+ parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
+ parsePtr->term = tokenPtr->start-1;
+ parsePtr->incomplete = 1;
+ goto error;
}
tokenPtr->size = src - tokenPtr->start;
tokenPtr[-1].size = src - tokenPtr[-1].start;
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
- while (src != end) {
- offset = Tcl_UtfToUniChar(src, &ch);
+ while (numBytes) {
+ if (Tcl_UtfCharComplete(src, numBytes)) {
+ offset = Tcl_UtfToUniChar(src, &ch);
+ } else {
+ char utfBytes[TCL_UTF_MAX];
+ memcpy(utfBytes, src, (size_t) numBytes);
+ utfBytes[numBytes] = '\0';
+ offset = Tcl_UtfToUniChar(utfBytes, &ch);
+ }
c = UCHAR(ch);
if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
- src += offset;
+ src += offset; numBytes -= offset;
continue;
}
- if ((c == ':') && (((src+1) != end) && (src[1] == ':'))) {
- src += 2;
- while ((src != end) && (*src == ':')) {
- src += 1;
+ if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
+ src += 2; numBytes -= 2;
+ while (numBytes && (*src == ':')) {
+ src++; numBytes--;
}
continue;
}
/*
* Support for empty array names here.
*/
- array = ((src != end) && (*src == '('));
+ array = (numBytes && (*src == '('));
tokenPtr->size = src - tokenPtr->start;
- if (tokenPtr->size == 0 && !array) {
+ if ((tokenPtr->size == 0) && !array) {
goto justADollarSign;
}
parsePtr->numTokens++;
* since it could contain any number of substitutions.
*/
- if (ParseTokens(src+1, TYPE_CLOSE_PAREN, parsePtr)
+ if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr)
!= TCL_OK) {
goto error;
}
- if ((parsePtr->term == end) || (*parsePtr->term != ')')) {
+ if ((parsePtr->term == (src + numBytes))
+ || (*parsePtr->term != ')')) {
if (parsePtr->interp != NULL) {
Tcl_SetResult(parsePtr->interp, "missing )",
TCL_STATIC);
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
-\f
+
/*
*----------------------------------------------------------------------
*
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_ParseVar(interp, string, termPtr)
Tcl_Interp *interp; /* Context for looking up variable. */
- register char *string; /* String containing variable name.
+ register CONST char *string; /* String containing variable name.
* First character must be "$". */
- char **termPtr; /* If non-NULL, points to word to fill
+ CONST char **termPtr; /* If non-NULL, points to word to fill
* in with character just after last
* one in the variable specifier. */
{
Tcl_Parse parse;
register Tcl_Obj *objPtr;
+ int code;
if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) {
return NULL;
return "$";
}
- objPtr = Tcl_EvalTokens(interp, parse.tokenPtr, parse.numTokens);
- if (objPtr == NULL) {
+ code = Tcl_EvalTokensStandard(interp, parse.tokenPtr, parse.numTokens);
+ if (code != TCL_OK) {
return NULL;
}
+ objPtr = Tcl_GetObjResult(interp);
/*
* At this point we should have an object containing the value of
* a variable. Just return the string from that object.
+ *
+ * This should have returned the object for the user to manage, but
+ * instead we have some weak reference to the string value in the
+ * object, which is why we make sure the object exists after resetting
+ * the result. This isn't ideal, but it's the best we can do with the
+ * current documented interface. -- hobbs
*/
-#ifdef TCL_COMPILE_DEBUG
- if (objPtr->refCount < 2) {
- panic("Tcl_ParseVar got temporary object from Tcl_EvalTokens");
+ if (!Tcl_IsShared(objPtr)) {
+ Tcl_IncrRefCount(objPtr);
}
-#endif /*TCL_COMPILE_DEBUG*/
- TclDecrRefCount(objPtr);
+ Tcl_ResetResult(interp);
return TclGetString(objPtr);
}
-\f
+
/*
*----------------------------------------------------------------------
*
*
* Given a string in braces such as a Tcl command argument or a string
* value in a Tcl expression, this procedure parses the string and
- * returns information about the parse.
+ * returns information about the parse. No more than numBytes bytes
+ * will be scanned.
*
* Results:
* The return value is TCL_OK if the string was parsed successfully and
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
- char *string; /* String containing the string in braces.
+ CONST char *string; /* String containing the string in braces.
* The first character must be '{'. */
- int numBytes; /* Total number of bytes in string. If < 0,
+ register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to
* the first null character. */
register Tcl_Parse *parsePtr;
* information in parsePtr; zero means
* ignore existing tokens in parsePtr and
* reinitialize it. */
- char **termPtr; /* If non-NULL, points to word in which to
+ CONST char **termPtr; /* If non-NULL, points to word in which to
* store a pointer to the character just
* after the terminating '}' if the parse
* was successful. */
{
- char utfBytes[TCL_UTF_MAX]; /* For result of backslash substitution. */
Tcl_Token *tokenPtr;
- register char *src, *end;
+ register CONST char *src;
int startIndex, level, length;
- if ((numBytes >= 0) || (string == NULL)) {
- end = string + numBytes;
- } else {
- end = string + strlen(string);
+ if ((numBytes == 0) || (string == NULL)) {
+ return TCL_ERROR;
}
-
+ if (numBytes < 0) {
+ numBytes = strlen(string);
+ }
+
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
- parsePtr->end = end;
+ parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
- src = string+1;
+ src = string;
startIndex = parsePtr->numTokens;
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
}
tokenPtr = &parsePtr->tokenPtr[startIndex];
tokenPtr->type = TCL_TOKEN_TEXT;
- tokenPtr->start = src;
+ tokenPtr->start = src+1;
tokenPtr->numComponents = 0;
level = 1;
while (1) {
- while (CHAR_TYPE(*src) == TYPE_NORMAL) {
- src++;
- }
- if (*src == '}') {
- level--;
- if (level == 0) {
+ while (++src, --numBytes) {
+ if (CHAR_TYPE(*src) != TYPE_NORMAL) {
break;
}
- src++;
- } else if (*src == '{') {
- level++;
- src++;
- } else if (*src == '\\') {
- Tcl_UtfBackslash(src, &length, utfBytes);
- if (src[1] == '\n') {
+ }
+ if (numBytes == 0) {
+ register int openBrace = 0;
+
+ parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
+ parsePtr->term = string;
+ parsePtr->incomplete = 1;
+ if (interp == NULL) {
/*
- * A backslash-newline sequence must be collapsed, even
- * inside braces, so we have to split the word into
- * multiple tokens so that the backslash-newline can be
- * represented explicitly.
+ * Skip straight to the exit code since we have no
+ * interpreter to put error message in.
*/
-
- if ((src + 2) == end) {
- parsePtr->incomplete = 1;
- }
- tokenPtr->size = (src - tokenPtr->start);
- if (tokenPtr->size != 0) {
- parsePtr->numTokens++;
- }
- if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
- TclExpandTokenArray(parsePtr);
- }
- tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
- tokenPtr->type = TCL_TOKEN_BS;
- tokenPtr->start = src;
- tokenPtr->size = length;
- tokenPtr->numComponents = 0;
- parsePtr->numTokens++;
-
- src += length;
- tokenPtr++;
- tokenPtr->type = TCL_TOKEN_TEXT;
- tokenPtr->start = src;
- tokenPtr->numComponents = 0;
- } else {
- src += length;
+ goto error;
}
- } else if (src == end) {
- int openBrace;
- if (interp != NULL) {
- Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
- }
+ Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
+
/*
- * Search the source string for a possible open
- * brace within the context of a comment. Since we
- * aren't performing a full Tcl parse, just look for
- * an open brace preceeded by a '<whitspace>#' on
- * the same line.
+ * Guess if the problem is due to comments by searching
+ * the source string for a possible open brace within the
+ * context of a comment. Since we aren't performing a
+ * full Tcl parse, just look for an open brace preceded
+ * by a '<whitespace>#' on the same line.
*/
- openBrace = 0;
- while (src > string ) {
+
+ for (; src > string; src--) {
switch (*src) {
- case '{':
- openBrace = 1;
+ case '{':
+ openBrace = 1;
break;
case '\n':
- openBrace = 0;
+ openBrace = 0;
break;
- case '#':
- if ((openBrace == 1) && (isspace(UCHAR(src[-1])))) {
- if (interp != NULL) {
- Tcl_AppendResult(interp,
- ": possible unbalanced brace in comment",
- (char *) NULL);
- }
- openBrace = -1;
- break;
+ case '#' :
+ if (openBrace && (isspace(UCHAR(src[-1])))) {
+ Tcl_AppendResult(interp,
+ ": possible unbalanced brace in comment",
+ (char *) NULL);
+ goto error;
}
break;
}
- if (openBrace == -1) {
- break;
- }
- src--;
}
- parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
- parsePtr->term = string;
- parsePtr->incomplete = 1;
- goto error;
- } else {
- src++;
- }
- }
- /*
- * Decide if we need to finish emitting a partially-finished token.
- * There are 3 cases:
- * {abc \newline xyz} or {xyz} - finish emitting "xyz" token
- * {abc \newline} - don't emit token after \newline
- * {} - finish emitting zero-sized token
- * The last case ensures that there is a token (even if empty) that
- * describes the braced string.
- */
+ error:
+ Tcl_FreeParse(parsePtr);
+ return TCL_ERROR;
+ }
+ switch (*src) {
+ case '{':
+ level++;
+ break;
+ case '}':
+ if (--level == 0) {
+
+ /*
+ * Decide if we need to finish emitting a
+ * partially-finished token. There are 3 cases:
+ * {abc \newline xyz} or {xyz}
+ * - finish emitting "xyz" token
+ * {abc \newline}
+ * - don't emit token after \newline
+ * {} - finish emitting zero-sized token
+ *
+ * The last case ensures that there is a token
+ * (even if empty) that describes the braced string.
+ */
- if ((src != tokenPtr->start)
- || (parsePtr->numTokens == startIndex)) {
- tokenPtr->size = (src - tokenPtr->start);
- parsePtr->numTokens++;
- }
- if (termPtr != NULL) {
- *termPtr = src+1;
+ if ((src != tokenPtr->start)
+ || (parsePtr->numTokens == startIndex)) {
+ tokenPtr->size = (src - tokenPtr->start);
+ parsePtr->numTokens++;
+ }
+ if (termPtr != NULL) {
+ *termPtr = src+1;
+ }
+ return TCL_OK;
+ }
+ break;
+ case '\\':
+ TclParseBackslash(src, numBytes, &length, NULL);
+ if ((length > 1) && (src[1] == '\n')) {
+ /*
+ * A backslash-newline sequence must be collapsed, even
+ * inside braces, so we have to split the word into
+ * multiple tokens so that the backslash-newline can be
+ * represented explicitly.
+ */
+
+ if (numBytes == 2) {
+ parsePtr->incomplete = 1;
+ }
+ tokenPtr->size = (src - tokenPtr->start);
+ if (tokenPtr->size != 0) {
+ parsePtr->numTokens++;
+ }
+ if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->type = TCL_TOKEN_BS;
+ tokenPtr->start = src;
+ tokenPtr->size = length;
+ tokenPtr->numComponents = 0;
+ parsePtr->numTokens++;
+
+ src += length - 1;
+ numBytes -= length - 1;
+ tokenPtr++;
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src + 1;
+ tokenPtr->numComponents = 0;
+ } else {
+ src += length - 1;
+ numBytes -= length - 1;
+ }
+ break;
+ }
}
- return TCL_OK;
-
- error:
- Tcl_FreeParse(parsePtr);
- return TCL_ERROR;
}
-\f
+
/*
*----------------------------------------------------------------------
*
*
* Given a double-quoted string such as a quoted Tcl command argument
* or a quoted value in a Tcl expression, this procedure parses the
- * string and returns information about the parse.
+ * string and returns information about the parse. No more than
+ * numBytes bytes will be scanned.
*
* Results:
* The return value is TCL_OK if the string was parsed successfully and
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
- char *string; /* String containing the quoted string.
+ CONST char *string; /* String containing the quoted string.
* The first character must be '"'. */
- int numBytes; /* Total number of bytes in string. If < 0,
+ register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to
* the first null character. */
register Tcl_Parse *parsePtr;
* information in parsePtr; zero means
* ignore existing tokens in parsePtr and
* reinitialize it. */
- char **termPtr; /* If non-NULL, points to word in which to
+ CONST char **termPtr; /* If non-NULL, points to word in which to
* store a pointer to the character just
* after the quoted string's terminating
* close-quote if the parse succeeds. */
{
- char *end;
-
- if ((numBytes >= 0) || (string == NULL)) {
- end = string + numBytes;
- } else {
- end = string + strlen(string);
+ if ((numBytes == 0) || (string == NULL)) {
+ return TCL_ERROR;
}
-
+ if (numBytes < 0) {
+ numBytes = strlen(string);
+ }
+
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
- parsePtr->end = end;
+ parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
- if (ParseTokens(string+1, TYPE_QUOTE, parsePtr) != TCL_OK) {
+ if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) {
goto error;
}
if (*parsePtr->term != '"') {
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
-\f
+
/*
*----------------------------------------------------------------------
*
*/
static int
-CommandComplete(script, length)
- char *script; /* Script to check. */
- int length; /* Number of bytes in script. */
+CommandComplete(script, numBytes)
+ CONST char *script; /* Script to check. */
+ int numBytes; /* Number of bytes in script. */
{
Tcl_Parse parse;
- char *p, *end;
+ CONST char *p, *end;
int result;
p = script;
- end = p + length;
+ end = p + numBytes;
while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
== TCL_OK) {
p = parse.commandStart + parse.commandSize;
Tcl_FreeParse(&parse);
return result;
}
-\f
+
/*
*----------------------------------------------------------------------
*
int
Tcl_CommandComplete(script)
- char *script; /* Script to check. */
+ CONST char *script; /* Script to check. */
{
return CommandComplete(script, (int) strlen(script));
}
-\f
+
/*
*----------------------------------------------------------------------
*
Tcl_Obj *objPtr; /* Points to object holding script
* to check. */
{
- char *script;
+ CONST char *script;
int length;
script = Tcl_GetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
-\f
+
/*
*----------------------------------------------------------------------
*
* code analysis, etc.
*
* Copyright (c) 1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-2000 by Scriptics Corporation.
+ * Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
-#include "tclCompile.h"
/*
* The stuff below is a bit of a hack so that this file can be used in
int lexeme; /* Type of last lexeme scanned in expr.
* See below for definitions. Corresponds to
* size characters beginning at start. */
- char *start; /* First character in lexeme. */
+ CONST char *start; /* First character in lexeme. */
int size; /* Number of bytes in lexeme. */
- char *next; /* Position of the next character to be
+ CONST char *next; /* Position of the next character to be
* scanned in the expression string. */
- char *prevEnd; /* Points to the character just after the
+ CONST char *prevEnd; /* Points to the character just after the
* last one in the previous lexeme. Used to
* compute size of subexpression tokens. */
- char *originalExpr; /* Points to the start of the expression
+ CONST char *originalExpr; /* Points to the start of the expression
* originally passed to Tcl_ParseExpr. */
- char *lastChar; /* Points just after last byte of expr. */
+ CONST char *lastChar; /* Points just after last byte of expr. */
} ParseInfo;
/*
* Definitions of the different lexemes that appear in expressions. The
* order of these must match the corresponding entries in the
* operatorStrings array below.
+ *
+ * Basic lexemes:
*/
#define LITERAL 0
#define COMMA 8
#define END 9
#define UNKNOWN 10
+#define UNKNOWN_CHAR 11
/*
- * Binary operators:
+ * Binary numeric operators:
*/
-#define MULT 11
-#define DIVIDE 12
-#define MOD 13
-#define PLUS 14
-#define MINUS 15
-#define LEFT_SHIFT 16
-#define RIGHT_SHIFT 17
-#define LESS 18
-#define GREATER 19
-#define LEQ 20
-#define GEQ 21
-#define EQUAL 22
-#define NEQ 23
-#define BIT_AND 24
-#define BIT_XOR 25
-#define BIT_OR 26
-#define AND 27
-#define OR 28
-#define QUESTY 29
-#define COLON 30
+#define MULT 12
+#define DIVIDE 13
+#define MOD 14
+#define PLUS 15
+#define MINUS 16
+#define LEFT_SHIFT 17
+#define RIGHT_SHIFT 18
+#define LESS 19
+#define GREATER 20
+#define LEQ 21
+#define GEQ 22
+#define EQUAL 23
+#define NEQ 24
+#define BIT_AND 25
+#define BIT_XOR 26
+#define BIT_OR 27
+#define AND 28
+#define OR 29
+#define QUESTY 30
+#define COLON 31
/*
* Unary operators. Unary minus and plus are represented by the (binary)
* lexemes MINUS and PLUS.
*/
-#define NOT 31
-#define BIT_NOT 32
+#define NOT 32
+#define BIT_NOT 33
+
+/*
+ * Binary string operators:
+ */
+
+#define STREQ 34
+#define STRNEQ 35
/*
* Mapping from lexemes to strings; used for debugging messages. These
* entries must match the order and number of the lexeme definitions above.
*/
-#ifdef TCL_COMPILE_DEBUG
static char *lexemeStrings[] = {
"LITERAL", "FUNCNAME",
- "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN",
+ "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", "UNKNOWN_CHAR",
"*", "/", "%", "+", "-",
"<<", ">>", "<", ">", "<=", ">=", "==", "!=",
"&", "^", "|", "&&", "||", "?", ":",
- "!", "~"
+ "!", "~", "eq", "ne",
};
-#endif /* TCL_COMPILE_DEBUG */
/*
* Declarations for local procedures to this file:
*/
static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr));
-static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr));
+static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr,
+ CONST char *extraInfo));
static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string,
+ CONST char *end));
static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
-static void PrependSubExprTokens _ANSI_ARGS_((char *op,
- int opBytes, char *src, int srcBytes,
- int firstIndex, ParseInfo *infoPtr));
+static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op,
+ int opBytes, CONST char *src, int srcBytes,
+ int firstIndex, ParseInfo *infoPtr));
/*
* Macro used to debug the execution of the recursive descent parser used
* Given a string, this procedure parses the first Tcl expression
* in the string and returns information about the structure of
* the expression. This procedure is the top-level interface to the
- * the expression parsing module.
+ * the expression parsing module. No more that numBytes bytes will
+ * be scanned.
*
* Results:
* The return value is TCL_OK if the command was parsed successfully
int
Tcl_ParseExpr(interp, string, numBytes, parsePtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to parse. */
+ CONST char *string; /* The source string to parse. */
int numBytes; /* Number of bytes in string. If < 0, the
* string consists of all bytes up to the
* first null character. */
{
ParseInfo info;
int code;
- char savedChar;
if (numBytes < 0) {
numBytes = (string? strlen(string) : 0);
parsePtr->incomplete = 0;
/*
- * Temporarily overwrite the character just after the end of the
- * string with a 0 byte. This acts as a sentinel and reduces the
- * number of places where we have to check for the end of the
- * input string. The original value of the byte is restored at
- * the end of the parse.
- */
-
- savedChar = string[numBytes];
- string[numBytes] = 0;
-
- /*
* Initialize the ParseInfo structure that holds state while parsing
* the expression.
*/
goto error;
}
if (info.lexeme != END) {
- LogSyntaxError(&info);
+ LogSyntaxError(&info, "extra tokens at end of expression");
goto error;
}
- string[numBytes] = (char) savedChar;
return TCL_OK;
error:
- string[numBytes] = (char) savedChar;
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
}
* condExpr ::= lorExpr ['?' condExpr ':' condExpr]
*
* Note that this is the topmost recursive-descent parsing routine used
- * by TclParseExpr to parse expressions. This avoids an extra procedure
+ * by Tcl_ParseExpr to parse expressions. This avoids an extra procedure
* call since such a procedure would only return the result of calling
* ParseCondExpr. Other recursive-descent procedures that need to parse
* complete expressions also call ParseCondExpr.
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
int firstIndex, numToMove, code;
- char *srcStart;
+ CONST char *srcStart;
HERE("condExpr", 1);
srcStart = infoPtr->start;
return code;
}
if (infoPtr->lexeme != COLON) {
- LogSyntaxError(infoPtr);
+ LogSyntaxError(infoPtr, "missing colon from ternary conditional");
return TCL_ERROR;
}
code = GetLexeme(infoPtr); /* skip over the ':' */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("lorExpr", 2);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("landExpr", 3);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("bitOrExpr", 4);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("bitXorExpr", 5);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("bitAndExpr", 6);
srcStart = infoPtr->start;
* ParseEqualityExpr --
*
* This procedure parses a Tcl equality (inequality) expression:
- * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr}
+ * equalityExpr ::= relationalExpr
+ * {('==' | '!=' | 'ne' | 'eq') relationalExpr}
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("equalityExpr", 7);
srcStart = infoPtr->start;
}
lexeme = infoPtr->lexeme;
- while ((lexeme == EQUAL) || (lexeme == NEQ)) {
+ while ((lexeme == EQUAL) || (lexeme == NEQ)
+ || (lexeme == STREQ) || (lexeme == STRNEQ)) {
operator = infoPtr->start;
- code = GetLexeme(infoPtr); /* skip over == or != */
+ code = GetLexeme(infoPtr); /* skip over ==, !=, 'eq' or 'ne' */
if (code != TCL_OK) {
return code;
}
}
/*
- * Generate tokens for the subexpression and '==' or '!=' operator.
+ * Generate tokens for the subexpression and '==', '!=', 'eq' or 'ne'
+ * operator.
*/
PrependSubExprTokens(operator, 2, srcStart,
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, operatorSize, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("relationalExpr", 8);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("shiftExpr", 9);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("addExpr", 10);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("multiplyExpr", 11);
srcStart = infoPtr->start;
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
- char *srcStart, *operator;
+ CONST char *srcStart, *operator;
HERE("unaryExpr", 12);
srcStart = infoPtr->start;
Tcl_Interp *interp = parsePtr->interp;
Tcl_Token *tokenPtr, *exprTokenPtr;
Tcl_Parse nested;
- char *dollarPtr, *stringStart, *termPtr, *src;
+ CONST char *dollarPtr, *stringStart, *termPtr, *src;
int lexeme, exprIndex, firstIndex, numToMove, code;
/*
return code;
}
if (infoPtr->lexeme != CLOSE_PAREN) {
- goto syntaxError;
+ LogSyntaxError(infoPtr, "looking for close parenthesis");
+ return TCL_ERROR;
}
code = GetLexeme(infoPtr); /* skip over the ')' */
if (code != TCL_OK) {
exprTokenPtr->size = infoPtr->size;
exprTokenPtr->numComponents = 1;
break;
-
+
case DOLLAR:
/*
* $var variable reference.
return code;
}
if (infoPtr->lexeme != OPEN_PAREN) {
- goto syntaxError;
+ /*
+ * Guess what kind of error we have by trying to tell
+ * whether we have a function or variable name here.
+ * Alas, this makes the parser more tightly bound with the
+ * rest of the interpreter, but that is the only way to
+ * give a sensible message here. Still, it is not too
+ * serious as this is only done when generating an error.
+ */
+ Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
+ Tcl_DString functionName;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ * Look up the name as a function name. We need a writable
+ * copy (DString) so we can terminate it with a NULL for
+ * the benefit of Tcl_FindHashEntry which operates on
+ * NULL-terminated string keys.
+ */
+ Tcl_DStringInit(&functionName);
+ hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
+ Tcl_DStringAppend(&functionName, tokenPtr->start,
+ tokenPtr->size));
+ Tcl_DStringFree(&functionName);
+
+ /*
+ * Assume that we have an attempted variable reference
+ * unless we've got a function name, as the set of
+ * potential function names is typically much smaller.
+ */
+ if (hPtr != NULL) {
+ LogSyntaxError(infoPtr,
+ "expected parenthesis enclosing function arguments");
+ } else {
+ LogSyntaxError(infoPtr,
+ "variable references require preceding $");
+ }
+ return TCL_ERROR;
}
code = GetLexeme(infoPtr); /* skip over '(' */
if (code != TCL_OK) {
return code;
}
} else if (infoPtr->lexeme != CLOSE_PAREN) {
- goto syntaxError;
+ LogSyntaxError(infoPtr,
+ "missing close parenthesis at end of function call");
+ return TCL_ERROR;
}
}
exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
break;
-
- default:
- goto syntaxError;
+
+ case COMMA:
+ LogSyntaxError(infoPtr,
+ "commas can only separate function arguments");
+ return TCL_ERROR;
+ case END:
+ LogSyntaxError(infoPtr, "premature end of expression");
+ return TCL_ERROR;
+ case UNKNOWN:
+ LogSyntaxError(infoPtr, "single equality character not legal in expressions");
+ return TCL_ERROR;
+ case UNKNOWN_CHAR:
+ LogSyntaxError(infoPtr, "character not legal in expressions");
+ return TCL_ERROR;
+ case QUESTY:
+ LogSyntaxError(infoPtr, "unexpected ternary 'then' separator");
+ return TCL_ERROR;
+ case COLON:
+ LogSyntaxError(infoPtr, "unexpected ternary 'else' separator");
+ return TCL_ERROR;
+ case CLOSE_PAREN:
+ LogSyntaxError(infoPtr, "unexpected close parenthesis");
+ return TCL_ERROR;
+
+ default: {
+ char buf[64];
+
+ sprintf(buf, "unexpected operator %s", lexemeStrings[lexeme]);
+ LogSyntaxError(infoPtr, buf);
+ return TCL_ERROR;
+ }
}
/*
}
parsePtr->term = infoPtr->next;
return TCL_OK;
-
- syntaxError:
- LogSyntaxError(infoPtr);
- return TCL_ERROR;
}
\f
/*
ParseInfo *infoPtr; /* Holds state needed to parse the expr,
* including the resulting lexeme. */
{
- register char *src; /* Points to current source char. */
- char *termPtr; /* Points to char terminating a literal. */
- double doubleValue; /* Value of a scanned double literal. */
+ register CONST char *src; /* Points to current source char. */
char c;
- int startsWithDigit, offset;
+ int offset, length, numBytes;
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Interp *interp = parsePtr->interp;
Tcl_UniChar ch;
infoPtr->prevEnd = infoPtr->next;
/*
- * Scan over leading white space at the start of a lexeme. Note that a
- * backslash-newline is treated as a space.
+ * Scan over leading white space at the start of a lexeme.
*/
src = infoPtr->next;
- c = *src;
- while (isspace(UCHAR(c)) || (c == '\\')) { /* INTL: ISO space */
- if (c == '\\') {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break; /* no longer white space */
- }
- } else {
- src++;
- }
- c = *src;
- }
+ numBytes = parsePtr->end - src;
+ do {
+ char type;
+ int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
+ src += scanned; numBytes -= scanned;
+ } while (numBytes && (*src == '\n') && (src++,numBytes--));
parsePtr->term = src;
- if (src >= infoPtr->lastChar) {
+ if (numBytes == 0) {
infoPtr->lexeme = END;
infoPtr->next = src;
return TCL_OK;
* by mistake, which would eventually cause a syntax error.
*/
+ c = *src;
if ((c != '+') && (c != '-')) {
- startsWithDigit = isdigit(UCHAR(c)); /* INTL: digit */
- if (startsWithDigit && TclLooksLikeInt(src, -1)) {
- errno = 0;
- (void) strtoul(src, &termPtr, 0);
- if (errno == ERANGE) {
- if (interp != NULL) {
- char *s = "integer value too large to represent";
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s,
- (char *) NULL);
- }
+ CONST char *end = infoPtr->lastChar;
+ if ((length = TclParseInteger(src, (end - src)))) {
+ /*
+ * First length bytes look like an integer. Verify by
+ * attempting the conversion to the largest integer we have.
+ */
+ int code;
+ Tcl_WideInt wide;
+ Tcl_Obj *value = Tcl_NewStringObj(src, length);
+
+ Tcl_IncrRefCount(value);
+ code = Tcl_GetWideIntFromObj(interp, value, &wide);
+ Tcl_DecrRefCount(value);
+ if (code == TCL_ERROR) {
parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
return TCL_ERROR;
}
- if (termPtr != src) {
- /*
- * src was the start of a valid integer, but was it
- * a bad octal? Stopping at a digit would cause that.
- */
- if (isdigit(UCHAR(*termPtr))) { /* INTL: digit. */
- /*
- * We only want to report an error for the number,
- * but we may have something like "08+1"
- */
- if (interp != NULL) {
- while (isdigit(UCHAR(*(++termPtr)))) {} /* INTL: digit. */
- Tcl_ResetResult(interp);
- offset = termPtr - src;
- c = src[offset];
- src[offset] = 0;
- Tcl_AppendResult(interp, "\"", src,
- "\" is an invalid octal number",
- (char *) NULL);
- src[offset] = c;
- }
- parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
- return TCL_ERROR;
- }
+ infoPtr->lexeme = LITERAL;
+ infoPtr->start = src;
+ infoPtr->size = length;
+ infoPtr->next = (src + length);
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+ } else if ((length = ParseMaxDoubleLength(src, end))) {
+ /*
+ * There are length characters that could be a double.
+ * Let strtod() tells us for sure. Need a writable copy
+ * so we can set an terminating NULL to keep strtod from
+ * scanning too far.
+ */
+ char *startPtr, *termPtr;
+ double doubleValue;
+ Tcl_DString toParse;
- infoPtr->lexeme = LITERAL;
- infoPtr->start = src;
- infoPtr->size = (termPtr - src);
- infoPtr->next = termPtr;
- parsePtr->term = termPtr;
- return TCL_OK;
- }
- } else if (startsWithDigit || (c == '.')
- || (c == 'n') || (c == 'N')) {
errno = 0;
- doubleValue = strtod(src, &termPtr);
- if (termPtr != src) {
+ Tcl_DStringInit(&toParse);
+ startPtr = Tcl_DStringAppend(&toParse, src, length);
+ doubleValue = strtod(startPtr, &termPtr);
+ Tcl_DStringFree(&toParse);
+ if (termPtr != startPtr) {
if (errno != 0) {
if (interp != NULL) {
TclExprFloatError(interp, doubleValue);
}
/*
- * src was the start of a valid double.
+ * startPtr was the start of a valid double, copied
+ * from src.
*/
infoPtr->lexeme = LITERAL;
infoPtr->start = src;
- infoPtr->size = (termPtr - src);
- infoPtr->next = termPtr;
- parsePtr->term = termPtr;
+ if ((termPtr - startPtr) > length) {
+ infoPtr->size = length;
+ } else {
+ infoPtr->size = (termPtr - startPtr);
+ }
+ infoPtr->next = src + infoPtr->size;
+ parsePtr->term = infoPtr->next;
return TCL_OK;
}
}
return TCL_OK;
case '<':
- switch (src[1]) {
- case '<':
- infoPtr->lexeme = LEFT_SHIFT;
- infoPtr->size = 2;
- infoPtr->next = src+2;
- break;
- case '=':
- infoPtr->lexeme = LEQ;
- infoPtr->size = 2;
- infoPtr->next = src+2;
- break;
- default:
- infoPtr->lexeme = LESS;
- break;
+ infoPtr->lexeme = LESS;
+ if ((infoPtr->lastChar - src) > 1) {
+ switch (src[1]) {
+ case '<':
+ infoPtr->lexeme = LEFT_SHIFT;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ case '=':
+ infoPtr->lexeme = LEQ;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ }
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '>':
- switch (src[1]) {
- case '>':
- infoPtr->lexeme = RIGHT_SHIFT;
- infoPtr->size = 2;
- infoPtr->next = src+2;
- break;
- case '=':
- infoPtr->lexeme = GEQ;
- infoPtr->size = 2;
- infoPtr->next = src+2;
- break;
- default:
- infoPtr->lexeme = GREATER;
- break;
+ infoPtr->lexeme = GREATER;
+ if ((infoPtr->lastChar - src) > 1) {
+ switch (src[1]) {
+ case '>':
+ infoPtr->lexeme = RIGHT_SHIFT;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ case '=':
+ infoPtr->lexeme = GEQ;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ }
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '=':
- if (src[1] == '=') {
+ infoPtr->lexeme = UNKNOWN;
+ if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = EQUAL;
infoPtr->size = 2;
infoPtr->next = src+2;
- } else {
- infoPtr->lexeme = UNKNOWN;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '!':
- if (src[1] == '=') {
+ infoPtr->lexeme = NOT;
+ if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = NEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
- } else {
- infoPtr->lexeme = NOT;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '&':
- if (src[1] == '&') {
+ infoPtr->lexeme = BIT_AND;
+ if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = AND;
infoPtr->size = 2;
infoPtr->next = src+2;
- } else {
- infoPtr->lexeme = BIT_AND;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
return TCL_OK;
case '|':
- if (src[1] == '|') {
+ infoPtr->lexeme = BIT_OR;
+ if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = OR;
infoPtr->size = 2;
infoPtr->next = src+2;
- } else {
- infoPtr->lexeme = BIT_OR;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
infoPtr->lexeme = BIT_NOT;
return TCL_OK;
+ case 'e':
+ if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1)) {
+ infoPtr->lexeme = STREQ;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+ } else {
+ goto checkFuncName;
+ }
+
+ case 'n':
+ if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1)) {
+ infoPtr->lexeme = STRNEQ;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+ } else {
+ goto checkFuncName;
+ }
+
default:
- offset = Tcl_UtfToUniChar(src, &ch);
+ checkFuncName:
+ length = (infoPtr->lastChar - src);
+ if (Tcl_UtfCharComplete(src, length)) {
+ offset = Tcl_UtfToUniChar(src, &ch);
+ } else {
+ char utfBytes[TCL_UTF_MAX];
+ memcpy(utfBytes, src, (size_t) length);
+ utfBytes[length] = '\0';
+ offset = Tcl_UtfToUniChar(utfBytes, &ch);
+ }
c = UCHAR(ch);
if (isalpha(UCHAR(c))) { /* INTL: ISO only. */
infoPtr->lexeme = FUNC_NAME;
while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
- src += offset;
- offset = Tcl_UtfToUniChar(src, &ch);
+ src += offset; length -= offset;
+ if (Tcl_UtfCharComplete(src, length)) {
+ offset = Tcl_UtfToUniChar(src, &ch);
+ } else {
+ char utfBytes[TCL_UTF_MAX];
+ memcpy(utfBytes, src, (size_t) length);
+ utfBytes[length] = '\0';
+ offset = Tcl_UtfToUniChar(utfBytes, &ch);
+ }
c = UCHAR(ch);
}
infoPtr->size = (src - infoPtr->start);
infoPtr->next = src;
parsePtr->term = infoPtr->next;
+ /*
+ * Check for boolean literals (true, false, yes, no, on, off)
+ */
+ switch (infoPtr->start[0]) {
+ case 'f':
+ if (infoPtr->size == 5 &&
+ strncmp("false", infoPtr->start, 5) == 0) {
+ infoPtr->lexeme = LITERAL;
+ return TCL_OK;
+ }
+ break;
+ case 'n':
+ if (infoPtr->size == 2 &&
+ strncmp("no", infoPtr->start, 2) == 0) {
+ infoPtr->lexeme = LITERAL;
+ return TCL_OK;
+ }
+ break;
+ case 'o':
+ if (infoPtr->size == 3 &&
+ strncmp("off", infoPtr->start, 3) == 0) {
+ infoPtr->lexeme = LITERAL;
+ return TCL_OK;
+ } else if (infoPtr->size == 2 &&
+ strncmp("on", infoPtr->start, 2) == 0) {
+ infoPtr->lexeme = LITERAL;
+ return TCL_OK;
+ }
+ break;
+ case 't':
+ if (infoPtr->size == 4 &&
+ strncmp("true", infoPtr->start, 4) == 0) {
+ infoPtr->lexeme = LITERAL;
+ return TCL_OK;
+ }
+ break;
+ case 'y':
+ if (infoPtr->size == 3 &&
+ strncmp("yes", infoPtr->start, 3) == 0) {
+ infoPtr->lexeme = LITERAL;
+ return TCL_OK;
+ }
+ break;
+ }
return TCL_OK;
}
- infoPtr->lexeme = UNKNOWN;
+ infoPtr->lexeme = UNKNOWN_CHAR;
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
+ * TclParseInteger --
+ *
+ * Scans up to numBytes bytes starting at src, and checks whether
+ * the leading bytes look like an integer's string representation.
+ *
+ * Results:
+ * Returns 0 if the leading bytes do not look like an integer.
+ * Otherwise, returns the number of bytes examined that look
+ * like an integer. This may be less than numBytes if the integer
+ * is only the leading part of the string.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclParseInteger(string, numBytes)
+ register CONST char *string;/* The string to examine. */
+ register int numBytes; /* Max number of bytes to scan. */
+{
+ register CONST char *p = string;
+
+ /* Take care of introductory "0x" */
+ if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
+ int scanned;
+ Tcl_UniChar ch;
+ p+=2; numBytes -= 2;
+ scanned = TclParseHex(p, numBytes, &ch);
+ if (scanned) {
+ return scanned + 2;
+ }
+ return 0;
+ }
+ while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */
+ numBytes--; p++;
+ }
+ if (numBytes == 0) {
+ return (p - string);
+ }
+ if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
+ return (p - string);
+ }
+ return 0;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseMaxDoubleLength --
+ *
+ * Scans a sequence of bytes checking that the characters could
+ * be in a string rep of a double.
+ *
+ * Results:
+ * Returns the number of bytes starting with string, runing to, but
+ * not including end, all of which could be part of a string rep.
+ * of a double. Only character identity is used, no actual
+ * parsing is done.
+ *
+ * The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f',
+ * '.', '+', '-', 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'.
+ * This covers the values "Inf" and "Nan" as well as the
+ * decimal and hexadecimal representations recognized by a
+ * C99-compliant strtod().
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseMaxDoubleLength(string, end)
+ register CONST char *string;/* The string to examine. */
+ CONST char *end; /* Point to the first character past the end
+ * of the string we are examining. */
+{
+ CONST char *p = string;
+ while (p < end) {
+ switch (*p) {
+ case '0': case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9': case 'A': case 'B':
+ case 'C': case 'D': case 'E': case 'F': case 'I': case 'N':
+ case 'P': case 'X': case 'a': case 'b': case 'c': case 'd':
+ case 'e': case 'f': case 'i': case 'n': case 'p': case 'x':
+ case '.': case '+': case '-':
+ p++;
+ break;
+ default:
+ goto done;
+ }
+ }
+ done:
+ return (p - string);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* PrependSubExprTokens --
*
* This procedure is called after the operands of an subexpression have
static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
- char *op; /* Points to first byte of the operator
+ CONST char *op; /* Points to first byte of the operator
* in the source script. */
int opBytes; /* Number of bytes in the operator. */
- char *src; /* Points to first byte of the subexpression
+ CONST char *src; /* Points to first byte of the subexpression
* in the source script. */
int srcBytes; /* Number of bytes in subexpression's
* source. */
*
* Side effects:
* Sets the interpreter result to an error message describing the
- * expression that was being parsed when the error occurred.
+ * expression that was being parsed when the error occurred, and why
+ * the parser considers that to be a syntax error at all.
*
*----------------------------------------------------------------------
*/
static void
-LogSyntaxError(infoPtr)
+LogSyntaxError(infoPtr, extraInfo)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
+ CONST char *extraInfo; /* String to provide extra information
+ * about the syntax error. */
{
int numBytes = (infoPtr->lastChar - infoPtr->originalExpr);
char buffer[100];
- sprintf(buffer, "syntax error in expression \"%.*s\"",
- ((numBytes > 60)? 60 : numBytes), infoPtr->originalExpr);
+ if (numBytes > 60) {
+ sprintf(buffer, "syntax error in expression \"%.60s...\"",
+ infoPtr->originalExpr);
+ } else {
+ sprintf(buffer, "syntax error in expression \"%.*s\"",
+ numBytes, infoPtr->originalExpr);
+ }
+ Tcl_ResetResult(infoPtr->parsePtr->interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp),
- buffer, (char *) NULL);
+ buffer, ": ", extraInfo, (char *) NULL);
infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
infoPtr->parsePtr->term = infoPtr->start;
}
+++ /dev/null
-/*
- * tclPatch.h --
- *
- * This file does nothing except define a "patch level" for Tcl.
- * The patch level has the form "X.YpZ" where X.Y is the base
- * release, and Z is a serial number that is used to sequence
- * patches for a given release. Thus 7.4p1 is the first patch
- * to release 7.4, 7.4p2 is the patch that follows 7.4p1, and
- * so on. The "pZ" is omitted in an original new release, and
- * it is replaced with "bZ" for beta releases or "aZ for alpha
- * releases. The patch level ensures that patches are applied
- * in the correct order and only to appropriate sources.
- *
- * Copyright (c) 1993-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclPatch.h 1.23 96/10/02 14:36:15
- */
-
-#define TCL_PATCH_LEVEL "7.6"
*/
static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp,
- char *spec, int atOk, char *arg, char *nextArg,
- int flags, int *skipPtr, int *closePtr, int *releasePtr));
+ CONST char *spec, int atOk, CONST char *arg,
+ CONST char *nextArg, int flags, int *skipPtr,
+ int *closePtr, int *releasePtr));
\f
/*
*----------------------------------------------------------------------
FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr,
releasePtr)
Tcl_Interp *interp; /* Intepreter to use for error reporting. */
- char *spec; /* Points to character just after
+ CONST char *spec; /* Points to character just after
* redirection character. */
- char *arg; /* Pointer to entire argument containing
+ CONST char *arg; /* Pointer to entire argument containing
* spec: used for error reporting. */
int atOK; /* Non-zero means that '@' notation can be
* used to specify a channel, zero means that
* it isn't. */
- char *nextArg; /* Next argument in argc/argv array, if needed
+ CONST char *nextArg; /* Next argument in argc/argv array, if needed
* for file name or channel name. May be
* NULL. */
int flags; /* Flags to use for opening file or to
Tcl_Flush(chan);
}
} else {
- char *name;
+ CONST char *name;
Tcl_DString nameString;
if (*spec == '\0') {
int i, abnormalExit, anyErrorInfo;
Tcl_Pid pid;
WAIT_STATUS_TYPE waitStatus;
- char *msg;
+ CONST char *msg;
abnormalExit = 0;
for (i = 0; i < numPids; i++) {
abnormalExit = 1;
} else if (WIFSIGNALED(waitStatus)) {
if (interp != (Tcl_Interp *) NULL) {
- char *p;
+ CONST char *p;
p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus)));
Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
}
} else if (WIFSTOPPED(waitStatus)) {
if (interp != (Tcl_Interp *) NULL) {
- char *p;
+ CONST char *p;
p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus)));
Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
int count;
Tcl_Obj *objPtr;
- Tcl_Seek(errorChan, 0L, SEEK_SET);
+ Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET);
objPtr = Tcl_NewObj();
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
if (count < 0) {
outPipePtr, errFilePtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting. */
int argc; /* Number of entries in argv. */
- char **argv; /* Array of strings describing commands in
+ CONST char **argv; /* Array of strings describing commands in
* pipeline plus I/O redirection with <,
* <<, >, etc. Argv[argc] must be NULL. */
Tcl_Pid **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with
* at *pidPtr right now. */
int cmdCount; /* Count of number of distinct commands
* found in argc/argv. */
- char *inputLiteral = NULL; /* If non-null, then this points to a
+ CONST char *inputLiteral = NULL; /* If non-null, then this points to a
* string containing input data (specified
* via <<) to be piped to the first process
* in the pipeline. */
int errorClose = 0; /* If non-zero, then errorFile should be
* closed when cleaning up. */
int errorRelease = 0;
- char *p;
+ CONST char *p;
int skip, lastBar, lastArg, i, j, atOK, flags, errorToOutput;
Tcl_DString execBuffer;
TclFile pipeIn;
for (i = 0; i < argc; i = lastArg + 1) {
int result, joinThisError;
Tcl_Pid pid;
- char *oldName;
+ CONST char *oldName;
/*
* Convert the program name into native form.
Tcl_Interp *interp; /* Interpreter for error reporting. Can
* NOT be NULL. */
int argc; /* How many arguments. */
- char **argv; /* Array of arguments for command pipe. */
+ CONST char **argv; /* Array of arguments for command pipe. */
int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT,
* TCL_STDERR, and TCL_ENFORCE_MODE. */
{
*/
static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
- char *string));
-static int ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2,
+ CONST char *string));
+static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1,
+ CONST char *v2,
int *satPtr));
static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
- char *name));
+ CONST char *name));
\f
/*
*----------------------------------------------------------------------
Tcl_PkgProvide(interp, name, version)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
- char *name; /* Name of package. */
- char *version; /* Version string for package. */
+ CONST char *name; /* Name of package. */
+ CONST char *version; /* Version string for package. */
{
return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
}
Tcl_PkgProvideEx(interp, name, version, clientData)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
- char *name; /* Name of package. */
- char *version; /* Version string for package. */
+ CONST char *name; /* Name of package. */
+ CONST char *version; /* Version string for package. */
ClientData clientData; /* clientdata for this package (normally
* used for C callback function table) */
{
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_PkgRequire(interp, name, version, exact)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
- char *name; /* Name of desired package. */
- char *version; /* Version string for desired version;
+ CONST char *name; /* Name of desired package. */
+ CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
}
-char *
+CONST char *
Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
- char *name; /* Name of desired package. */
- char *version; /* Version string for desired version;
+ CONST char *name; /* Name of desired package. */
+ CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
Tcl_DString command;
/*
- * If an attempt is being made to load this into a standalong executable
+ * If an attempt is being made to load this into a standalone executable
* on a platform where backlinking is not supported then this must be
* a shared version of Tcl (Otherwise the load would have failed).
* Detect this situation by checking that this library has been correctly
* work.
*/
- if (!tclEmptyStringRep) {
+ if (tclEmptyStringRep == NULL) {
+
+ /*
+ * OK, so what's going on here?
+ *
+ * First, what are we doing? We are performing a check on behalf of
+ * one particular caller, Tcl_InitStubs(). When a package is
+ * stub-enabled, it is statically linked to libtclstub.a, which
+ * contains a copy of Tcl_InitStubs(). When a stub-enabled package
+ * is loaded, its *_Init() function is supposed to call
+ * Tcl_InitStubs() before calling any other functions in the Tcl
+ * library. The first Tcl function called by Tcl_InitStubs() through
+ * the stub table is Tcl_PkgRequireEx(), so this code right here is
+ * the first code that is part of the original Tcl library in the
+ * executable that gets executed on behalf of a newly loaded
+ * stub-enabled package.
+ *
+ * One easy error for the developer/builder of a stub-enabled package
+ * to make is to forget to define USE_TCL_STUBS when compiling the
+ * package. When that happens, the package will contain symbols
+ * that are references to the Tcl library, rather than function
+ * pointers referencing the stub table. On platforms that lack
+ * backlinking, those unresolved references may cause the loading
+ * of the package to also load a second copy of the Tcl library,
+ * leading to all kinds of trouble. We would like to catch that
+ * error and report a useful message back to the user. That's
+ * what we're doing.
+ *
+ * Second, how does this work? If we reach this point, then the
+ * global variable tclEmptyStringRep has the value NULL. Compare
+ * that with the definition of tclEmptyStringRep near the top of
+ * the file generic/tclObj.c. It clearly should not have the value
+ * NULL; it should point to the char tclEmptyString. If we see it
+ * having the value NULL, then somehow we are seeing a Tcl library
+ * that isn't completely initialized, and that's an indicator for the
+ * error condition described above. (Further explanation is welcome.)
+ *
+ * Third, so what do we do about it? This situation indicates
+ * the package we just loaded wasn't properly compiled to be
+ * stub-enabled, yet it thinks it is stub-enabled (it called
+ * Tcl_InitStubs()). We want to report that the package just
+ * loaded is broken, so we want to place an error message in
+ * the interpreter result and return NULL to indicate failure
+ * to Tcl_InitStubs() so that it will also fail. (Further
+ * explanation why we don't want to Tcl_Panic() is welcome.
+ * After all, two Tcl libraries can't be a good thing!)
+ *
+ * Trouble is that's going to be tricky. We're now using a Tcl
+ * library that's not fully initialized. In particular, it
+ * doesn't have a proper value for tclEmptyStringRep. The
+ * Tcl_Obj system heavily depends on the value of tclEmptyStringRep
+ * and all of Tcl depends (increasingly) on the Tcl_Obj system, we
+ * need to correct that flaw before making the calls to set the
+ * interpreter result to the error message. That's the only flaw
+ * corrected; other problems with initialization of the Tcl library
+ * are not remedied, so be very careful about adding any other calls
+ * here without checking how they behave when initialization is
+ * incomplete.
+ */
+
+ tclEmptyStringRep = &tclEmptyString;
Tcl_AppendResult(interp, "Cannot load package \"", name,
"\" in standalone executable: This package is not ",
"compiled with stub support", NULL);
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_PkgPresent(interp, name, version, exact)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
- char *name; /* Name of desired package. */
- char *version; /* Version string for desired version;
+ CONST char *name; /* Name of desired package. */
+ CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
}
-char *
+CONST char *
Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
- char *name; /* Name of desired package. */
- char *version; /* Version string for desired version;
+ CONST char *name; /* Name of desired package. */
+ CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
Package *pkgPtr;
int satisfies, result;
- /*
- * If an attempt is being made to load this into a standalone executable
- * on a platform where backlinking is not supported then this must be
- * a shared version of Tcl (Otherwise the load would have failed).
- * Detect this situation by checking that this library has been correctly
- * initialised. If it has not been then return immediately as nothing will
- * work.
- */
-
- if (!tclEmptyStringRep) {
- Tcl_AppendResult(interp, "Cannot load package \"", name,
- "\" in standalone executable: This package is not ",
- "compiled with stub support", NULL);
- return NULL;
- }
-
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- static char *pkgOptions[] = {
+ static CONST char *pkgOptions[] = {
"forget", "ifneeded", "names", "present", "provide", "require",
"unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
};
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *tablePtr;
- char *version, *argv2, *argv3, *argv4;
+ CONST char *version;
+ char *argv2, *argv3, *argv4;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
keyString = Tcl_GetString(objv[i]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
- return TCL_OK;
+ continue;
}
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (version == NULL) {
return TCL_ERROR;
}
- Tcl_SetResult(interp, version, TCL_VOLATILE);
+ Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
break;
}
case PKG_PROVIDE: {
if (version == NULL) {
return TCL_ERROR;
}
- Tcl_SetResult(interp, version, TCL_VOLATILE);
+ Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
break;
}
case PKG_UNKNOWN: {
static Package *
FindPackage(interp, name)
Tcl_Interp *interp; /* Interpreter to use for package lookup. */
- char *name; /* Name of package to fine. */
+ CONST char *name; /* Name of package to fine. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
static int
CheckVersion(interp, string)
Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* Supposedly a version number, which is
+ CONST char *string; /* Supposedly a version number, which is
* groups of decimal digits separated
* by dots. */
{
- char *p = string;
+ CONST char *p = string;
char prevChar;
if (!isdigit(UCHAR(*p))) { /* INTL: digit */
static int
ComparePkgVersions(v1, v2, satPtr)
- char *v1, *v2; /* Versions strings, of form 2.1.3 (any
+ CONST char *v1;
+ CONST char *v2; /* Versions strings, of form 2.1.3 (any
* number of version numbers). */
int *satPtr; /* If non-null, the word pointed to is
* filled in with a 0/1 value. 1 means
#ifndef _TCLPLATDECLS
#define _TCLPLATDECLS
+/*
+ * Pull in the typedef of TCHAR for windows.
+ */
+#if defined(__CYGWIN__)
+ typedef char TCHAR;
+#elif defined(__WIN32__) && !defined(_TCHAR_DEFINED)
+# include <tchar.h>
+# ifndef _TCHAR_DEFINED
+ /* Borland seems to forget to set this. */
+ typedef _TCHAR TCHAR;
+# define _TCHAR_DEFINED
+# endif
+# if defined(_MSC_VER) && defined(__STDC__)
+ /* MSVC++ misses this. */
+ typedef _TCHAR TCHAR;
+# endif
+#endif
+
/* !BEGIN!: Do not edit below this line. */
/*
Handle resource));
/* 2 */
EXTERN int Tcl_MacEvalResource _ANSI_ARGS_((Tcl_Interp * interp,
- char * resourceName, int resourceNumber,
- char * fileName));
+ CONST char * resourceName,
+ int resourceNumber, CONST char * fileName));
/* 3 */
EXTERN Handle Tcl_MacFindResource _ANSI_ARGS_((Tcl_Interp * interp,
- long resourceType, char * resourceName,
- int resourceNumber, char * resFileRef,
+ long resourceType, CONST char * resourceName,
+ int resourceNumber, CONST char * resFileRef,
int * releaseIt));
/* 4 */
EXTERN int Tcl_GetOSTypeFromObj _ANSI_ARGS_((
EXTERN int strcasecmp _ANSI_ARGS_((CONST char * s1,
CONST char * s2));
#endif /* MAC_TCL */
+#ifdef MAC_OSX_TCL
+/* 0 */
+EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * bundleName,
+ int hasResourceFile, int maxPathLen,
+ char * libraryPath));
+#endif /* MAC_OSX_TCL */
typedef struct TclPlatStubs {
int magic;
#ifdef MAC_TCL
void (*tcl_MacSetEventProc) _ANSI_ARGS_((Tcl_MacConvertEventPtr procPtr)); /* 0 */
char * (*tcl_MacConvertTextResource) _ANSI_ARGS_((Handle resource)); /* 1 */
- int (*tcl_MacEvalResource) _ANSI_ARGS_((Tcl_Interp * interp, char * resourceName, int resourceNumber, char * fileName)); /* 2 */
- Handle (*tcl_MacFindResource) _ANSI_ARGS_((Tcl_Interp * interp, long resourceType, char * resourceName, int resourceNumber, char * resFileRef, int * releaseIt)); /* 3 */
+ int (*tcl_MacEvalResource) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * resourceName, int resourceNumber, CONST char * fileName)); /* 2 */
+ Handle (*tcl_MacFindResource) _ANSI_ARGS_((Tcl_Interp * interp, long resourceType, CONST char * resourceName, int resourceNumber, CONST char * resFileRef, int * releaseIt)); /* 3 */
int (*tcl_GetOSTypeFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, OSType * osTypePtr)); /* 4 */
void (*tcl_SetOSTypeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, OSType osType)); /* 5 */
Tcl_Obj * (*tcl_NewOSTypeObj) _ANSI_ARGS_((OSType osType)); /* 6 */
int (*strncasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 7 */
int (*strcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2)); /* 8 */
#endif /* MAC_TCL */
+#ifdef MAC_OSX_TCL
+ int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 0 */
+#endif /* MAC_OSX_TCL */
} TclPlatStubs;
#ifdef __cplusplus
(tclPlatStubsPtr->strcasecmp) /* 8 */
#endif
#endif /* MAC_TCL */
+#ifdef MAC_OSX_TCL
+#ifndef Tcl_MacOSXOpenBundleResources
+#define Tcl_MacOSXOpenBundleResources \
+ (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */
+#endif
+#endif /* MAC_OSX_TCL */
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
# include "../win/tclWinPort.h"
#else
# if defined(MAC_TCL)
-# include "tclMacPort.h"
-# else
-# include "../unix/tclUnixPort.h"
-# endif
+# include "tclMacPort.h"
+# else
+# include "../unix/tclUnixPort.h"
+# endif
#endif
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(LLONG_MIN)
+# ifdef LLONG_BIT
+# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1)))
+# else
+/* Assume we're on a system with a 64-bit 'long long' type */
+# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63))
+# endif
+/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */
+# define LLONG_MAX (~LLONG_MIN)
+#endif
+
+
#endif /* _TCLPORT */
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_ErrnoId()
{
switch (errno) {
#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "EOPNOTSUPP";
#endif
+#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) )
+ case EOVERFLOW: return "EOVERFLOW";
+#endif
#ifdef EPERM
case EPERM: return "EPERM";
#endif
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_ErrnoMsg(err)
int err; /* Error number (such as in errno variable). */
{
#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "operation not supported on socket";
#endif
+#if defined(EOVERFLOW) && ( !defined(EFBIG) || (EOVERFLOW != EFBIG) ) && ( !defined(EINVAL) || (EOVERFLOW != EINVAL) )
+ case EOVERFLOW: return "file too big";
+#endif
#ifdef EPERM
case EPERM: return "not owner";
#endif
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_SignalId(sig)
int sig; /* Number of signal. */
{
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_SignalMsg(sig)
int sig; /* Number of signal. */
{
}
return "unknown signal";
}
-
static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
char *procName, int nameLen, int returnCode));
+static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
* The ProcBodyObjType type
{
register Interp *iPtr = (Interp *) interp;
Proc *procPtr;
- char *fullName, *procName;
+ char *fullName;
+ CONST char *procName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
Tcl_DString ds;
procPtr->cmdPtr = (Command *) cmd;
+
+ /*
+ * Optimize for noop procs: if the body is not precompiled (like a TclPro
+ * procbody), and the argument list is just "args" and the body is empty,
+ * define a compileProc to compile a noop.
+ *
+ * Notes:
+ * - cannot be done for any argument list without having different
+ * compiled/not-compiled behaviour in the "wrong argument #" case,
+ * or making this code much more complicated. In any case, it doesn't
+ * seem to make a lot of sense to verify the number of arguments we
+ * are about to ignore ...
+ * - could be enhanced to handle also non-empty bodies that contain
+ * only comments; however, parsing the body will slow down the
+ * compilation of all procs whose argument list is just _args_ */
+
+ if (objv[3]->typePtr == &tclProcBodyType) {
+ goto done;
+ }
+
+ procArgs = Tcl_GetString(objv[2]);
+
+ while (*procArgs == ' ') {
+ procArgs++;
+ }
+
+ if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
+ procArgs +=4;
+ while(*procArgs != '\0') {
+ if (*procArgs != ' ') {
+ goto done;
+ }
+ procArgs++;
+ }
+
+ /*
+ * The argument list is just "args"; check the body
+ */
+
+ procBody = Tcl_GetString(objv[3]);
+ while (*procBody != '\0') {
+ if (!isspace(UCHAR(*procBody))) {
+ goto done;
+ }
+ procBody++;
+ }
+
+ /*
+ * The body is just spaces: link the compileProc
+ */
+
+ ((Command *) cmd)->compileProc = TclCompileNoOp;
+ }
+
+ done:
return TCL_OK;
}
\f
TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
Tcl_Interp *interp; /* interpreter containing proc */
Namespace *nsPtr; /* namespace containing this proc */
- char *procName; /* unqualified name of this proc */
+ CONST char *procName; /* unqualified name of this proc */
Tcl_Obj *argsPtr; /* description of arguments */
Tcl_Obj *bodyPtr; /* command body */
Proc **procPtrPtr; /* returns: pointer to proc data */
{
Interp *iPtr = (Interp*)interp;
- char **argArray = NULL;
+ CONST char **argArray = NULL;
register Proc *procPtr;
int i, length, result, numArgs;
- char *args, *bytes, *p;
+ CONST char *args, *bytes, *p;
register CompiledLocal *localPtr = NULL;
Tcl_Obj *defPtr;
int precompiled = 0;
}
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength, valueLength;
- char **fieldValues;
+ CONST char **fieldValues;
/*
* Now divide the specifier up into name and default.
p = fieldValues[0];
while (*p != '\0') {
if (*p == '(') {
- char *q = p;
+ CONST char *q = p;
do {
q++;
} while (*q != '\0');
ckfree((char *) fieldValues);
goto procError;
}
+ } else if ((*p == ':') && (*(p+1) == ':')) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "procedure \"", procName,
+ "\" has formal parameter \"", fieldValues[0],
+ "\" that is not a simple name",
+ (char *) NULL);
+ ckfree((char *) fieldValues);
+ goto procError;
}
p++;
}
- if (precompiled) {
- /*
- * compare the parsed argument with the stored one
- */
-
- if ((localPtr->nameLength != nameLength)
- || (strcmp(localPtr->name, fieldValues[0]))
- || (localPtr->frameIndex != i)
- || (localPtr->flags != (VAR_SCALAR | VAR_ARGUMENT))
- || ((localPtr->defValuePtr == NULL)
- && (fieldCount == 2))
- || ((localPtr->defValuePtr != NULL)
- && (fieldCount != 2))) {
- char buf[80 + TCL_INTEGER_SPACE];
- sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
- i);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "procedure \"", procName,
- buf, (char *) NULL);
- ckfree((char *) fieldValues);
- goto procError;
- }
+ if (precompiled) {
+ /*
+ * Compare the parsed argument with the stored one.
+ * For the flags, we and out VAR_UNDEFINED to support bridging
+ * precompiled <= 8.3 code in 8.4 where this is now used as an
+ * optimization indicator. Yes, this is a hack. -- hobbs
+ */
+
+ if ((localPtr->nameLength != nameLength)
+ || (strcmp(localPtr->name, fieldValues[0]))
+ || (localPtr->frameIndex != i)
+ || ((localPtr->flags & ~VAR_UNDEFINED)
+ != (VAR_SCALAR | VAR_ARGUMENT))
+ || ((localPtr->defValuePtr == NULL)
+ && (fieldCount == 2))
+ || ((localPtr->defValuePtr != NULL)
+ && (fieldCount != 2))) {
+ char buf[80 + TCL_INTEGER_SPACE];
+ sprintf(buf, "\": formal parameter %d is inconsistent with precompiled body",
+ i);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "procedure \"", procName,
+ buf, (char *) NULL);
+ ckfree((char *) fieldValues);
+ goto procError;
+ }
/*
* compare the default value if any
}
strcpy(localPtr->name, fieldValues[0]);
}
+
ckfree((char *) fieldValues);
}
int
TclGetFrame(interp, string, framePtrPtr)
Tcl_Interp *interp; /* Interpreter in which to find frame. */
- char *string; /* String describing frame. */
+ CONST char *string; /* String describing frame. */
CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
* if global frame indicated). */
{
Proc *
TclFindProc(iPtr, procName)
Interp *iPtr; /* Interpreter in which to look. */
- char *procName; /* Name of desired procedure. */
+ CONST char *procName; /* Name of desired procedure. */
{
Tcl_Command cmd;
Tcl_Command origCmd;
* invoked. */
int argc; /* Count of number of arguments to this
* procedure. */
- register char **argv; /* Argument values. */
+ register CONST char **argv; /* Argument values. */
{
register Tcl_Obj *objPtr;
register int i;
register CompiledLocal *localPtr;
char *procName;
int nameLen, localCt, numArgs, argCt, i, result;
+ Tcl_Obj *objResult = Tcl_GetObjResult(interp);
/*
* This procedure generates an array "compiledLocals" that holds the
Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* local var is a reference */
- varPtr->flags &= ~VAR_UNDEFINED;
+ TclClearVarUndefined(varPtr);
argCt = 0;
break; /* done processing args */
} else if (argCt > 0) {
Tcl_Obj *objPtr = objv[i];
varPtr->value.objPtr = objPtr;
- varPtr->flags &= ~VAR_UNDEFINED;
+ TclClearVarUndefined(varPtr);
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else if (localPtr->defValuePtr != NULL) {
Tcl_Obj *objPtr = localPtr->defValuePtr;
varPtr->value.objPtr = objPtr;
- varPtr->flags &= ~VAR_UNDEFINED;
+ TclClearVarUndefined(varPtr);
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else {
- Tcl_ResetResult(interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "no value given for parameter \"", localPtr->name,
- "\" to \"", Tcl_GetString(objv[0]), "\"", (char *) NULL);
- result = TCL_ERROR;
- goto procDone;
+ goto incorrectArgs;
}
varPtr++;
localPtr = localPtr->nextPtr;
}
if (argCt > 0) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "called \"", Tcl_GetString(objv[0]),
- "\" with too many arguments", (char *) NULL);
+ incorrectArgs:
+ /*
+ * Build up equivalent to Tcl_WrongNumArgs message for proc
+ */
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(objResult,
+ "wrong # args: should be \"", procName, (char *) NULL);
+ localPtr = procPtr->firstLocalPtr;
+ for (i = 1; i <= numArgs; i++) {
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_AppendStringsToObj(objResult,
+ " ?", localPtr->name, "?", (char *) NULL);
+ } else {
+ Tcl_AppendStringsToObj(objResult,
+ " ", localPtr->name, (char *) NULL);
+ }
+ localPtr = localPtr->nextPtr;
+ }
+ Tcl_AppendStringsToObj(objResult, "\"", (char *) NULL);
+
result = TCL_ERROR;
goto procDone;
}
* Invoke the commands in the procedure's body.
*/
- if (tclTraceExec >= 1) {
#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 1) {
fprintf(stdout, "Calling proc ");
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
-#else /* TCL_COMPILE_DEBUG */
- fprintf(stdout, "Calling proc %.*s\n", nameLen, procName);
-#endif /*TCL_COMPILE_DEBUG*/
fflush(stdout);
}
+#endif /*TCL_COMPILE_DEBUG*/
iPtr->returnCode = TCL_OK;
procPtr->refCount++;
- result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0);
+ result = TclCompEvalObj(interp, procPtr->bodyPtr);
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
int numChars;
char *ellipsis;
+#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 1) {
/*
* Display a line summarizing the top level command we
fprintf(stdout, "Compiling %s \"%.*s%s\"\n",
description, numChars, procName, ellipsis);
}
+#endif
/*
* Plug the current procPtr into the interpreter and coerce
int returnCode; /* The unexpected result code. */
{
Interp *iPtr = (Interp *) interp;
+ char msg[100 + TCL_INTEGER_SPACE];
+ char *ellipsis = "";
+ if (returnCode == TCL_OK) {
+ return TCL_OK;
+ }
+ if (returnCode > TCL_CONTINUE) {
+ return returnCode;
+ }
if (returnCode == TCL_RETURN) {
- returnCode = TclUpdateReturnInfo(iPtr);
- } else if (returnCode == TCL_ERROR) {
- char msg[100 + TCL_INTEGER_SPACE];
- char *ellipsis = "";
- int numChars = nameLen;
-
- if (numChars > 60) {
- numChars = 60;
- ellipsis = "...";
- }
- sprintf(msg, "\n (procedure \"%.*s%s\" line %d)",
- numChars, procName, ellipsis, iPtr->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- } else if (returnCode == TCL_BREAK) {
+ return TclUpdateReturnInfo(iPtr);
+ }
+ if (returnCode != TCL_ERROR) {
Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "invoked \"break\" outside of a loop", -1);
- returnCode = TCL_ERROR;
- } else if (returnCode == TCL_CONTINUE) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "invoked \"continue\" outside of a loop", -1);
- returnCode = TCL_ERROR;
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK)
+ ? "invoked \"break\" outside of a loop"
+ : "invoked \"continue\" outside of a loop"), -1);
+ }
+ if (nameLen > 60) {
+ nameLen = 60;
+ ellipsis = "...";
}
- return returnCode;
+ sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
+ ellipsis, iPtr->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ return TCL_ERROR;
}
\f
/*
* exception is being processed. */
{
int code;
+ char *errorCode;
code = iPtr->returnCode;
iPtr->returnCode = TCL_OK;
if (code == TCL_ERROR) {
- Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL,
- (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
+ errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
+ Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
+ NULL, Tcl_NewStringObj(errorCode, -1),
TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
if (iPtr->errorInfo != NULL) {
- Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL,
- iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
+ NULL, Tcl_NewStringObj(iPtr->errorInfo, -1),
+ TCL_GLOBAL_ONLY);
iPtr->flags |= ERR_IN_PROGRESS;
}
}
{
panic("called ProcBodyUpdateString");
}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileNoOp --
+ *
+ * Procedure called to compile noOp's
+ *
+ * Results:
+ * The return value is TCL_OK, indicating successful compilation.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute a noOp at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TclCompileNoOp(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int i, code;
+ int savedStackDepth = envPtr->currStackDepth;
+
+ tokenPtr = parsePtr->tokenPtr;
+ for(i = 1; i < parsePtr->numWords; i++) {
+ tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
+ envPtr->currStackDepth = savedStackDepth;
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ }
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
+ return TCL_OK;
+}
+
+
+
*/
static TclRegexp * CompileRegexp _ANSI_ARGS_((Tcl_Interp *interp,
- char *pattern, int length, int flags));
+ CONST char *pattern, int length, int flags));
static void DupRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static void FinalizeRegexp _ANSI_ARGS_((ClientData clientData));
Tcl_RegExpCompile(interp, string)
Tcl_Interp *interp; /* For use in error reporting and
* to access the interp regexp cache. */
- char *string; /* String for which to produce
+ CONST char *string; /* String for which to produce
* compiled regular expression. */
{
return (Tcl_RegExp) CompileRegexp(interp, string, (int) strlen(string),
int flags, result, numChars;
TclRegexp *regexp = (TclRegexp *)re;
Tcl_DString ds;
- Tcl_UniChar *ustr;
+ CONST Tcl_UniChar *ustr;
/*
* If the starting point is offset from the beginning of the buffer,
int index; /* 0 means give the range of the entire
* match, > 0 means give the range of
* a matching subrange. */
- char **startPtr; /* Store address of first character in
+ CONST char **startPtr; /* Store address of first character in
* (sub-) range here. */
- char **endPtr; /* Store address of character just after last
+ CONST char **endPtr; /* Store address of character just after last
* in (sub-) range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
int
Tcl_RegExpMatch(interp, string, pattern)
Tcl_Interp *interp; /* Used for error reporting. May be NULL. */
- char *string; /* String. */
- char *pattern; /* Regular expression to match against
+ CONST char *string; /* String. */
+ CONST char *pattern; /* Regular expression to match against
* string. */
{
Tcl_RegExp re;
regexpPtr->string = NULL;
regexpPtr->objPtr = objPtr;
- udata = Tcl_GetUnicode(objPtr);
- length = Tcl_GetCharLength(objPtr);
+ udata = Tcl_GetUnicodeFromObj(objPtr, &length);
if (offset > length) {
offset = length;
void
TclRegError(interp, msg, status)
Tcl_Interp *interp; /* Interpreter for error reporting. */
- char *msg; /* Message to prepend to error. */
+ CONST char *msg; /* Message to prepend to error. */
int status; /* Status code to report. */
{
char buf[100]; /* ample in practice */
static TclRegexp *
CompileRegexp(interp, string, length, flags)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- char *string; /* The regexp to compile (UTF-8). */
+ CONST char *string; /* The regexp to compile (UTF-8). */
int length; /* The length of the string in bytes. */
int flags; /* Compilation flags. */
{
TclRegexp *regexpPtr;
- Tcl_UniChar *uniString;
+ CONST Tcl_UniChar *uniString;
int numChars;
Tcl_DString stringBuf;
int status, i;
Tcl_Interp *interp; /* Interpreter whose name resolution
* rules are being modified. */
- char *name; /* Name of this resolution scheme. */
+ CONST char *name; /* Name of this resolution scheme. */
Tcl_ResolveCmdProc *cmdProc; /* New procedure for command
* resolution */
Tcl_ResolveVarProc *varProc; /* Procedure for variable resolution
Tcl_Interp *interp; /* Interpreter whose name resolution
* rules are being queried. */
- char *name; /* Look for a scheme with this name. */
+ CONST char *name; /* Look for a scheme with this name. */
Tcl_ResolverInfo *resInfoPtr; /* Returns pointers to the procedures,
* if found */
{
Tcl_Interp *interp; /* Interpreter whose name resolution
* rules are being modified. */
- char *name; /* Name of the scheme to be removed. */
+ CONST char *name; /* Name of the scheme to be removed. */
{
Interp *iPtr = (Interp*)interp;
ResolverScheme **prevPtrPtr, *resPtr;
* type:
*
* typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((
- * Tcl_Interp* interp, char* name, Tcl_Namespace *context,
+ * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
* int flags, Tcl_Command *rPtr));
*
* Whenever a command is executed or Tcl_FindCommand is invoked
* time:
*
* typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
- * Tcl_Interp* interp, char* name, Tcl_Namespace *context,
+ * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
* Tcl_ResolvedVarInfo *rPtr));
*
* If this procedure is able to resolve the name, it should return
* Tcl_FindNamespaceVar.) This procedure has the following type:
*
* typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
- * Tcl_Interp* interp, char* name, Tcl_Namespace *context,
+ * Tcl_Interp* interp, CONST char* name, Tcl_Namespace *context,
* int flags, Tcl_Var *rPtr));
*
* This procedure is quite similar to the compile-time version.
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetStringResult(interp)
register Tcl_Interp *interp; /* Interpreter whose result to return. */
{
*/
#include "tclInt.h"
+/*
+ * For strtoll() and strtoull() declarations on some platforms...
+ */
+#include "tclPort.h"
/*
* Flag values used by Tcl_ScanObjCmd.
#define SCAN_PTOK 0x100 /* Decimal point is allowed. */
#define SCAN_EXPOK 0x200 /* An exponent is allowed. */
+#define SCAN_LONGER 0x400 /* Asked for a wide value. */
/*
* The following structure contains the information associated with
int staticAssign[STATIC_LIST_SIZE];
int *nassign = staticAssign;
int objIndex, xpgSize, nspace = STATIC_LIST_SIZE;
+ char buf[TCL_UTF_MAX+1];
/*
* Initialize an array that records the number of times a variable
}
/*
- * Ignore size specifier.
+ * Handle any size specifier.
*/
- if ((ch == 'l') || (ch == 'L') || (ch == 'h')) {
+ switch (ch) {
+ case 'l':
+ case 'L':
+#ifndef TCL_WIDE_INT_IS_LONG
+ flags |= SCAN_LONGER;
+#endif
+ case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
*/
switch (ch) {
+ case 'c':
+ if (flags & SCAN_WIDTH) {
+ Tcl_SetResult(interp,
+ "field width may not be specified in %c conversion",
+ TCL_STATIC);
+ goto error;
+ }
+ /*
+ * Fall through!
+ */
case 'n':
+ case 's':
+ if (flags & SCAN_LONGER) {
+ invalidLonger:
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "'l' modifier may not be specified in %", buf,
+ " conversion", NULL);
+ goto error;
+ }
+ /*
+ * Fall through!
+ */
case 'd':
+ case 'e':
+ case 'f':
+ case 'g':
case 'i':
case 'o':
- case 'x':
case 'u':
- case 'f':
- case 'e':
- case 'g':
- case 's':
- break;
- case 'c':
- if (flags & SCAN_WIDTH) {
- Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC);
- goto error;
- }
- break;
+ case 'x':
+ break;
+ /*
+ * Bracket terms need special checking
+ */
case '[':
+ if (flags & SCAN_LONGER) {
+ goto invalidLonger;
+ }
if (*format == '\0') {
goto badSet;
}
{
char *format;
int numVars, nconversions, totalVars = -1;
- int objIndex, offset, i, value, result, code;
+ int objIndex, offset, i, result, code;
+ long value;
char *string, *end, *baseString;
char op = 0;
int base = 0;
int underflow = 0;
size_t width;
long (*fn)() = NULL;
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt (*lfn)() = NULL;
+ Tcl_WideInt wideValue;
+#endif
Tcl_UniChar ch, sch;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
if (*end == '$') {
format = end+1;
format += Tcl_UtfToUniChar(format, &ch);
- objIndex = value - 1;
+ objIndex = (int) value - 1;
}
}
}
/*
- * Ignore size specifier.
+ * Handle any size specifier.
*/
- if ((ch == 'l') || (ch == 'L') || (ch == 'h')) {
+ switch (ch) {
+ case 'l':
+ case 'L':
+#ifndef TCL_WIDE_INT_IS_LONG
+ flags |= SCAN_LONGER;
+#endif
+ /*
+ * Fall through so we skip to the next character.
+ */
+ case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
op = 'i';
base = 10;
fn = (long (*)())strtol;
+#ifndef TCL_WIDE_INT_IS_LONG
+ lfn = (Tcl_WideInt (*)())strtoll;
+#endif
break;
case 'i':
op = 'i';
base = 0;
fn = (long (*)())strtol;
+#ifndef TCL_WIDE_INT_IS_LONG
+ lfn = (Tcl_WideInt (*)())strtoll;
+#endif
break;
case 'o':
op = 'i';
base = 8;
- fn = (long (*)())strtol;
+ fn = (long (*)())strtoul;
+#ifndef TCL_WIDE_INT_IS_LONG
+ lfn = (Tcl_WideInt (*)())strtoull;
+#endif
break;
case 'x':
op = 'i';
base = 16;
- fn = (long (*)())strtol;
+ fn = (long (*)())strtoul;
+#ifndef TCL_WIDE_INT_IS_LONG
+ lfn = (Tcl_WideInt (*)())strtoull;
+#endif
break;
case 'u':
op = 'i';
base = 10;
flags |= SCAN_UNSIGNED;
fn = (long (*)())strtoul;
+#ifndef TCL_WIDE_INT_IS_LONG
+ lfn = (Tcl_WideInt (*)())strtoull;
+#endif
break;
case 'f':
* a number. If we are unsure of the base, it
* indicates that we are in base 8 or base 16 (if it is
* followed by an 'x').
+ *
+ * 8.1 - 8.3.4 incorrectly handled 0x... base-16
+ * cases for %x by not reading the 0x as the
+ * auto-prelude for base-16. [Bug #495213]
*/
case '0':
if (base == 0) {
base = 8;
flags |= SCAN_XOK;
}
+ if (base == 16) {
+ flags |= SCAN_XOK;
+ }
if (flags & SCAN_NOZERO) {
flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS
| SCAN_NOZERO);
if (!(flags & SCAN_SUPPRESS)) {
*end = '\0';
- value = (int) (*fn)(buf, NULL, base);
- if ((flags & SCAN_UNSIGNED) && (value < 0)) {
- sprintf(buf, "%u", value); /* INTL: ISO digit */
- objPtr = Tcl_NewStringObj(buf, -1);
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (flags & SCAN_LONGER) {
+ wideValue = (Tcl_WideInt) (*lfn)(buf, NULL, base);
+ if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
+ /* INTL: ISO digit */
+ sprintf(buf, "%" TCL_LL_MODIFIER "u",
+ (Tcl_WideUInt)wideValue);
+ objPtr = Tcl_NewStringObj(buf, -1);
+ } else {
+ objPtr = Tcl_NewWideIntObj(wideValue);
+ }
} else {
- objPtr = Tcl_NewIntObj(value);
+#endif /* !TCL_WIDE_INT_IS_LONG */
+ value = (long) (*fn)(buf, NULL, base);
+ if ((flags & SCAN_UNSIGNED) && (value < 0)) {
+ sprintf(buf, "%lu", value); /* INTL: ISO digit */
+ objPtr = Tcl_NewStringObj(buf, -1);
+ } else {
+ if ((unsigned long) value > UINT_MAX) {
+ objPtr = Tcl_NewLongObj(value);
+ } else {
+ objPtr = Tcl_NewIntObj(value);
+ }
+ }
+#ifndef TCL_WIDE_INT_IS_LONG
}
+#endif
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
if ((width == 0) || (width > sizeof(buf) - 1)) {
width = sizeof(buf) - 1;
}
+ flags &= ~SCAN_LONGER;
flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK;
for (end = buf; width > 0; width--) {
switch (*string) {
}
}
}
- ckfree((char*) objs);
+ if (objs != NULL) {
+ ckfree((char*) objs);
+ }
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
if (numVars) {
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id$
- */
+ * RCS: @(#) $Id$ */
#include "tclInt.h"
*/
static void AppendUnicodeToUnicodeRep _ANSI_ARGS_((
- Tcl_Obj *objPtr, Tcl_UniChar *unicode,
+ Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
int appendNumChars));
static void AppendUnicodeToUtfRep _ANSI_ARGS_((
- Tcl_Obj *objPtr, Tcl_UniChar *unicode,
+ Tcl_Obj *objPtr, CONST Tcl_UniChar *unicode,
int numChars));
static void AppendUtfToUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- char *bytes, int numBytes));
+ CONST char *bytes, int numBytes));
static void AppendUtfToUtfRep _ANSI_ARGS_((Tcl_Obj *objPtr,
- char *bytes, int numBytes));
+ CONST char *bytes, int numBytes));
static void FillUnicodeRep _ANSI_ARGS_((Tcl_Obj *objPtr));
#define SET_STRING(objPtr, stringPtr) \
(objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)
+/*
+ * TCL STRING GROWTH ALGORITHM
+ *
+ * When growing strings (during an append, for example), the following growth
+ * algorithm is used:
+ *
+ * Attempt to allocate 2 * (originalLength + appendLength)
+ * On failure:
+ * attempt to allocate originalLength + 2*appendLength +
+ * TCL_GROWTH_MIN_ALLOC
+ *
+ * This algorithm allows very good performance, as it rapidly increases the
+ * memory allocated for a given string, which minimizes the number of
+ * reallocations that must be performed. However, using only the doubling
+ * algorithm can lead to a significant waste of memory. In particular, it
+ * may fail even when there is sufficient memory available to complete the
+ * append request (but there is not 2 * totalLength memory available). So when
+ * the doubling fails (because there is not enough memory available), the
+ * algorithm requests a smaller amount of memory, which is still enough to
+ * cover the request, but which hopefully will be less than the total available
+ * memory.
+ *
+ * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling
+ * of very small appends. Without this extra slush factor, a sequence
+ * of several small appends would cause several memory allocations.
+ * As long as TCL_GROWTH_MIN_ALLOC is a reasonable size, we can
+ * avoid that behavior.
+ *
+ * The growth algorithm can be tuned by adjusting the following parameters:
+ *
+ * TCL_GROWTH_MIN_ALLOC Additional space, in bytes, to allocate when
+ * the double allocation has failed.
+ * Default is 1024 (1 kilobyte).
+ */
+#ifndef TCL_GROWTH_MIN_ALLOC
+#define TCL_GROWTH_MIN_ALLOC 1024
+#endif
+
\f
/*
*----------------------------------------------------------------------
* TCL_MEM_DEBUG is defined. It creates new string objects. It is the
* same as the Tcl_NewStringObj procedure above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
- * caller. This simplifies debugging since then the checkmem command
- * will report the correct file name and line number when reporting
- * objects that haven't been freed.
+ * caller. This simplifies debugging since then the [memory active]
+ * command will report the correct file name and line number when
+ * reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this procedure just returns the
* result of calling Tcl_NewStringObj.
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
- char *file; /* The name of the source file calling this
+ CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
* for debugging. */
/*
*---------------------------------------------------------------------------
*
- * TclNewUnicodeObj --
+ * Tcl_NewUnicodeObj --
*
* This procedure is creates a new String object and initializes
- * it from the given Utf String. If the Utf String is the same size
+ * it from the given Unicode String. If the Utf String is the same size
* as the Unicode string, don't duplicate the data.
*
* Results:
Tcl_Obj *
Tcl_NewUnicodeObj(unicode, numChars)
- Tcl_UniChar *unicode; /* The unicode string used to initialize
+ CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
* the new object. */
int numChars; /* Number of characters in the unicode
* string. */
/*
*----------------------------------------------------------------------
*
+ * Tcl_GetUnicodeFromObj --
+ *
+ * Get the Unicode form of the String object with length. If
+ * the object is not already a String object, it will be converted
+ * to one. If the String object does not have a Unicode rep, then
+ * one is create from the UTF string format.
+ *
+ * Results:
+ * Returns a pointer to the object's internal Unicode string.
+ *
+ * Side effects:
+ * Converts the object to have the String internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_UniChar *
+Tcl_GetUnicodeFromObj(objPtr, lengthPtr)
+ Tcl_Obj *objPtr; /* The object to find the unicode string for. */
+ int *lengthPtr; /* If non-NULL, the location where the
+ * string rep's unichar length should be
+ * stored. If NULL, no length is stored. */
+{
+ String *stringPtr;
+
+ SetStringFromAny(NULL, objPtr);
+ stringPtr = GET_STRING(objPtr);
+
+ if ((stringPtr->numChars == -1) || (stringPtr->uallocated == 0)) {
+
+ /*
+ * We haven't yet calculated the length, or all of the characters
+ * in the Utf string are 1 byte chars (so we didn't store the
+ * unicode str). Since this function must return a unicode string,
+ * and one has not yet been stored, force the Unicode to be
+ * calculated and stored now.
+ */
+
+ FillUnicodeRep(objPtr);
+
+ /*
+ * We need to fetch the pointer again because we have just
+ * reallocated the structure to make room for the Unicode data.
+ */
+
+ stringPtr = GET_STRING(objPtr);
+ }
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = stringPtr->numChars;
+ }
+ return stringPtr->unicode;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetRange --
*
* Create a Tcl Object that contains the chars between first and last
*----------------------------------------------------------------------
*/
-Tcl_Obj*
+Tcl_Obj *
Tcl_GetRange(objPtr, first, last)
-
- Tcl_Obj *objPtr; /* The Tcl object to find the range of. */
+ Tcl_Obj *objPtr; /* The Tcl object to find the range of. */
int first; /* First index of the range. */
int last; /* Last index of the range. */
{
void
Tcl_SetStringObj(objPtr, bytes, length)
register Tcl_Obj *objPtr; /* Object whose internal rep to init. */
- char *bytes; /* Points to the first of the length bytes
+ CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the object. */
register int length; /* The number of bytes to copy from "bytes"
* when initializing the object. If
* Not enough space in current string. Reallocate the string
* space and free the old string.
*/
+ if (objPtr->bytes != tclEmptyStringRep) {
+ new = (char *) ckrealloc((char *)objPtr->bytes,
+ (unsigned)(length+1));
+ } else {
+ new = (char *) ckalloc((unsigned) (length+1));
+ if (objPtr->bytes != NULL && objPtr->length != 0) {
+ memcpy((VOID *) new, (VOID *) objPtr->bytes,
+ (size_t) objPtr->length);
+ Tcl_InvalidateStringRep(objPtr);
+ }
+ }
+ objPtr->bytes = new;
+ stringPtr->allocated = length;
+ }
+
+ objPtr->length = length;
+ if ((objPtr->bytes != NULL) && (objPtr->bytes != tclEmptyStringRep)) {
+ objPtr->bytes[length] = 0;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AttemptSetObjLength --
+ *
+ * This procedure changes the length of the string representation
+ * of an object. It uses the attempt* (non-panic'ing) memory allocators.
+ *
+ * Results:
+ * 1 if the requested memory was allocated, 0 otherwise.
+ *
+ * Side effects:
+ * If the size of objPtr's string representation is greater than
+ * length, then it is reduced to length and a new terminating null
+ * byte is stored in the strength. If the length of the string
+ * representation is greater than length, the storage space is
+ * reallocated to the given length; a null byte is stored at the
+ * end, but other bytes past the end of the original string
+ * representation are undefined. The object's internal
+ * representation is changed to "expendable string".
+ *
+ *----------------------------------------------------------------------
+ */
- new = (char *) ckalloc((unsigned) (length+1));
- if (objPtr->bytes != NULL) {
- memcpy((VOID *) new, (VOID *) objPtr->bytes,
- (size_t) objPtr->length);
- Tcl_InvalidateStringRep(objPtr);
+int
+Tcl_AttemptSetObjLength(objPtr, length)
+ register Tcl_Obj *objPtr; /* Pointer to object. This object must
+ * not currently be shared. */
+ register int length; /* Number of bytes desired for string
+ * representation of object, not including
+ * terminating null byte. */
+{
+ char *new;
+ String *stringPtr;
+
+ if (Tcl_IsShared(objPtr)) {
+ panic("Tcl_AttemptSetObjLength called with shared object");
+ }
+ SetStringFromAny(NULL, objPtr);
+
+ /*
+ * Invalidate the unicode data.
+ */
+
+ stringPtr = GET_STRING(objPtr);
+ stringPtr->numChars = -1;
+ stringPtr->uallocated = 0;
+
+ if (length > (int) stringPtr->allocated) {
+
+ /*
+ * Not enough space in current string. Reallocate the string
+ * space and free the old string.
+ */
+ if (objPtr->bytes != tclEmptyStringRep) {
+ new = (char *) attemptckrealloc((char *)objPtr->bytes,
+ (unsigned)(length+1));
+ if (new == NULL) {
+ return 0;
+ }
+ } else {
+ new = (char *) attemptckalloc((unsigned) (length+1));
+ if (new == NULL) {
+ return 0;
+ }
+ if (objPtr->bytes != NULL && objPtr->length != 0) {
+ memcpy((VOID *) new, (VOID *) objPtr->bytes,
+ (size_t) objPtr->length);
+ Tcl_InvalidateStringRep(objPtr);
+ }
}
objPtr->bytes = new;
stringPtr->allocated = length;
if ((objPtr->bytes != NULL) && (objPtr->bytes != tclEmptyStringRep)) {
objPtr->bytes[length] = 0;
}
+ return 1;
}
\f
/*
void
Tcl_SetUnicodeObj(objPtr, unicode, numChars)
Tcl_Obj *objPtr; /* The object to set the string of. */
- Tcl_UniChar *unicode; /* The unicode string used to initialize
+ CONST Tcl_UniChar *unicode; /* The unicode string used to initialize
* the object. */
int numChars; /* Number of characters in the unicode
* string. */
void
Tcl_AppendToObj(objPtr, bytes, length)
register Tcl_Obj *objPtr; /* Points to the object to append to. */
- char *bytes; /* Points to the bytes to append to the
+ CONST char *bytes; /* Points to the bytes to append to the
* object. */
register int length; /* The number of bytes to append from
* "bytes". If < 0, then append all bytes
void
Tcl_AppendUnicodeToObj(objPtr, unicode, length)
register Tcl_Obj *objPtr; /* Points to the object to append to. */
- Tcl_UniChar *unicode; /* The unicode string to append to the
+ CONST Tcl_UniChar *unicode; /* The unicode string to append to the
* object. */
int length; /* Number of chars in "unicode". */
{
}
SetStringFromAny(NULL, objPtr);
-
- /*
- * TEMPORARY!!! This is terribly inefficient, but it works, and Don
- * needs for me to check this stuff in ASAP. -Melissa
- */
-
-/* UpdateStringOfString(objPtr); */
-/* AppendUnicodeToUtfRep(objPtr, unicode, length); */
-/* return; */
+ stringPtr = GET_STRING(objPtr);
/*
* If objPtr has a valid Unicode rep, then append the "unicode"
* "unicode" to objPtr's string rep.
*/
- stringPtr = GET_STRING(objPtr);
if (stringPtr->uallocated > 0) {
AppendUnicodeToUnicodeRep(objPtr, unicode, length);
} else {
static void
AppendUnicodeToUnicodeRep(objPtr, unicode, appendNumChars)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- Tcl_UniChar *unicode; /* String to append. */
- int appendNumChars; /* Number of chars of "unicode" to append. */
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
+ CONST Tcl_UniChar *unicode; /* String to append. */
+ int appendNumChars; /* Number of chars of "unicode" to append. */
{
- String *stringPtr;
- int numChars;
- size_t newSize;
+ String *stringPtr, *tmpString;
+ size_t numChars;
if (appendNumChars < 0) {
appendNumChars = 0;
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
-
+
/*
* If not enough space has been allocated for the unicode rep,
- * reallocate the internal rep object with double the amount of
- * space needed, so the unicode string can grow without being
- * reallocated.
+ * reallocate the internal rep object with additional space. First try to
+ * double the required allocation; if that fails, try a more modest
+ * increase. See the "TCL STRING GROWTH ALGORITHM" comment at the top of
+ * this file for an explanation of this growth algorithm.
*/
numChars = stringPtr->numChars + appendNumChars;
- newSize = (numChars + 1) * sizeof(Tcl_UniChar);
- if (newSize > stringPtr->uallocated) {
- stringPtr->uallocated = newSize * 2;
- stringPtr = (String *) ckrealloc((char*)stringPtr,
+ if (numChars >= stringPtr->uallocated) {
+ stringPtr->uallocated = 2 * numChars;
+ tmpString = (String *) attemptckrealloc((char *)stringPtr,
STRING_SIZE(stringPtr->uallocated));
+ if (tmpString == NULL) {
+ stringPtr->uallocated =
+ numChars + appendNumChars + TCL_GROWTH_MIN_ALLOC;
+ tmpString = (String *) ckrealloc((char *)stringPtr,
+ STRING_SIZE(stringPtr->uallocated));
+ }
+ stringPtr = tmpString;
SET_STRING(objPtr, stringPtr);
}
stringPtr->unicode[numChars] = 0;
stringPtr->numChars = numChars;
- SET_STRING(objPtr, stringPtr);
Tcl_InvalidateStringRep(objPtr);
}
\f
static void
AppendUnicodeToUtfRep(objPtr, unicode, numChars)
- Tcl_Obj *objPtr; /* Points to the object to append to. */
- Tcl_UniChar *unicode; /* String to convert to UTF. */
- int numChars; /* Number of chars of "unicode" to convert. */
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
+ CONST Tcl_UniChar *unicode; /* String to convert to UTF. */
+ int numChars; /* Number of chars of "unicode" to convert. */
{
Tcl_DString dsPtr;
- char *bytes;
+ CONST char *bytes;
if (numChars < 0) {
numChars = 0;
}
Tcl_DStringInit(&dsPtr);
- bytes = (char *)Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr);
+ bytes = Tcl_UniCharToUtfDString(unicode, numChars, &dsPtr);
AppendUtfToUtfRep(objPtr, bytes, Tcl_DStringLength(&dsPtr));
Tcl_DStringFree(&dsPtr);
}
static void
AppendUtfToUnicodeRep(objPtr, bytes, numBytes)
Tcl_Obj *objPtr; /* Points to the object to append to. */
- char *bytes; /* String to convert to Unicode. */
+ CONST char *bytes; /* String to convert to Unicode. */
int numBytes; /* Number of bytes of "bytes" to convert. */
{
Tcl_DString dsPtr;
static void
AppendUtfToUtfRep(objPtr, bytes, numBytes)
Tcl_Obj *objPtr; /* Points to the object to append to. */
- char *bytes; /* String to append. */
+ CONST char *bytes; /* String to append. */
int numBytes; /* Number of bytes of "bytes" to append. */
{
String *stringPtr;
if (newLength > (int) stringPtr->allocated) {
/*
- * There isn't currently enough space in the string
- * representation so allocate additional space. Overallocate the
- * space by doubling it so that we won't have to do as much
- * reallocation in the future.
+ * There isn't currently enough space in the string representation
+ * so allocate additional space. First, try to double the length
+ * required. If that fails, try a more modest allocation. See the
+ * "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
+ * explanation of this growth algorithm.
*/
- Tcl_SetObjLength(objPtr, 2*newLength);
+ if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) {
+ Tcl_SetObjLength(objPtr,
+ newLength + numBytes + TCL_GROWTH_MIN_ALLOC);
+ }
} else {
/*
{
#define STATIC_LIST_SIZE 16
String *stringPtr;
- int newLength, oldLength;
+ int newLength, oldLength, attemptLength;
register char *string, *dst;
char *static_list[STATIC_LIST_SIZE];
char **args = static_list;
*/
nargs = 0;
- newLength = oldLength = objPtr->length;
+ newLength = 0;
+ oldLength = objPtr->length;
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
newLength += strlen(string);
args[nargs++] = string;
}
- if (newLength == oldLength) {
+ if (newLength == 0) {
goto done;
}
stringPtr = GET_STRING(objPtr);
- if (newLength > (int) stringPtr->allocated) {
+ if (oldLength + newLength > (int) stringPtr->allocated) {
/*
* There isn't currently enough space in the string
- * representation so allocate additional space. If the current
+ * representation, so allocate additional space. If the current
* string representation isn't empty (i.e. it looks like we're
- * doing a series of appends) then overallocate the space so
- * that we won't have to do as much reallocation in the future.
+ * doing a series of appends) then try to allocate extra space to
+ * accomodate future growth: first try to double the required memory;
+ * if that fails, try a more modest allocation. See the "TCL STRING
+ * GROWTH ALGORITHM" comment at the top of this file for an explanation
+ * of this growth algorithm. Otherwise, if the current string
+ * representation is empty, exactly enough memory is allocated.
*/
- Tcl_SetObjLength(objPtr,
- (objPtr->length == 0) ? newLength : 2*newLength);
+ if (oldLength == 0) {
+ Tcl_SetObjLength(objPtr, newLength);
+ } else {
+ attemptLength = 2 * (oldLength + newLength);
+ if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
+ attemptLength = oldLength + (2 * newLength) +
+ TCL_GROWTH_MIN_ALLOC;
+ Tcl_SetObjLength(objPtr, attemptLength);
+ }
+ }
}
/*
if (dst != NULL) {
*dst = 0;
}
- objPtr->length = newLength;
+ objPtr->length = oldLength + newLength;
done:
/*
static int
SetStringFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- Tcl_Obj *objPtr; /* The object to convert. */
+ register Tcl_Obj *objPtr; /* The object to convert. */
{
- String *stringPtr;
-
/*
* The Unicode object is opitmized for the case where each UTF char
* in a string is only one byte. In this case, we store the value of
*/
if (objPtr->typePtr != &tclStringType) {
+ String *stringPtr;
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
#undef Tcl_NewStringObj
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+# undef Tcl_FindHashEntry
+# undef Tcl_CreateHashEntry
+#endif
/*
* WARNING: The contents of this file is automatically generated by the
TclIntStubs tclIntStubs = {
TCL_STUB_MAGIC,
NULL,
- TclAccess, /* 0 */
+ NULL, /* 0 */
TclAccessDeleteProc, /* 1 */
TclAccessInsertProc, /* 2 */
TclAllocateFreeObjects, /* 3 */
TclDumpMemoryInfo, /* 14 */
NULL, /* 15 */
TclExprFloatError, /* 16 */
- TclFileAttrsCmd, /* 17 */
- TclFileCopyCmd, /* 18 */
- TclFileDeleteCmd, /* 19 */
- TclFileMakeDirsCmd, /* 20 */
- TclFileRenameCmd, /* 21 */
+ NULL, /* 17 */
+ NULL, /* 18 */
+ NULL, /* 19 */
+ NULL, /* 20 */
+ NULL, /* 21 */
TclFindElement, /* 22 */
TclFindProc, /* 23 */
TclFormatInt, /* 24 */
NULL, /* 26 */
TclGetDate, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
- TclGetElementOfIndexedArray, /* 29 */
+ NULL, /* 29 */
NULL, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
TclGetInterpProc, /* 33 */
TclGetIntForIndex, /* 34 */
- TclGetIndexedScalar, /* 35 */
+ NULL, /* 35 */
TclGetLong, /* 36 */
TclGetLoadedPackages, /* 37 */
TclGetNamespaceForQualName, /* 38 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
- TclIncrElementOfIndexedArray, /* 47 */
- TclIncrIndexedScalar, /* 48 */
+ NULL, /* 47 */
+ NULL, /* 48 */
TclIncrVar2, /* 49 */
TclInitCompiledLocals, /* 50 */
TclInterpInit, /* 51 */
NULL, /* 56 */
NULL, /* 57 */
TclLookupVar, /* 58 */
- TclpMatchFiles, /* 59 */
+ NULL, /* 59 */
TclNeedSpace, /* 60 */
TclNewProcBodyObj, /* 61 */
TclObjCommandComplete, /* 62 */
TclObjInvokeGlobal, /* 65 */
TclOpenFileChannelDeleteProc, /* 66 */
TclOpenFileChannelInsertProc, /* 67 */
- TclpAccess, /* 68 */
-#if !defined(__CYGWIN__) || defined(__MINGW32__)
+ NULL, /* 68 */
TclpAlloc, /* 69 */
-#endif
- TclpCopyFile, /* 70 */
- TclpCopyDirectory, /* 71 */
- TclpCreateDirectory, /* 72 */
- TclpDeleteFile, /* 73 */
-#if !defined(__CYGWIN__) || defined(__MINGW32__)
+ NULL, /* 70 */
+ NULL, /* 71 */
+ NULL, /* 72 */
+ NULL, /* 73 */
TclpFree, /* 74 */
-#endif
TclpGetClicks, /* 75 */
TclpGetSeconds, /* 76 */
TclpGetTime, /* 77 */
TclpGetTimeZone, /* 78 */
- TclpListVolumes, /* 79 */
- TclpOpenFileChannel, /* 80 */
-#if !defined(__CYGWIN__) || defined(__MINGW32__)
+ NULL, /* 79 */
+ NULL, /* 80 */
TclpRealloc, /* 81 */
-#endif
- TclpRemoveDirectory, /* 82 */
- TclpRenameFile, /* 83 */
+ NULL, /* 82 */
+ NULL, /* 83 */
NULL, /* 84 */
NULL, /* 85 */
NULL, /* 86 */
TclProcCompileProc, /* 92 */
TclProcDeleteProc, /* 93 */
TclProcInterpProc, /* 94 */
- TclpStat, /* 95 */
+ NULL, /* 95 */
TclRenameCommand, /* 96 */
TclResetShadowedCmdRefs, /* 97 */
TclServiceIdle, /* 98 */
- TclSetElementOfIndexedArray, /* 99 */
- TclSetIndexedScalar, /* 100 */
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
+ NULL, /* 99 */
+ NULL, /* 100 */
TclSetPreInitScript, /* 101 */
-#endif /* UNIX */
-#ifdef __WIN32__
- TclSetPreInitScript, /* 101 */
-#endif /* __WIN32__ */
-#ifdef MAC_TCL
- NULL, /* 101 */
-#endif /* MAC_TCL */
TclSetupEnv, /* 102 */
TclSockGetPort, /* 103 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifdef MAC_TCL
NULL, /* 104 */
#endif /* MAC_TCL */
- TclStat, /* 105 */
+ NULL, /* 105 */
TclStatDeleteProc, /* 106 */
TclStatInsertProc, /* 107 */
TclTeardownNamespace, /* 108 */
TclpStrftime, /* 134 */
TclpCheckStackSpace, /* 135 */
NULL, /* 136 */
- TclpChdir, /* 137 */
+ NULL, /* 137 */
TclGetEnv, /* 138 */
- TclpLoadFile, /* 139 */
+ NULL, /* 139 */
TclLooksLikeInt, /* 140 */
TclpGetCwd, /* 141 */
TclSetByteCodeFromAny, /* 142 */
TclVarTraceExists, /* 157 */
TclSetStartupScriptFileName, /* 158 */
TclGetStartupScriptFileName, /* 159 */
- TclpMatchFilesTypes, /* 160 */
+ NULL, /* 160 */
TclChannelTransform, /* 161 */
TclChannelEventScriptInvoker, /* 162 */
+ TclGetInstructionTable, /* 163 */
+ TclExpandCodeArray, /* 164 */
+ TclpSetInitialEncodings, /* 165 */
+ TclListObjSetElement, /* 166 */
+ TclSetStartupScriptPath, /* 167 */
+ TclGetStartupScriptPath, /* 168 */
+ TclpUtfNcmp2, /* 169 */
+ TclCheckInterpTraces, /* 170 */
+ TclCheckExecutionTraces, /* 171 */
};
TclIntPlatStubs tclIntPlatStubs = {
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
+ TclpReaddir, /* 10 */
+ TclpLocaltime, /* 11 */
+ TclpGmtime, /* 12 */
+ TclpInetNtoa, /* 13 */
#endif /* UNIX */
#ifdef __WIN32__
TclWinConvertError, /* 0 */
TclpMakeFile, /* 18 */
TclpOpenFile, /* 19 */
TclWinAddProcess, /* 20 */
- TclpAsyncMark, /* 21 */
+ NULL, /* 21 */
TclpCreateTempFile, /* 22 */
TclpGetTZName, /* 23 */
TclWinNoBackslash, /* 24 */
TclWinGetPlatform, /* 25 */
TclWinSetInterfaces, /* 26 */
+ TclWinFlushDirtyChannels, /* 27 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
TclpSysAlloc, /* 0 */
FSpGetDefaultDir, /* 4 */
FSpSetDefaultDir, /* 5 */
FSpFindFolder, /* 6 */
- GetGlobalMouse, /* 7 */
- FSpGetDirectoryID, /* 8 */
- FSpOpenResFileCompat, /* 9 */
- FSpCreateResFileCompat, /* 10 */
+ GetGlobalMouseTcl, /* 7 */
+ FSpGetDirectoryIDTcl, /* 8 */
+ FSpOpenResFileCompatTcl, /* 9 */
+ FSpCreateResFileCompatTcl, /* 10 */
FSpLocationFromPath, /* 11 */
FSpPathFromLocation, /* 12 */
TclMacExitHandler, /* 13 */
TclMacUnRegisterResourceFork, /* 21 */
TclMacCreateEnv, /* 22 */
TclMacFOpenHack, /* 23 */
- NULL, /* 24 */
+ TclpGetTZName, /* 24 */
TclMacChmod, /* 25 */
+ FSpLLocationFromPath, /* 26 */
#endif /* MAC_TCL */
};
strncasecmp, /* 7 */
strcasecmp, /* 8 */
#endif /* MAC_TCL */
+#ifdef MAC_OSX_TCL
+ Tcl_MacOSXOpenBundleResources, /* 0 */
+#endif /* MAC_OSX_TCL */
};
static TclStubHooks tclStubHooks = {
Tcl_ResetResult, /* 217 */
Tcl_ScanElement, /* 218 */
Tcl_ScanCountedElement, /* 219 */
- Tcl_Seek, /* 220 */
+ Tcl_SeekOld, /* 220 */
Tcl_ServiceAll, /* 221 */
Tcl_ServiceEvent, /* 222 */
Tcl_SetAssocData, /* 223 */
Tcl_SplitPath, /* 243 */
Tcl_StaticPackage, /* 244 */
Tcl_StringMatch, /* 245 */
- Tcl_Tell, /* 246 */
+ Tcl_TellOld, /* 246 */
Tcl_TraceVar, /* 247 */
Tcl_TraceVar2, /* 248 */
Tcl_TranslateFileName, /* 249 */
Tcl_SetErrorCodeVA, /* 275 */
Tcl_VarEvalVA, /* 276 */
Tcl_WaitPid, /* 277 */
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
- Tcl_PanicVA, /* 278 */
-#endif /* UNIX */
-#ifdef __WIN32__
Tcl_PanicVA, /* 278 */
-#endif /* __WIN32__ */
-#ifdef MAC_TCL
- NULL, /* 278 */
-#endif /* MAC_TCL */
Tcl_GetVersion, /* 279 */
Tcl_InitMemory, /* 280 */
Tcl_StackChannel, /* 281 */
Tcl_UnstackChannel, /* 282 */
Tcl_GetStackedChannel, /* 283 */
- NULL, /* 284 */
+ Tcl_SetMainLoop, /* 284 */
NULL, /* 285 */
Tcl_AppendObjToObj, /* 286 */
Tcl_CreateEncoding, /* 287 */
Tcl_ChannelGetHandleProc, /* 409 */
Tcl_ChannelFlushProc, /* 410 */
Tcl_ChannelHandlerProc, /* 411 */
+ Tcl_JoinThread, /* 412 */
+ Tcl_IsChannelShared, /* 413 */
+ Tcl_IsChannelRegistered, /* 414 */
+ Tcl_CutChannel, /* 415 */
+ Tcl_SpliceChannel, /* 416 */
+ Tcl_ClearChannelHandlers, /* 417 */
+ Tcl_IsChannelExisting, /* 418 */
+ Tcl_UniCharNcasecmp, /* 419 */
+ Tcl_UniCharCaseMatch, /* 420 */
+ Tcl_FindHashEntry, /* 421 */
+ Tcl_CreateHashEntry, /* 422 */
+ Tcl_InitCustomHashTable, /* 423 */
+ Tcl_InitObjHashTable, /* 424 */
+ Tcl_CommandTraceInfo, /* 425 */
+ Tcl_TraceCommand, /* 426 */
+ Tcl_UntraceCommand, /* 427 */
+ Tcl_AttemptAlloc, /* 428 */
+ Tcl_AttemptDbCkalloc, /* 429 */
+ Tcl_AttemptRealloc, /* 430 */
+ Tcl_AttemptDbCkrealloc, /* 431 */
+ Tcl_AttemptSetObjLength, /* 432 */
+ Tcl_GetChannelThread, /* 433 */
+ Tcl_GetUnicodeFromObj, /* 434 */
+ Tcl_GetMathFuncInfo, /* 435 */
+ Tcl_ListMathFuncs, /* 436 */
+ Tcl_SubstObj, /* 437 */
+ Tcl_DetachChannel, /* 438 */
+ Tcl_IsStandardChannel, /* 439 */
+ Tcl_FSCopyFile, /* 440 */
+ Tcl_FSCopyDirectory, /* 441 */
+ Tcl_FSCreateDirectory, /* 442 */
+ Tcl_FSDeleteFile, /* 443 */
+ Tcl_FSLoadFile, /* 444 */
+ Tcl_FSMatchInDirectory, /* 445 */
+ Tcl_FSLink, /* 446 */
+ Tcl_FSRemoveDirectory, /* 447 */
+ Tcl_FSRenameFile, /* 448 */
+ Tcl_FSLstat, /* 449 */
+ Tcl_FSUtime, /* 450 */
+ Tcl_FSFileAttrsGet, /* 451 */
+ Tcl_FSFileAttrsSet, /* 452 */
+ Tcl_FSFileAttrStrings, /* 453 */
+ Tcl_FSStat, /* 454 */
+ Tcl_FSAccess, /* 455 */
+ Tcl_FSOpenFileChannel, /* 456 */
+ Tcl_FSGetCwd, /* 457 */
+ Tcl_FSChdir, /* 458 */
+ Tcl_FSConvertToPathType, /* 459 */
+ Tcl_FSJoinPath, /* 460 */
+ Tcl_FSSplitPath, /* 461 */
+ Tcl_FSEqualPaths, /* 462 */
+ Tcl_FSGetNormalizedPath, /* 463 */
+ Tcl_FSJoinToPath, /* 464 */
+ Tcl_FSGetInternalRep, /* 465 */
+ Tcl_FSGetTranslatedPath, /* 466 */
+ Tcl_FSEvalFile, /* 467 */
+ Tcl_FSNewNativePath, /* 468 */
+ Tcl_FSGetNativePath, /* 469 */
+ Tcl_FSFileSystemInfo, /* 470 */
+ Tcl_FSPathSeparator, /* 471 */
+ Tcl_FSListVolumes, /* 472 */
+ Tcl_FSRegister, /* 473 */
+ Tcl_FSUnregister, /* 474 */
+ Tcl_FSData, /* 475 */
+ Tcl_FSGetTranslatedStringPath, /* 476 */
+ Tcl_FSGetFileSystemForPath, /* 477 */
+ Tcl_FSGetPathType, /* 478 */
+ Tcl_OutputBuffered, /* 479 */
+ Tcl_FSMountsChanged, /* 480 */
+ Tcl_EvalTokensStandard, /* 481 */
+ Tcl_GetTime, /* 482 */
+ Tcl_CreateObjTrace, /* 483 */
+ Tcl_GetCommandInfoFromToken, /* 484 */
+ Tcl_SetCommandInfoFromToken, /* 485 */
+ Tcl_DbNewWideIntObj, /* 486 */
+ Tcl_GetWideIntFromObj, /* 487 */
+ Tcl_NewWideIntObj, /* 488 */
+ Tcl_SetWideIntObj, /* 489 */
+ Tcl_AllocStatBuf, /* 490 */
+ Tcl_Seek, /* 491 */
+ Tcl_Tell, /* 492 */
+ Tcl_ChannelWideSeekProc, /* 493 */
};
/* !END!: Do not edit above this line. */
-
#undef Tcl_InitStubs
#endif
-char *
+CONST char *
Tcl_InitStubs (interp, version, exact)
Tcl_Interp *interp;
- char *version;
+ CONST char *version;
int exact;
{
- char *actualVersion;
+ CONST char *actualVersion;
TclStubs *tmp;
if (!tclStubsPtr) {
+++ /dev/null
-/*
- * tclStubs.c --
- *
- * This file contains the wrapper functions for the platform independent
- * public Tcl API.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id$
- */
-
-#include "tcl.h"
-
-/*
- * Undefine function macros that will interfere with the defintions below.
- */
-
-#undef Tcl_Alloc
-#undef Tcl_Free
-#undef Tcl_Realloc
-#undef Tcl_NewBooleanObj
-#undef Tcl_NewByteArrayObj
-#undef Tcl_NewDoubleObj
-#undef Tcl_NewIntObj
-#undef Tcl_NewListObj
-#undef Tcl_NewLongObj
-#undef Tcl_NewObj
-#undef Tcl_NewStringObj
-#undef Tcl_InitMemory
-#undef Tcl_DumpActiveMemory
-#undef Tcl_ValidateAllMemory
-#undef Tcl_EvalObj
-#undef Tcl_GlobalEvalObj
-#undef Tcl_MutexLock
-#undef Tcl_MutexUnlock
-#undef Tcl_ConditionNotify
-#undef Tcl_ConditionWait
-
-/*
- * WARNING: This file is automatically generated by the tools/genStubs.tcl
- * script. Any modifications to the function declarations below should be made
- * in the generic/tcl.decls script.
- */
-
-/* !BEGIN!: Do not edit below this line. */
-
-/*
- * Exported stub functions:
- */
-
-/* Slot 0 */
-int
-Tcl_PkgProvideEx(interp, name, version, clientData)
- Tcl_Interp * interp;
- char * name;
- char * version;
- ClientData clientData;
-{
- return (tclStubsPtr->tcl_PkgProvideEx)(interp, name, version, clientData);
-}
-
-/* Slot 1 */
-char *
-Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
- Tcl_Interp * interp;
- char * name;
- char * version;
- int exact;
- ClientData * clientDataPtr;
-{
- return (tclStubsPtr->tcl_PkgRequireEx)(interp, name, version, exact, clientDataPtr);
-}
-
-/* Slot 2 */
-void
-Tcl_Panic TCL_VARARGS_DEF(char *,format)
-{
- char * var;
- va_list argList;
-
- var = (char *) TCL_VARARGS_START(char *,format,argList);
-
- (tclStubsPtr->tcl_PanicVA)(var, argList);
- va_end(argList);
-}
-
-/* Slot 3 */
-char *
-Tcl_Alloc(size)
- unsigned int size;
-{
- return (tclStubsPtr->tcl_Alloc)(size);
-}
-
-/* Slot 4 */
-void
-Tcl_Free(ptr)
- char * ptr;
-{
- (tclStubsPtr->tcl_Free)(ptr);
-}
-
-/* Slot 5 */
-char *
-Tcl_Realloc(ptr, size)
- char * ptr;
- unsigned int size;
-{
- return (tclStubsPtr->tcl_Realloc)(ptr, size);
-}
-
-/* Slot 6 */
-char *
-Tcl_DbCkalloc(size, file, line)
- unsigned int size;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbCkalloc)(size, file, line);
-}
-
-/* Slot 7 */
-int
-Tcl_DbCkfree(ptr, file, line)
- char * ptr;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbCkfree)(ptr, file, line);
-}
-
-/* Slot 8 */
-char *
-Tcl_DbCkrealloc(ptr, size, file, line)
- char * ptr;
- unsigned int size;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbCkrealloc)(ptr, size, file, line);
-}
-
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
-/* Slot 9 */
-void
-Tcl_CreateFileHandler(fd, mask, proc, clientData)
- int fd;
- int mask;
- Tcl_FileProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CreateFileHandler)(fd, mask, proc, clientData);
-}
-
-#endif /* UNIX */
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
-/* Slot 10 */
-void
-Tcl_DeleteFileHandler(fd)
- int fd;
-{
- (tclStubsPtr->tcl_DeleteFileHandler)(fd);
-}
-
-#endif /* UNIX */
-/* Slot 11 */
-void
-Tcl_SetTimer(timePtr)
- Tcl_Time * timePtr;
-{
- (tclStubsPtr->tcl_SetTimer)(timePtr);
-}
-
-/* Slot 12 */
-void
-Tcl_Sleep(ms)
- int ms;
-{
- (tclStubsPtr->tcl_Sleep)(ms);
-}
-
-/* Slot 13 */
-int
-Tcl_WaitForEvent(timePtr)
- Tcl_Time * timePtr;
-{
- return (tclStubsPtr->tcl_WaitForEvent)(timePtr);
-}
-
-/* Slot 14 */
-int
-Tcl_AppendAllObjTypes(interp, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_AppendAllObjTypes)(interp, objPtr);
-}
-
-/* Slot 15 */
-void
-Tcl_AppendStringsToObj TCL_VARARGS_DEF(Tcl_Obj *,objPtr)
-{
- Tcl_Obj * var;
- va_list argList;
-
- var = (Tcl_Obj *) TCL_VARARGS_START(Tcl_Obj *,objPtr,argList);
-
- (tclStubsPtr->tcl_AppendStringsToObjVA)(var, argList);
- va_end(argList);
-}
-
-/* Slot 16 */
-void
-Tcl_AppendToObj(objPtr, bytes, length)
- Tcl_Obj * objPtr;
- char * bytes;
- int length;
-{
- (tclStubsPtr->tcl_AppendToObj)(objPtr, bytes, length);
-}
-
-/* Slot 17 */
-Tcl_Obj *
-Tcl_ConcatObj(objc, objv)
- int objc;
- Tcl_Obj *CONST objv[];
-{
- return (tclStubsPtr->tcl_ConcatObj)(objc, objv);
-}
-
-/* Slot 18 */
-int
-Tcl_ConvertToType(interp, objPtr, typePtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- Tcl_ObjType * typePtr;
-{
- return (tclStubsPtr->tcl_ConvertToType)(interp, objPtr, typePtr);
-}
-
-/* Slot 19 */
-void
-Tcl_DbDecrRefCount(objPtr, file, line)
- Tcl_Obj * objPtr;
- char * file;
- int line;
-{
- (tclStubsPtr->tcl_DbDecrRefCount)(objPtr, file, line);
-}
-
-/* Slot 20 */
-void
-Tcl_DbIncrRefCount(objPtr, file, line)
- Tcl_Obj * objPtr;
- char * file;
- int line;
-{
- (tclStubsPtr->tcl_DbIncrRefCount)(objPtr, file, line);
-}
-
-/* Slot 21 */
-int
-Tcl_DbIsShared(objPtr, file, line)
- Tcl_Obj * objPtr;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbIsShared)(objPtr, file, line);
-}
-
-/* Slot 22 */
-Tcl_Obj *
-Tcl_DbNewBooleanObj(boolValue, file, line)
- int boolValue;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbNewBooleanObj)(boolValue, file, line);
-}
-
-/* Slot 23 */
-Tcl_Obj *
-Tcl_DbNewByteArrayObj(bytes, length, file, line)
- unsigned char * bytes;
- int length;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbNewByteArrayObj)(bytes, length, file, line);
-}
-
-/* Slot 24 */
-Tcl_Obj *
-Tcl_DbNewDoubleObj(doubleValue, file, line)
- double doubleValue;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbNewDoubleObj)(doubleValue, file, line);
-}
-
-/* Slot 25 */
-Tcl_Obj *
-Tcl_DbNewListObj(objc, objv, file, line)
- int objc;
- Tcl_Obj *CONST objv[];
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbNewListObj)(objc, objv, file, line);
-}
-
-/* Slot 26 */
-Tcl_Obj *
-Tcl_DbNewLongObj(longValue, file, line)
- long longValue;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbNewLongObj)(longValue, file, line);
-}
-
-/* Slot 27 */
-Tcl_Obj *
-Tcl_DbNewObj(file, line)
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbNewObj)(file, line);
-}
-
-/* Slot 28 */
-Tcl_Obj *
-Tcl_DbNewStringObj(bytes, length, file, line)
- CONST char * bytes;
- int length;
- char * file;
- int line;
-{
- return (tclStubsPtr->tcl_DbNewStringObj)(bytes, length, file, line);
-}
-
-/* Slot 29 */
-Tcl_Obj *
-Tcl_DuplicateObj(objPtr)
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_DuplicateObj)(objPtr);
-}
-
-/* Slot 30 */
-void
-TclFreeObj(objPtr)
- Tcl_Obj * objPtr;
-{
- (tclStubsPtr->tclFreeObj)(objPtr);
-}
-
-/* Slot 31 */
-int
-Tcl_GetBoolean(interp, str, boolPtr)
- Tcl_Interp * interp;
- char * str;
- int * boolPtr;
-{
- return (tclStubsPtr->tcl_GetBoolean)(interp, str, boolPtr);
-}
-
-/* Slot 32 */
-int
-Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- int * boolPtr;
-{
- return (tclStubsPtr->tcl_GetBooleanFromObj)(interp, objPtr, boolPtr);
-}
-
-/* Slot 33 */
-unsigned char *
-Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
- Tcl_Obj * objPtr;
- int * lengthPtr;
-{
- return (tclStubsPtr->tcl_GetByteArrayFromObj)(objPtr, lengthPtr);
-}
-
-/* Slot 34 */
-int
-Tcl_GetDouble(interp, str, doublePtr)
- Tcl_Interp * interp;
- char * str;
- double * doublePtr;
-{
- return (tclStubsPtr->tcl_GetDouble)(interp, str, doublePtr);
-}
-
-/* Slot 35 */
-int
-Tcl_GetDoubleFromObj(interp, objPtr, doublePtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- double * doublePtr;
-{
- return (tclStubsPtr->tcl_GetDoubleFromObj)(interp, objPtr, doublePtr);
-}
-
-/* Slot 36 */
-int
-Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- char ** tablePtr;
- char * msg;
- int flags;
- int * indexPtr;
-{
- return (tclStubsPtr->tcl_GetIndexFromObj)(interp, objPtr, tablePtr, msg, flags, indexPtr);
-}
-
-/* Slot 37 */
-int
-Tcl_GetInt(interp, str, intPtr)
- Tcl_Interp * interp;
- char * str;
- int * intPtr;
-{
- return (tclStubsPtr->tcl_GetInt)(interp, str, intPtr);
-}
-
-/* Slot 38 */
-int
-Tcl_GetIntFromObj(interp, objPtr, intPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- int * intPtr;
-{
- return (tclStubsPtr->tcl_GetIntFromObj)(interp, objPtr, intPtr);
-}
-
-/* Slot 39 */
-int
-Tcl_GetLongFromObj(interp, objPtr, longPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- long * longPtr;
-{
- return (tclStubsPtr->tcl_GetLongFromObj)(interp, objPtr, longPtr);
-}
-
-/* Slot 40 */
-Tcl_ObjType *
-Tcl_GetObjType(typeName)
- char * typeName;
-{
- return (tclStubsPtr->tcl_GetObjType)(typeName);
-}
-
-/* Slot 41 */
-char *
-Tcl_GetStringFromObj(objPtr, lengthPtr)
- Tcl_Obj * objPtr;
- int * lengthPtr;
-{
- return (tclStubsPtr->tcl_GetStringFromObj)(objPtr, lengthPtr);
-}
-
-/* Slot 42 */
-void
-Tcl_InvalidateStringRep(objPtr)
- Tcl_Obj * objPtr;
-{
- (tclStubsPtr->tcl_InvalidateStringRep)(objPtr);
-}
-
-/* Slot 43 */
-int
-Tcl_ListObjAppendList(interp, listPtr, elemListPtr)
- Tcl_Interp * interp;
- Tcl_Obj * listPtr;
- Tcl_Obj * elemListPtr;
-{
- return (tclStubsPtr->tcl_ListObjAppendList)(interp, listPtr, elemListPtr);
-}
-
-/* Slot 44 */
-int
-Tcl_ListObjAppendElement(interp, listPtr, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * listPtr;
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_ListObjAppendElement)(interp, listPtr, objPtr);
-}
-
-/* Slot 45 */
-int
-Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr)
- Tcl_Interp * interp;
- Tcl_Obj * listPtr;
- int * objcPtr;
- Tcl_Obj *** objvPtr;
-{
- return (tclStubsPtr->tcl_ListObjGetElements)(interp, listPtr, objcPtr, objvPtr);
-}
-
-/* Slot 46 */
-int
-Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr)
- Tcl_Interp * interp;
- Tcl_Obj * listPtr;
- int index;
- Tcl_Obj ** objPtrPtr;
-{
- return (tclStubsPtr->tcl_ListObjIndex)(interp, listPtr, index, objPtrPtr);
-}
-
-/* Slot 47 */
-int
-Tcl_ListObjLength(interp, listPtr, intPtr)
- Tcl_Interp * interp;
- Tcl_Obj * listPtr;
- int * intPtr;
-{
- return (tclStubsPtr->tcl_ListObjLength)(interp, listPtr, intPtr);
-}
-
-/* Slot 48 */
-int
-Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
- Tcl_Interp * interp;
- Tcl_Obj * listPtr;
- int first;
- int count;
- int objc;
- Tcl_Obj *CONST objv[];
-{
- return (tclStubsPtr->tcl_ListObjReplace)(interp, listPtr, first, count, objc, objv);
-}
-
-/* Slot 49 */
-Tcl_Obj *
-Tcl_NewBooleanObj(boolValue)
- int boolValue;
-{
- return (tclStubsPtr->tcl_NewBooleanObj)(boolValue);
-}
-
-/* Slot 50 */
-Tcl_Obj *
-Tcl_NewByteArrayObj(bytes, length)
- unsigned char * bytes;
- int length;
-{
- return (tclStubsPtr->tcl_NewByteArrayObj)(bytes, length);
-}
-
-/* Slot 51 */
-Tcl_Obj *
-Tcl_NewDoubleObj(doubleValue)
- double doubleValue;
-{
- return (tclStubsPtr->tcl_NewDoubleObj)(doubleValue);
-}
-
-/* Slot 52 */
-Tcl_Obj *
-Tcl_NewIntObj(intValue)
- int intValue;
-{
- return (tclStubsPtr->tcl_NewIntObj)(intValue);
-}
-
-/* Slot 53 */
-Tcl_Obj *
-Tcl_NewListObj(objc, objv)
- int objc;
- Tcl_Obj *CONST objv[];
-{
- return (tclStubsPtr->tcl_NewListObj)(objc, objv);
-}
-
-/* Slot 54 */
-Tcl_Obj *
-Tcl_NewLongObj(longValue)
- long longValue;
-{
- return (tclStubsPtr->tcl_NewLongObj)(longValue);
-}
-
-/* Slot 55 */
-Tcl_Obj *
-Tcl_NewObj()
-{
- return (tclStubsPtr->tcl_NewObj)();
-}
-
-/* Slot 56 */
-Tcl_Obj *
-Tcl_NewStringObj(bytes, length)
- CONST char * bytes;
- int length;
-{
- return (tclStubsPtr->tcl_NewStringObj)(bytes, length);
-}
-
-/* Slot 57 */
-void
-Tcl_SetBooleanObj(objPtr, boolValue)
- Tcl_Obj * objPtr;
- int boolValue;
-{
- (tclStubsPtr->tcl_SetBooleanObj)(objPtr, boolValue);
-}
-
-/* Slot 58 */
-unsigned char *
-Tcl_SetByteArrayLength(objPtr, length)
- Tcl_Obj * objPtr;
- int length;
-{
- return (tclStubsPtr->tcl_SetByteArrayLength)(objPtr, length);
-}
-
-/* Slot 59 */
-void
-Tcl_SetByteArrayObj(objPtr, bytes, length)
- Tcl_Obj * objPtr;
- unsigned char * bytes;
- int length;
-{
- (tclStubsPtr->tcl_SetByteArrayObj)(objPtr, bytes, length);
-}
-
-/* Slot 60 */
-void
-Tcl_SetDoubleObj(objPtr, doubleValue)
- Tcl_Obj * objPtr;
- double doubleValue;
-{
- (tclStubsPtr->tcl_SetDoubleObj)(objPtr, doubleValue);
-}
-
-/* Slot 61 */
-void
-Tcl_SetIntObj(objPtr, intValue)
- Tcl_Obj * objPtr;
- int intValue;
-{
- (tclStubsPtr->tcl_SetIntObj)(objPtr, intValue);
-}
-
-/* Slot 62 */
-void
-Tcl_SetListObj(objPtr, objc, objv)
- Tcl_Obj * objPtr;
- int objc;
- Tcl_Obj *CONST objv[];
-{
- (tclStubsPtr->tcl_SetListObj)(objPtr, objc, objv);
-}
-
-/* Slot 63 */
-void
-Tcl_SetLongObj(objPtr, longValue)
- Tcl_Obj * objPtr;
- long longValue;
-{
- (tclStubsPtr->tcl_SetLongObj)(objPtr, longValue);
-}
-
-/* Slot 64 */
-void
-Tcl_SetObjLength(objPtr, length)
- Tcl_Obj * objPtr;
- int length;
-{
- (tclStubsPtr->tcl_SetObjLength)(objPtr, length);
-}
-
-/* Slot 65 */
-void
-Tcl_SetStringObj(objPtr, bytes, length)
- Tcl_Obj * objPtr;
- char * bytes;
- int length;
-{
- (tclStubsPtr->tcl_SetStringObj)(objPtr, bytes, length);
-}
-
-/* Slot 66 */
-void
-Tcl_AddErrorInfo(interp, message)
- Tcl_Interp * interp;
- CONST char * message;
-{
- (tclStubsPtr->tcl_AddErrorInfo)(interp, message);
-}
-
-/* Slot 67 */
-void
-Tcl_AddObjErrorInfo(interp, message, length)
- Tcl_Interp * interp;
- CONST char * message;
- int length;
-{
- (tclStubsPtr->tcl_AddObjErrorInfo)(interp, message, length);
-}
-
-/* Slot 68 */
-void
-Tcl_AllowExceptions(interp)
- Tcl_Interp * interp;
-{
- (tclStubsPtr->tcl_AllowExceptions)(interp);
-}
-
-/* Slot 69 */
-void
-Tcl_AppendElement(interp, string)
- Tcl_Interp * interp;
- CONST char * string;
-{
- (tclStubsPtr->tcl_AppendElement)(interp, string);
-}
-
-/* Slot 70 */
-void
-Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,interp)
-{
- Tcl_Interp * var;
- va_list argList;
-
- var = (Tcl_Interp *) TCL_VARARGS_START(Tcl_Interp *,interp,argList);
-
- (tclStubsPtr->tcl_AppendResultVA)(var, argList);
- va_end(argList);
-}
-
-/* Slot 71 */
-Tcl_AsyncHandler
-Tcl_AsyncCreate(proc, clientData)
- Tcl_AsyncProc * proc;
- ClientData clientData;
-{
- return (tclStubsPtr->tcl_AsyncCreate)(proc, clientData);
-}
-
-/* Slot 72 */
-void
-Tcl_AsyncDelete(async)
- Tcl_AsyncHandler async;
-{
- (tclStubsPtr->tcl_AsyncDelete)(async);
-}
-
-/* Slot 73 */
-int
-Tcl_AsyncInvoke(interp, code)
- Tcl_Interp * interp;
- int code;
-{
- return (tclStubsPtr->tcl_AsyncInvoke)(interp, code);
-}
-
-/* Slot 74 */
-void
-Tcl_AsyncMark(async)
- Tcl_AsyncHandler async;
-{
- (tclStubsPtr->tcl_AsyncMark)(async);
-}
-
-/* Slot 75 */
-int
-Tcl_AsyncReady()
-{
- return (tclStubsPtr->tcl_AsyncReady)();
-}
-
-/* Slot 76 */
-void
-Tcl_BackgroundError(interp)
- Tcl_Interp * interp;
-{
- (tclStubsPtr->tcl_BackgroundError)(interp);
-}
-
-/* Slot 77 */
-char
-Tcl_Backslash(src, readPtr)
- CONST char * src;
- int * readPtr;
-{
- return (tclStubsPtr->tcl_Backslash)(src, readPtr);
-}
-
-/* Slot 78 */
-int
-Tcl_BadChannelOption(interp, optionName, optionList)
- Tcl_Interp * interp;
- char * optionName;
- char * optionList;
-{
- return (tclStubsPtr->tcl_BadChannelOption)(interp, optionName, optionList);
-}
-
-/* Slot 79 */
-void
-Tcl_CallWhenDeleted(interp, proc, clientData)
- Tcl_Interp * interp;
- Tcl_InterpDeleteProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CallWhenDeleted)(interp, proc, clientData);
-}
-
-/* Slot 80 */
-void
-Tcl_CancelIdleCall(idleProc, clientData)
- Tcl_IdleProc * idleProc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CancelIdleCall)(idleProc, clientData);
-}
-
-/* Slot 81 */
-int
-Tcl_Close(interp, chan)
- Tcl_Interp * interp;
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_Close)(interp, chan);
-}
-
-/* Slot 82 */
-int
-Tcl_CommandComplete(cmd)
- char * cmd;
-{
- return (tclStubsPtr->tcl_CommandComplete)(cmd);
-}
-
-/* Slot 83 */
-char *
-Tcl_Concat(argc, argv)
- int argc;
- char ** argv;
-{
- return (tclStubsPtr->tcl_Concat)(argc, argv);
-}
-
-/* Slot 84 */
-int
-Tcl_ConvertElement(src, dst, flags)
- CONST char * src;
- char * dst;
- int flags;
-{
- return (tclStubsPtr->tcl_ConvertElement)(src, dst, flags);
-}
-
-/* Slot 85 */
-int
-Tcl_ConvertCountedElement(src, length, dst, flags)
- CONST char * src;
- int length;
- char * dst;
- int flags;
-{
- return (tclStubsPtr->tcl_ConvertCountedElement)(src, length, dst, flags);
-}
-
-/* Slot 86 */
-int
-Tcl_CreateAlias(slave, slaveCmd, target, targetCmd, argc, argv)
- Tcl_Interp * slave;
- char * slaveCmd;
- Tcl_Interp * target;
- char * targetCmd;
- int argc;
- char ** argv;
-{
- return (tclStubsPtr->tcl_CreateAlias)(slave, slaveCmd, target, targetCmd, argc, argv);
-}
-
-/* Slot 87 */
-int
-Tcl_CreateAliasObj(slave, slaveCmd, target, targetCmd, objc, objv)
- Tcl_Interp * slave;
- char * slaveCmd;
- Tcl_Interp * target;
- char * targetCmd;
- int objc;
- Tcl_Obj *CONST objv[];
-{
- return (tclStubsPtr->tcl_CreateAliasObj)(slave, slaveCmd, target, targetCmd, objc, objv);
-}
-
-/* Slot 88 */
-Tcl_Channel
-Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
- Tcl_ChannelType * typePtr;
- char * chanName;
- ClientData instanceData;
- int mask;
-{
- return (tclStubsPtr->tcl_CreateChannel)(typePtr, chanName, instanceData, mask);
-}
-
-/* Slot 89 */
-void
-Tcl_CreateChannelHandler(chan, mask, proc, clientData)
- Tcl_Channel chan;
- int mask;
- Tcl_ChannelProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CreateChannelHandler)(chan, mask, proc, clientData);
-}
-
-/* Slot 90 */
-void
-Tcl_CreateCloseHandler(chan, proc, clientData)
- Tcl_Channel chan;
- Tcl_CloseProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CreateCloseHandler)(chan, proc, clientData);
-}
-
-/* Slot 91 */
-Tcl_Command
-Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
- Tcl_Interp * interp;
- char * cmdName;
- Tcl_CmdProc * proc;
- ClientData clientData;
- Tcl_CmdDeleteProc * deleteProc;
-{
- return (tclStubsPtr->tcl_CreateCommand)(interp, cmdName, proc, clientData, deleteProc);
-}
-
-/* Slot 92 */
-void
-Tcl_CreateEventSource(setupProc, checkProc, clientData)
- Tcl_EventSetupProc * setupProc;
- Tcl_EventCheckProc * checkProc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CreateEventSource)(setupProc, checkProc, clientData);
-}
-
-/* Slot 93 */
-void
-Tcl_CreateExitHandler(proc, clientData)
- Tcl_ExitProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CreateExitHandler)(proc, clientData);
-}
-
-/* Slot 94 */
-Tcl_Interp *
-Tcl_CreateInterp()
-{
- return (tclStubsPtr->tcl_CreateInterp)();
-}
-
-/* Slot 95 */
-void
-Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
- Tcl_Interp * interp;
- char * name;
- int numArgs;
- Tcl_ValueType * argTypes;
- Tcl_MathProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CreateMathFunc)(interp, name, numArgs, argTypes, proc, clientData);
-}
-
-/* Slot 96 */
-Tcl_Command
-Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
- Tcl_Interp * interp;
- char * cmdName;
- Tcl_ObjCmdProc * proc;
- ClientData clientData;
- Tcl_CmdDeleteProc * deleteProc;
-{
- return (tclStubsPtr->tcl_CreateObjCommand)(interp, cmdName, proc, clientData, deleteProc);
-}
-
-/* Slot 97 */
-Tcl_Interp *
-Tcl_CreateSlave(interp, slaveName, isSafe)
- Tcl_Interp * interp;
- char * slaveName;
- int isSafe;
-{
- return (tclStubsPtr->tcl_CreateSlave)(interp, slaveName, isSafe);
-}
-
-/* Slot 98 */
-Tcl_TimerToken
-Tcl_CreateTimerHandler(milliseconds, proc, clientData)
- int milliseconds;
- Tcl_TimerProc * proc;
- ClientData clientData;
-{
- return (tclStubsPtr->tcl_CreateTimerHandler)(milliseconds, proc, clientData);
-}
-
-/* Slot 99 */
-Tcl_Trace
-Tcl_CreateTrace(interp, level, proc, clientData)
- Tcl_Interp * interp;
- int level;
- Tcl_CmdTraceProc * proc;
- ClientData clientData;
-{
- return (tclStubsPtr->tcl_CreateTrace)(interp, level, proc, clientData);
-}
-
-/* Slot 100 */
-void
-Tcl_DeleteAssocData(interp, name)
- Tcl_Interp * interp;
- char * name;
-{
- (tclStubsPtr->tcl_DeleteAssocData)(interp, name);
-}
-
-/* Slot 101 */
-void
-Tcl_DeleteChannelHandler(chan, proc, clientData)
- Tcl_Channel chan;
- Tcl_ChannelProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DeleteChannelHandler)(chan, proc, clientData);
-}
-
-/* Slot 102 */
-void
-Tcl_DeleteCloseHandler(chan, proc, clientData)
- Tcl_Channel chan;
- Tcl_CloseProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DeleteCloseHandler)(chan, proc, clientData);
-}
-
-/* Slot 103 */
-int
-Tcl_DeleteCommand(interp, cmdName)
- Tcl_Interp * interp;
- char * cmdName;
-{
- return (tclStubsPtr->tcl_DeleteCommand)(interp, cmdName);
-}
-
-/* Slot 104 */
-int
-Tcl_DeleteCommandFromToken(interp, command)
- Tcl_Interp * interp;
- Tcl_Command command;
-{
- return (tclStubsPtr->tcl_DeleteCommandFromToken)(interp, command);
-}
-
-/* Slot 105 */
-void
-Tcl_DeleteEvents(proc, clientData)
- Tcl_EventDeleteProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DeleteEvents)(proc, clientData);
-}
-
-/* Slot 106 */
-void
-Tcl_DeleteEventSource(setupProc, checkProc, clientData)
- Tcl_EventSetupProc * setupProc;
- Tcl_EventCheckProc * checkProc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DeleteEventSource)(setupProc, checkProc, clientData);
-}
-
-/* Slot 107 */
-void
-Tcl_DeleteExitHandler(proc, clientData)
- Tcl_ExitProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DeleteExitHandler)(proc, clientData);
-}
-
-/* Slot 108 */
-void
-Tcl_DeleteHashEntry(entryPtr)
- Tcl_HashEntry * entryPtr;
-{
- (tclStubsPtr->tcl_DeleteHashEntry)(entryPtr);
-}
-
-/* Slot 109 */
-void
-Tcl_DeleteHashTable(tablePtr)
- Tcl_HashTable * tablePtr;
-{
- (tclStubsPtr->tcl_DeleteHashTable)(tablePtr);
-}
-
-/* Slot 110 */
-void
-Tcl_DeleteInterp(interp)
- Tcl_Interp * interp;
-{
- (tclStubsPtr->tcl_DeleteInterp)(interp);
-}
-
-/* Slot 111 */
-void
-Tcl_DetachPids(numPids, pidPtr)
- int numPids;
- Tcl_Pid * pidPtr;
-{
- (tclStubsPtr->tcl_DetachPids)(numPids, pidPtr);
-}
-
-/* Slot 112 */
-void
-Tcl_DeleteTimerHandler(token)
- Tcl_TimerToken token;
-{
- (tclStubsPtr->tcl_DeleteTimerHandler)(token);
-}
-
-/* Slot 113 */
-void
-Tcl_DeleteTrace(interp, trace)
- Tcl_Interp * interp;
- Tcl_Trace trace;
-{
- (tclStubsPtr->tcl_DeleteTrace)(interp, trace);
-}
-
-/* Slot 114 */
-void
-Tcl_DontCallWhenDeleted(interp, proc, clientData)
- Tcl_Interp * interp;
- Tcl_InterpDeleteProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DontCallWhenDeleted)(interp, proc, clientData);
-}
-
-/* Slot 115 */
-int
-Tcl_DoOneEvent(flags)
- int flags;
-{
- return (tclStubsPtr->tcl_DoOneEvent)(flags);
-}
-
-/* Slot 116 */
-void
-Tcl_DoWhenIdle(proc, clientData)
- Tcl_IdleProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DoWhenIdle)(proc, clientData);
-}
-
-/* Slot 117 */
-char *
-Tcl_DStringAppend(dsPtr, str, length)
- Tcl_DString * dsPtr;
- CONST char * str;
- int length;
-{
- return (tclStubsPtr->tcl_DStringAppend)(dsPtr, str, length);
-}
-
-/* Slot 118 */
-char *
-Tcl_DStringAppendElement(dsPtr, string)
- Tcl_DString * dsPtr;
- CONST char * string;
-{
- return (tclStubsPtr->tcl_DStringAppendElement)(dsPtr, string);
-}
-
-/* Slot 119 */
-void
-Tcl_DStringEndSublist(dsPtr)
- Tcl_DString * dsPtr;
-{
- (tclStubsPtr->tcl_DStringEndSublist)(dsPtr);
-}
-
-/* Slot 120 */
-void
-Tcl_DStringFree(dsPtr)
- Tcl_DString * dsPtr;
-{
- (tclStubsPtr->tcl_DStringFree)(dsPtr);
-}
-
-/* Slot 121 */
-void
-Tcl_DStringGetResult(interp, dsPtr)
- Tcl_Interp * interp;
- Tcl_DString * dsPtr;
-{
- (tclStubsPtr->tcl_DStringGetResult)(interp, dsPtr);
-}
-
-/* Slot 122 */
-void
-Tcl_DStringInit(dsPtr)
- Tcl_DString * dsPtr;
-{
- (tclStubsPtr->tcl_DStringInit)(dsPtr);
-}
-
-/* Slot 123 */
-void
-Tcl_DStringResult(interp, dsPtr)
- Tcl_Interp * interp;
- Tcl_DString * dsPtr;
-{
- (tclStubsPtr->tcl_DStringResult)(interp, dsPtr);
-}
-
-/* Slot 124 */
-void
-Tcl_DStringSetLength(dsPtr, length)
- Tcl_DString * dsPtr;
- int length;
-{
- (tclStubsPtr->tcl_DStringSetLength)(dsPtr, length);
-}
-
-/* Slot 125 */
-void
-Tcl_DStringStartSublist(dsPtr)
- Tcl_DString * dsPtr;
-{
- (tclStubsPtr->tcl_DStringStartSublist)(dsPtr);
-}
-
-/* Slot 126 */
-int
-Tcl_Eof(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_Eof)(chan);
-}
-
-/* Slot 127 */
-char *
-Tcl_ErrnoId()
-{
- return (tclStubsPtr->tcl_ErrnoId)();
-}
-
-/* Slot 128 */
-char *
-Tcl_ErrnoMsg(err)
- int err;
-{
- return (tclStubsPtr->tcl_ErrnoMsg)(err);
-}
-
-/* Slot 129 */
-int
-Tcl_Eval(interp, string)
- Tcl_Interp * interp;
- char * string;
-{
- return (tclStubsPtr->tcl_Eval)(interp, string);
-}
-
-/* Slot 130 */
-int
-Tcl_EvalFile(interp, fileName)
- Tcl_Interp * interp;
- char * fileName;
-{
- return (tclStubsPtr->tcl_EvalFile)(interp, fileName);
-}
-
-/* Slot 131 */
-int
-Tcl_EvalObj(interp, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_EvalObj)(interp, objPtr);
-}
-
-/* Slot 132 */
-void
-Tcl_EventuallyFree(clientData, freeProc)
- ClientData clientData;
- Tcl_FreeProc * freeProc;
-{
- (tclStubsPtr->tcl_EventuallyFree)(clientData, freeProc);
-}
-
-/* Slot 133 */
-void
-Tcl_Exit(status)
- int status;
-{
- (tclStubsPtr->tcl_Exit)(status);
-}
-
-/* Slot 134 */
-int
-Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
- Tcl_Interp * interp;
- char * hiddenCmdToken;
- char * cmdName;
-{
- return (tclStubsPtr->tcl_ExposeCommand)(interp, hiddenCmdToken, cmdName);
-}
-
-/* Slot 135 */
-int
-Tcl_ExprBoolean(interp, str, ptr)
- Tcl_Interp * interp;
- char * str;
- int * ptr;
-{
- return (tclStubsPtr->tcl_ExprBoolean)(interp, str, ptr);
-}
-
-/* Slot 136 */
-int
-Tcl_ExprBooleanObj(interp, objPtr, ptr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- int * ptr;
-{
- return (tclStubsPtr->tcl_ExprBooleanObj)(interp, objPtr, ptr);
-}
-
-/* Slot 137 */
-int
-Tcl_ExprDouble(interp, str, ptr)
- Tcl_Interp * interp;
- char * str;
- double * ptr;
-{
- return (tclStubsPtr->tcl_ExprDouble)(interp, str, ptr);
-}
-
-/* Slot 138 */
-int
-Tcl_ExprDoubleObj(interp, objPtr, ptr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- double * ptr;
-{
- return (tclStubsPtr->tcl_ExprDoubleObj)(interp, objPtr, ptr);
-}
-
-/* Slot 139 */
-int
-Tcl_ExprLong(interp, str, ptr)
- Tcl_Interp * interp;
- char * str;
- long * ptr;
-{
- return (tclStubsPtr->tcl_ExprLong)(interp, str, ptr);
-}
-
-/* Slot 140 */
-int
-Tcl_ExprLongObj(interp, objPtr, ptr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- long * ptr;
-{
- return (tclStubsPtr->tcl_ExprLongObj)(interp, objPtr, ptr);
-}
-
-/* Slot 141 */
-int
-Tcl_ExprObj(interp, objPtr, resultPtrPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- Tcl_Obj ** resultPtrPtr;
-{
- return (tclStubsPtr->tcl_ExprObj)(interp, objPtr, resultPtrPtr);
-}
-
-/* Slot 142 */
-int
-Tcl_ExprString(interp, string)
- Tcl_Interp * interp;
- char * string;
-{
- return (tclStubsPtr->tcl_ExprString)(interp, string);
-}
-
-/* Slot 143 */
-void
-Tcl_Finalize()
-{
- (tclStubsPtr->tcl_Finalize)();
-}
-
-/* Slot 144 */
-void
-Tcl_FindExecutable(argv0)
- CONST char * argv0;
-{
- (tclStubsPtr->tcl_FindExecutable)(argv0);
-}
-
-/* Slot 145 */
-Tcl_HashEntry *
-Tcl_FirstHashEntry(tablePtr, searchPtr)
- Tcl_HashTable * tablePtr;
- Tcl_HashSearch * searchPtr;
-{
- return (tclStubsPtr->tcl_FirstHashEntry)(tablePtr, searchPtr);
-}
-
-/* Slot 146 */
-int
-Tcl_Flush(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_Flush)(chan);
-}
-
-/* Slot 147 */
-void
-Tcl_FreeResult(interp)
- Tcl_Interp * interp;
-{
- (tclStubsPtr->tcl_FreeResult)(interp);
-}
-
-/* Slot 148 */
-int
-Tcl_GetAlias(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr)
- Tcl_Interp * interp;
- char * slaveCmd;
- Tcl_Interp ** targetInterpPtr;
- char ** targetCmdPtr;
- int * argcPtr;
- char *** argvPtr;
-{
- return (tclStubsPtr->tcl_GetAlias)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr);
-}
-
-/* Slot 149 */
-int
-Tcl_GetAliasObj(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv)
- Tcl_Interp * interp;
- char * slaveCmd;
- Tcl_Interp ** targetInterpPtr;
- char ** targetCmdPtr;
- int * objcPtr;
- Tcl_Obj *** objv;
-{
- return (tclStubsPtr->tcl_GetAliasObj)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv);
-}
-
-/* Slot 150 */
-ClientData
-Tcl_GetAssocData(interp, name, procPtr)
- Tcl_Interp * interp;
- char * name;
- Tcl_InterpDeleteProc ** procPtr;
-{
- return (tclStubsPtr->tcl_GetAssocData)(interp, name, procPtr);
-}
-
-/* Slot 151 */
-Tcl_Channel
-Tcl_GetChannel(interp, chanName, modePtr)
- Tcl_Interp * interp;
- char * chanName;
- int * modePtr;
-{
- return (tclStubsPtr->tcl_GetChannel)(interp, chanName, modePtr);
-}
-
-/* Slot 152 */
-int
-Tcl_GetChannelBufferSize(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_GetChannelBufferSize)(chan);
-}
-
-/* Slot 153 */
-int
-Tcl_GetChannelHandle(chan, direction, handlePtr)
- Tcl_Channel chan;
- int direction;
- ClientData * handlePtr;
-{
- return (tclStubsPtr->tcl_GetChannelHandle)(chan, direction, handlePtr);
-}
-
-/* Slot 154 */
-ClientData
-Tcl_GetChannelInstanceData(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_GetChannelInstanceData)(chan);
-}
-
-/* Slot 155 */
-int
-Tcl_GetChannelMode(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_GetChannelMode)(chan);
-}
-
-/* Slot 156 */
-char *
-Tcl_GetChannelName(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_GetChannelName)(chan);
-}
-
-/* Slot 157 */
-int
-Tcl_GetChannelOption(interp, chan, optionName, dsPtr)
- Tcl_Interp * interp;
- Tcl_Channel chan;
- char * optionName;
- Tcl_DString * dsPtr;
-{
- return (tclStubsPtr->tcl_GetChannelOption)(interp, chan, optionName, dsPtr);
-}
-
-/* Slot 158 */
-Tcl_ChannelType *
-Tcl_GetChannelType(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_GetChannelType)(chan);
-}
-
-/* Slot 159 */
-int
-Tcl_GetCommandInfo(interp, cmdName, infoPtr)
- Tcl_Interp * interp;
- char * cmdName;
- Tcl_CmdInfo * infoPtr;
-{
- return (tclStubsPtr->tcl_GetCommandInfo)(interp, cmdName, infoPtr);
-}
-
-/* Slot 160 */
-char *
-Tcl_GetCommandName(interp, command)
- Tcl_Interp * interp;
- Tcl_Command command;
-{
- return (tclStubsPtr->tcl_GetCommandName)(interp, command);
-}
-
-/* Slot 161 */
-int
-Tcl_GetErrno()
-{
- return (tclStubsPtr->tcl_GetErrno)();
-}
-
-/* Slot 162 */
-char *
-Tcl_GetHostName()
-{
- return (tclStubsPtr->tcl_GetHostName)();
-}
-
-/* Slot 163 */
-int
-Tcl_GetInterpPath(askInterp, slaveInterp)
- Tcl_Interp * askInterp;
- Tcl_Interp * slaveInterp;
-{
- return (tclStubsPtr->tcl_GetInterpPath)(askInterp, slaveInterp);
-}
-
-/* Slot 164 */
-Tcl_Interp *
-Tcl_GetMaster(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_GetMaster)(interp);
-}
-
-/* Slot 165 */
-CONST char *
-Tcl_GetNameOfExecutable()
-{
- return (tclStubsPtr->tcl_GetNameOfExecutable)();
-}
-
-/* Slot 166 */
-Tcl_Obj *
-Tcl_GetObjResult(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_GetObjResult)(interp);
-}
-
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
-/* Slot 167 */
-int
-Tcl_GetOpenFile(interp, str, write, checkUsage, filePtr)
- Tcl_Interp * interp;
- char * str;
- int write;
- int checkUsage;
- ClientData * filePtr;
-{
- return (tclStubsPtr->tcl_GetOpenFile)(interp, str, write, checkUsage, filePtr);
-}
-
-#endif /* UNIX */
-/* Slot 168 */
-Tcl_PathType
-Tcl_GetPathType(path)
- char * path;
-{
- return (tclStubsPtr->tcl_GetPathType)(path);
-}
-
-/* Slot 169 */
-int
-Tcl_Gets(chan, dsPtr)
- Tcl_Channel chan;
- Tcl_DString * dsPtr;
-{
- return (tclStubsPtr->tcl_Gets)(chan, dsPtr);
-}
-
-/* Slot 170 */
-int
-Tcl_GetsObj(chan, objPtr)
- Tcl_Channel chan;
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_GetsObj)(chan, objPtr);
-}
-
-/* Slot 171 */
-int
-Tcl_GetServiceMode()
-{
- return (tclStubsPtr->tcl_GetServiceMode)();
-}
-
-/* Slot 172 */
-Tcl_Interp *
-Tcl_GetSlave(interp, slaveName)
- Tcl_Interp * interp;
- char * slaveName;
-{
- return (tclStubsPtr->tcl_GetSlave)(interp, slaveName);
-}
-
-/* Slot 173 */
-Tcl_Channel
-Tcl_GetStdChannel(type)
- int type;
-{
- return (tclStubsPtr->tcl_GetStdChannel)(type);
-}
-
-/* Slot 174 */
-char *
-Tcl_GetStringResult(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_GetStringResult)(interp);
-}
-
-/* Slot 175 */
-char *
-Tcl_GetVar(interp, varName, flags)
- Tcl_Interp * interp;
- char * varName;
- int flags;
-{
- return (tclStubsPtr->tcl_GetVar)(interp, varName, flags);
-}
-
-/* Slot 176 */
-char *
-Tcl_GetVar2(interp, part1, part2, flags)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- int flags;
-{
- return (tclStubsPtr->tcl_GetVar2)(interp, part1, part2, flags);
-}
-
-/* Slot 177 */
-int
-Tcl_GlobalEval(interp, command)
- Tcl_Interp * interp;
- char * command;
-{
- return (tclStubsPtr->tcl_GlobalEval)(interp, command);
-}
-
-/* Slot 178 */
-int
-Tcl_GlobalEvalObj(interp, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_GlobalEvalObj)(interp, objPtr);
-}
-
-/* Slot 179 */
-int
-Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
- Tcl_Interp * interp;
- char * cmdName;
- char * hiddenCmdToken;
-{
- return (tclStubsPtr->tcl_HideCommand)(interp, cmdName, hiddenCmdToken);
-}
-
-/* Slot 180 */
-int
-Tcl_Init(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_Init)(interp);
-}
-
-/* Slot 181 */
-void
-Tcl_InitHashTable(tablePtr, keyType)
- Tcl_HashTable * tablePtr;
- int keyType;
-{
- (tclStubsPtr->tcl_InitHashTable)(tablePtr, keyType);
-}
-
-/* Slot 182 */
-int
-Tcl_InputBlocked(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_InputBlocked)(chan);
-}
-
-/* Slot 183 */
-int
-Tcl_InputBuffered(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_InputBuffered)(chan);
-}
-
-/* Slot 184 */
-int
-Tcl_InterpDeleted(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_InterpDeleted)(interp);
-}
-
-/* Slot 185 */
-int
-Tcl_IsSafe(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_IsSafe)(interp);
-}
-
-/* Slot 186 */
-char *
-Tcl_JoinPath(argc, argv, resultPtr)
- int argc;
- CONST char ** argv;
- Tcl_DString * resultPtr;
-{
- return (tclStubsPtr->tcl_JoinPath)(argc, argv, resultPtr);
-}
-
-/* Slot 187 */
-int
-Tcl_LinkVar(interp, varName, addr, type)
- Tcl_Interp * interp;
- char * varName;
- char * addr;
- int type;
-{
- return (tclStubsPtr->tcl_LinkVar)(interp, varName, addr, type);
-}
-
-/* Slot 188 is reserved */
-/* Slot 189 */
-Tcl_Channel
-Tcl_MakeFileChannel(handle, mode)
- ClientData handle;
- int mode;
-{
- return (tclStubsPtr->tcl_MakeFileChannel)(handle, mode);
-}
-
-/* Slot 190 */
-int
-Tcl_MakeSafe(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_MakeSafe)(interp);
-}
-
-/* Slot 191 */
-Tcl_Channel
-Tcl_MakeTcpClientChannel(tcpSocket)
- ClientData tcpSocket;
-{
- return (tclStubsPtr->tcl_MakeTcpClientChannel)(tcpSocket);
-}
-
-/* Slot 192 */
-char *
-Tcl_Merge(argc, argv)
- int argc;
- char ** argv;
-{
- return (tclStubsPtr->tcl_Merge)(argc, argv);
-}
-
-/* Slot 193 */
-Tcl_HashEntry *
-Tcl_NextHashEntry(searchPtr)
- Tcl_HashSearch * searchPtr;
-{
- return (tclStubsPtr->tcl_NextHashEntry)(searchPtr);
-}
-
-/* Slot 194 */
-void
-Tcl_NotifyChannel(channel, mask)
- Tcl_Channel channel;
- int mask;
-{
- (tclStubsPtr->tcl_NotifyChannel)(channel, mask);
-}
-
-/* Slot 195 */
-Tcl_Obj *
-Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
- Tcl_Interp * interp;
- Tcl_Obj * part1Ptr;
- Tcl_Obj * part2Ptr;
- int flags;
-{
- return (tclStubsPtr->tcl_ObjGetVar2)(interp, part1Ptr, part2Ptr, flags);
-}
-
-/* Slot 196 */
-Tcl_Obj *
-Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
- Tcl_Interp * interp;
- Tcl_Obj * part1Ptr;
- Tcl_Obj * part2Ptr;
- Tcl_Obj * newValuePtr;
- int flags;
-{
- return (tclStubsPtr->tcl_ObjSetVar2)(interp, part1Ptr, part2Ptr, newValuePtr, flags);
-}
-
-/* Slot 197 */
-Tcl_Channel
-Tcl_OpenCommandChannel(interp, argc, argv, flags)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
- int flags;
-{
- return (tclStubsPtr->tcl_OpenCommandChannel)(interp, argc, argv, flags);
-}
-
-/* Slot 198 */
-Tcl_Channel
-Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
- Tcl_Interp * interp;
- char * fileName;
- char * modeString;
- int permissions;
-{
- return (tclStubsPtr->tcl_OpenFileChannel)(interp, fileName, modeString, permissions);
-}
-
-/* Slot 199 */
-Tcl_Channel
-Tcl_OpenTcpClient(interp, port, address, myaddr, myport, async)
- Tcl_Interp * interp;
- int port;
- char * address;
- char * myaddr;
- int myport;
- int async;
-{
- return (tclStubsPtr->tcl_OpenTcpClient)(interp, port, address, myaddr, myport, async);
-}
-
-/* Slot 200 */
-Tcl_Channel
-Tcl_OpenTcpServer(interp, port, host, acceptProc, callbackData)
- Tcl_Interp * interp;
- int port;
- char * host;
- Tcl_TcpAcceptProc * acceptProc;
- ClientData callbackData;
-{
- return (tclStubsPtr->tcl_OpenTcpServer)(interp, port, host, acceptProc, callbackData);
-}
-
-/* Slot 201 */
-void
-Tcl_Preserve(data)
- ClientData data;
-{
- (tclStubsPtr->tcl_Preserve)(data);
-}
-
-/* Slot 202 */
-void
-Tcl_PrintDouble(interp, value, dst)
- Tcl_Interp * interp;
- double value;
- char * dst;
-{
- (tclStubsPtr->tcl_PrintDouble)(interp, value, dst);
-}
-
-/* Slot 203 */
-int
-Tcl_PutEnv(string)
- CONST char * string;
-{
- return (tclStubsPtr->tcl_PutEnv)(string);
-}
-
-/* Slot 204 */
-char *
-Tcl_PosixError(interp)
- Tcl_Interp * interp;
-{
- return (tclStubsPtr->tcl_PosixError)(interp);
-}
-
-/* Slot 205 */
-void
-Tcl_QueueEvent(evPtr, position)
- Tcl_Event * evPtr;
- Tcl_QueuePosition position;
-{
- (tclStubsPtr->tcl_QueueEvent)(evPtr, position);
-}
-
-/* Slot 206 */
-int
-Tcl_Read(chan, bufPtr, toRead)
- Tcl_Channel chan;
- char * bufPtr;
- int toRead;
-{
- return (tclStubsPtr->tcl_Read)(chan, bufPtr, toRead);
-}
-
-/* Slot 207 */
-void
-Tcl_ReapDetachedProcs()
-{
- (tclStubsPtr->tcl_ReapDetachedProcs)();
-}
-
-/* Slot 208 */
-int
-Tcl_RecordAndEval(interp, cmd, flags)
- Tcl_Interp * interp;
- char * cmd;
- int flags;
-{
- return (tclStubsPtr->tcl_RecordAndEval)(interp, cmd, flags);
-}
-
-/* Slot 209 */
-int
-Tcl_RecordAndEvalObj(interp, cmdPtr, flags)
- Tcl_Interp * interp;
- Tcl_Obj * cmdPtr;
- int flags;
-{
- return (tclStubsPtr->tcl_RecordAndEvalObj)(interp, cmdPtr, flags);
-}
-
-/* Slot 210 */
-void
-Tcl_RegisterChannel(interp, chan)
- Tcl_Interp * interp;
- Tcl_Channel chan;
-{
- (tclStubsPtr->tcl_RegisterChannel)(interp, chan);
-}
-
-/* Slot 211 */
-void
-Tcl_RegisterObjType(typePtr)
- Tcl_ObjType * typePtr;
-{
- (tclStubsPtr->tcl_RegisterObjType)(typePtr);
-}
-
-/* Slot 212 */
-Tcl_RegExp
-Tcl_RegExpCompile(interp, string)
- Tcl_Interp * interp;
- char * string;
-{
- return (tclStubsPtr->tcl_RegExpCompile)(interp, string);
-}
-
-/* Slot 213 */
-int
-Tcl_RegExpExec(interp, regexp, str, start)
- Tcl_Interp * interp;
- Tcl_RegExp regexp;
- CONST char * str;
- CONST char * start;
-{
- return (tclStubsPtr->tcl_RegExpExec)(interp, regexp, str, start);
-}
-
-/* Slot 214 */
-int
-Tcl_RegExpMatch(interp, str, pattern)
- Tcl_Interp * interp;
- char * str;
- char * pattern;
-{
- return (tclStubsPtr->tcl_RegExpMatch)(interp, str, pattern);
-}
-
-/* Slot 215 */
-void
-Tcl_RegExpRange(regexp, index, startPtr, endPtr)
- Tcl_RegExp regexp;
- int index;
- char ** startPtr;
- char ** endPtr;
-{
- (tclStubsPtr->tcl_RegExpRange)(regexp, index, startPtr, endPtr);
-}
-
-/* Slot 216 */
-void
-Tcl_Release(clientData)
- ClientData clientData;
-{
- (tclStubsPtr->tcl_Release)(clientData);
-}
-
-/* Slot 217 */
-void
-Tcl_ResetResult(interp)
- Tcl_Interp * interp;
-{
- (tclStubsPtr->tcl_ResetResult)(interp);
-}
-
-/* Slot 218 */
-int
-Tcl_ScanElement(str, flagPtr)
- CONST char * str;
- int * flagPtr;
-{
- return (tclStubsPtr->tcl_ScanElement)(str, flagPtr);
-}
-
-/* Slot 219 */
-int
-Tcl_ScanCountedElement(str, length, flagPtr)
- CONST char * str;
- int length;
- int * flagPtr;
-{
- return (tclStubsPtr->tcl_ScanCountedElement)(str, length, flagPtr);
-}
-
-/* Slot 220 */
-int
-Tcl_Seek(chan, offset, mode)
- Tcl_Channel chan;
- int offset;
- int mode;
-{
- return (tclStubsPtr->tcl_Seek)(chan, offset, mode);
-}
-
-/* Slot 221 */
-int
-Tcl_ServiceAll()
-{
- return (tclStubsPtr->tcl_ServiceAll)();
-}
-
-/* Slot 222 */
-int
-Tcl_ServiceEvent(flags)
- int flags;
-{
- return (tclStubsPtr->tcl_ServiceEvent)(flags);
-}
-
-/* Slot 223 */
-void
-Tcl_SetAssocData(interp, name, proc, clientData)
- Tcl_Interp * interp;
- char * name;
- Tcl_InterpDeleteProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_SetAssocData)(interp, name, proc, clientData);
-}
-
-/* Slot 224 */
-void
-Tcl_SetChannelBufferSize(chan, sz)
- Tcl_Channel chan;
- int sz;
-{
- (tclStubsPtr->tcl_SetChannelBufferSize)(chan, sz);
-}
-
-/* Slot 225 */
-int
-Tcl_SetChannelOption(interp, chan, optionName, newValue)
- Tcl_Interp * interp;
- Tcl_Channel chan;
- char * optionName;
- char * newValue;
-{
- return (tclStubsPtr->tcl_SetChannelOption)(interp, chan, optionName, newValue);
-}
-
-/* Slot 226 */
-int
-Tcl_SetCommandInfo(interp, cmdName, infoPtr)
- Tcl_Interp * interp;
- char * cmdName;
- Tcl_CmdInfo * infoPtr;
-{
- return (tclStubsPtr->tcl_SetCommandInfo)(interp, cmdName, infoPtr);
-}
-
-/* Slot 227 */
-void
-Tcl_SetErrno(err)
- int err;
-{
- (tclStubsPtr->tcl_SetErrno)(err);
-}
-
-/* Slot 228 */
-void
-Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,interp)
-{
- Tcl_Interp * var;
- va_list argList;
-
- var = (Tcl_Interp *) TCL_VARARGS_START(Tcl_Interp *,interp,argList);
-
- (tclStubsPtr->tcl_SetErrorCodeVA)(var, argList);
- va_end(argList);
-}
-
-/* Slot 229 */
-void
-Tcl_SetMaxBlockTime(timePtr)
- Tcl_Time * timePtr;
-{
- (tclStubsPtr->tcl_SetMaxBlockTime)(timePtr);
-}
-
-/* Slot 230 */
-void
-Tcl_SetPanicProc(panicProc)
- Tcl_PanicProc * panicProc;
-{
- (tclStubsPtr->tcl_SetPanicProc)(panicProc);
-}
-
-/* Slot 231 */
-int
-Tcl_SetRecursionLimit(interp, depth)
- Tcl_Interp * interp;
- int depth;
-{
- return (tclStubsPtr->tcl_SetRecursionLimit)(interp, depth);
-}
-
-/* Slot 232 */
-void
-Tcl_SetResult(interp, str, freeProc)
- Tcl_Interp * interp;
- char * str;
- Tcl_FreeProc * freeProc;
-{
- (tclStubsPtr->tcl_SetResult)(interp, str, freeProc);
-}
-
-/* Slot 233 */
-int
-Tcl_SetServiceMode(mode)
- int mode;
-{
- return (tclStubsPtr->tcl_SetServiceMode)(mode);
-}
-
-/* Slot 234 */
-void
-Tcl_SetObjErrorCode(interp, errorObjPtr)
- Tcl_Interp * interp;
- Tcl_Obj * errorObjPtr;
-{
- (tclStubsPtr->tcl_SetObjErrorCode)(interp, errorObjPtr);
-}
-
-/* Slot 235 */
-void
-Tcl_SetObjResult(interp, resultObjPtr)
- Tcl_Interp * interp;
- Tcl_Obj * resultObjPtr;
-{
- (tclStubsPtr->tcl_SetObjResult)(interp, resultObjPtr);
-}
-
-/* Slot 236 */
-void
-Tcl_SetStdChannel(channel, type)
- Tcl_Channel channel;
- int type;
-{
- (tclStubsPtr->tcl_SetStdChannel)(channel, type);
-}
-
-/* Slot 237 */
-char *
-Tcl_SetVar(interp, varName, newValue, flags)
- Tcl_Interp * interp;
- char * varName;
- char * newValue;
- int flags;
-{
- return (tclStubsPtr->tcl_SetVar)(interp, varName, newValue, flags);
-}
-
-/* Slot 238 */
-char *
-Tcl_SetVar2(interp, part1, part2, newValue, flags)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- char * newValue;
- int flags;
-{
- return (tclStubsPtr->tcl_SetVar2)(interp, part1, part2, newValue, flags);
-}
-
-/* Slot 239 */
-char *
-Tcl_SignalId(sig)
- int sig;
-{
- return (tclStubsPtr->tcl_SignalId)(sig);
-}
-
-/* Slot 240 */
-char *
-Tcl_SignalMsg(sig)
- int sig;
-{
- return (tclStubsPtr->tcl_SignalMsg)(sig);
-}
-
-/* Slot 241 */
-void
-Tcl_SourceRCFile(interp)
- Tcl_Interp * interp;
-{
- (tclStubsPtr->tcl_SourceRCFile)(interp);
-}
-
-/* Slot 242 */
-int
-Tcl_SplitList(interp, listStr, argcPtr, argvPtr)
- Tcl_Interp * interp;
- CONST char * listStr;
- int * argcPtr;
- char *** argvPtr;
-{
- return (tclStubsPtr->tcl_SplitList)(interp, listStr, argcPtr, argvPtr);
-}
-
-/* Slot 243 */
-void
-Tcl_SplitPath(path, argcPtr, argvPtr)
- CONST char * path;
- int * argcPtr;
- char *** argvPtr;
-{
- (tclStubsPtr->tcl_SplitPath)(path, argcPtr, argvPtr);
-}
-
-/* Slot 244 */
-void
-Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
- Tcl_Interp * interp;
- char * pkgName;
- Tcl_PackageInitProc * initProc;
- Tcl_PackageInitProc * safeInitProc;
-{
- (tclStubsPtr->tcl_StaticPackage)(interp, pkgName, initProc, safeInitProc);
-}
-
-/* Slot 245 */
-int
-Tcl_StringMatch(str, pattern)
- CONST char * str;
- CONST char * pattern;
-{
- return (tclStubsPtr->tcl_StringMatch)(str, pattern);
-}
-
-/* Slot 246 */
-int
-Tcl_Tell(chan)
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_Tell)(chan);
-}
-
-/* Slot 247 */
-int
-Tcl_TraceVar(interp, varName, flags, proc, clientData)
- Tcl_Interp * interp;
- char * varName;
- int flags;
- Tcl_VarTraceProc * proc;
- ClientData clientData;
-{
- return (tclStubsPtr->tcl_TraceVar)(interp, varName, flags, proc, clientData);
-}
-
-/* Slot 248 */
-int
-Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- int flags;
- Tcl_VarTraceProc * proc;
- ClientData clientData;
-{
- return (tclStubsPtr->tcl_TraceVar2)(interp, part1, part2, flags, proc, clientData);
-}
-
-/* Slot 249 */
-char *
-Tcl_TranslateFileName(interp, name, bufferPtr)
- Tcl_Interp * interp;
- CONST char * name;
- Tcl_DString * bufferPtr;
-{
- return (tclStubsPtr->tcl_TranslateFileName)(interp, name, bufferPtr);
-}
-
-/* Slot 250 */
-int
-Tcl_Ungets(chan, str, len, atHead)
- Tcl_Channel chan;
- char * str;
- int len;
- int atHead;
-{
- return (tclStubsPtr->tcl_Ungets)(chan, str, len, atHead);
-}
-
-/* Slot 251 */
-void
-Tcl_UnlinkVar(interp, varName)
- Tcl_Interp * interp;
- char * varName;
-{
- (tclStubsPtr->tcl_UnlinkVar)(interp, varName);
-}
-
-/* Slot 252 */
-int
-Tcl_UnregisterChannel(interp, chan)
- Tcl_Interp * interp;
- Tcl_Channel chan;
-{
- return (tclStubsPtr->tcl_UnregisterChannel)(interp, chan);
-}
-
-/* Slot 253 */
-int
-Tcl_UnsetVar(interp, varName, flags)
- Tcl_Interp * interp;
- char * varName;
- int flags;
-{
- return (tclStubsPtr->tcl_UnsetVar)(interp, varName, flags);
-}
-
-/* Slot 254 */
-int
-Tcl_UnsetVar2(interp, part1, part2, flags)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- int flags;
-{
- return (tclStubsPtr->tcl_UnsetVar2)(interp, part1, part2, flags);
-}
-
-/* Slot 255 */
-void
-Tcl_UntraceVar(interp, varName, flags, proc, clientData)
- Tcl_Interp * interp;
- char * varName;
- int flags;
- Tcl_VarTraceProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_UntraceVar)(interp, varName, flags, proc, clientData);
-}
-
-/* Slot 256 */
-void
-Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- int flags;
- Tcl_VarTraceProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_UntraceVar2)(interp, part1, part2, flags, proc, clientData);
-}
-
-/* Slot 257 */
-void
-Tcl_UpdateLinkedVar(interp, varName)
- Tcl_Interp * interp;
- char * varName;
-{
- (tclStubsPtr->tcl_UpdateLinkedVar)(interp, varName);
-}
-
-/* Slot 258 */
-int
-Tcl_UpVar(interp, frameName, varName, localName, flags)
- Tcl_Interp * interp;
- char * frameName;
- char * varName;
- char * localName;
- int flags;
-{
- return (tclStubsPtr->tcl_UpVar)(interp, frameName, varName, localName, flags);
-}
-
-/* Slot 259 */
-int
-Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
- Tcl_Interp * interp;
- char * frameName;
- char * part1;
- char * part2;
- char * localName;
- int flags;
-{
- return (tclStubsPtr->tcl_UpVar2)(interp, frameName, part1, part2, localName, flags);
-}
-
-/* Slot 260 */
-int
-Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,interp)
-{
- Tcl_Interp * var;
- va_list argList;
- int resultValue;
-
- var = (Tcl_Interp *) TCL_VARARGS_START(Tcl_Interp *,interp,argList);
-
- resultValue = (tclStubsPtr->tcl_VarEvalVA)(var, argList);
- va_end(argList);
-return resultValue;
-}
-
-/* Slot 261 */
-ClientData
-Tcl_VarTraceInfo(interp, varName, flags, procPtr, prevClientData)
- Tcl_Interp * interp;
- char * varName;
- int flags;
- Tcl_VarTraceProc * procPtr;
- ClientData prevClientData;
-{
- return (tclStubsPtr->tcl_VarTraceInfo)(interp, varName, flags, procPtr, prevClientData);
-}
-
-/* Slot 262 */
-ClientData
-Tcl_VarTraceInfo2(interp, part1, part2, flags, procPtr, prevClientData)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- int flags;
- Tcl_VarTraceProc * procPtr;
- ClientData prevClientData;
-{
- return (tclStubsPtr->tcl_VarTraceInfo2)(interp, part1, part2, flags, procPtr, prevClientData);
-}
-
-/* Slot 263 */
-int
-Tcl_Write(chan, s, slen)
- Tcl_Channel chan;
- char * s;
- int slen;
-{
- return (tclStubsPtr->tcl_Write)(chan, s, slen);
-}
-
-/* Slot 264 */
-void
-Tcl_WrongNumArgs(interp, objc, objv, message)
- Tcl_Interp * interp;
- int objc;
- Tcl_Obj *CONST objv[];
- char * message;
-{
- (tclStubsPtr->tcl_WrongNumArgs)(interp, objc, objv, message);
-}
-
-/* Slot 265 */
-int
-Tcl_DumpActiveMemory(fileName)
- char * fileName;
-{
- return (tclStubsPtr->tcl_DumpActiveMemory)(fileName);
-}
-
-/* Slot 266 */
-void
-Tcl_ValidateAllMemory(file, line)
- char * file;
- int line;
-{
- (tclStubsPtr->tcl_ValidateAllMemory)(file, line);
-}
-
-/* Slot 267 */
-void
-Tcl_AppendResultVA(interp, argList)
- Tcl_Interp * interp;
- va_list argList;
-{
- (tclStubsPtr->tcl_AppendResultVA)(interp, argList);
-}
-
-/* Slot 268 */
-void
-Tcl_AppendStringsToObjVA(objPtr, argList)
- Tcl_Obj * objPtr;
- va_list argList;
-{
- (tclStubsPtr->tcl_AppendStringsToObjVA)(objPtr, argList);
-}
-
-/* Slot 269 */
-char *
-Tcl_HashStats(tablePtr)
- Tcl_HashTable * tablePtr;
-{
- return (tclStubsPtr->tcl_HashStats)(tablePtr);
-}
-
-/* Slot 270 */
-char *
-Tcl_ParseVar(interp, str, termPtr)
- Tcl_Interp * interp;
- char * str;
- char ** termPtr;
-{
- return (tclStubsPtr->tcl_ParseVar)(interp, str, termPtr);
-}
-
-/* Slot 271 */
-char *
-Tcl_PkgPresent(interp, name, version, exact)
- Tcl_Interp * interp;
- char * name;
- char * version;
- int exact;
-{
- return (tclStubsPtr->tcl_PkgPresent)(interp, name, version, exact);
-}
-
-/* Slot 272 */
-char *
-Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
- Tcl_Interp * interp;
- char * name;
- char * version;
- int exact;
- ClientData * clientDataPtr;
-{
- return (tclStubsPtr->tcl_PkgPresentEx)(interp, name, version, exact, clientDataPtr);
-}
-
-/* Slot 273 */
-int
-Tcl_PkgProvide(interp, name, version)
- Tcl_Interp * interp;
- char * name;
- char * version;
-{
- return (tclStubsPtr->tcl_PkgProvide)(interp, name, version);
-}
-
-/* Slot 274 */
-char *
-Tcl_PkgRequire(interp, name, version, exact)
- Tcl_Interp * interp;
- char * name;
- char * version;
- int exact;
-{
- return (tclStubsPtr->tcl_PkgRequire)(interp, name, version, exact);
-}
-
-/* Slot 275 */
-void
-Tcl_SetErrorCodeVA(interp, argList)
- Tcl_Interp * interp;
- va_list argList;
-{
- (tclStubsPtr->tcl_SetErrorCodeVA)(interp, argList);
-}
-
-/* Slot 276 */
-int
-Tcl_VarEvalVA(interp, argList)
- Tcl_Interp * interp;
- va_list argList;
-{
- return (tclStubsPtr->tcl_VarEvalVA)(interp, argList);
-}
-
-/* Slot 277 */
-Tcl_Pid
-Tcl_WaitPid(pid, statPtr, options)
- Tcl_Pid pid;
- int * statPtr;
- int options;
-{
- return (tclStubsPtr->tcl_WaitPid)(pid, statPtr, options);
-}
-
-/* Slot 278 */
-void
-Tcl_PanicVA(format, argList)
- char * format;
- va_list argList;
-{
- (tclStubsPtr->tcl_PanicVA)(format, argList);
-}
-
-/* Slot 279 */
-void
-Tcl_GetVersion(major, minor, patchLevel, type)
- int * major;
- int * minor;
- int * patchLevel;
- int * type;
-{
- (tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel, type);
-}
-
-/* Slot 280 is reserved */
-/* Slot 281 is reserved */
-/* Slot 282 is reserved */
-/* Slot 283 is reserved */
-/* Slot 284 is reserved */
-/* Slot 285 is reserved */
-/* Slot 286 */
-void
-Tcl_AppendObjToObj(objPtr, appendObjPtr)
- Tcl_Obj * objPtr;
- Tcl_Obj * appendObjPtr;
-{
- (tclStubsPtr->tcl_AppendObjToObj)(objPtr, appendObjPtr);
-}
-
-/* Slot 287 */
-Tcl_Encoding
-Tcl_CreateEncoding(typePtr)
- Tcl_EncodingType * typePtr;
-{
- return (tclStubsPtr->tcl_CreateEncoding)(typePtr);
-}
-
-/* Slot 288 */
-void
-Tcl_CreateThreadExitHandler(proc, clientData)
- Tcl_ExitProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_CreateThreadExitHandler)(proc, clientData);
-}
-
-/* Slot 289 */
-void
-Tcl_DeleteThreadExitHandler(proc, clientData)
- Tcl_ExitProc * proc;
- ClientData clientData;
-{
- (tclStubsPtr->tcl_DeleteThreadExitHandler)(proc, clientData);
-}
-
-/* Slot 290 */
-void
-Tcl_DiscardResult(statePtr)
- Tcl_SavedResult * statePtr;
-{
- (tclStubsPtr->tcl_DiscardResult)(statePtr);
-}
-
-/* Slot 291 */
-int
-Tcl_EvalEx(interp, script, numBytes, flags)
- Tcl_Interp * interp;
- char * script;
- int numBytes;
- int flags;
-{
- return (tclStubsPtr->tcl_EvalEx)(interp, script, numBytes, flags);
-}
-
-/* Slot 292 */
-int
-Tcl_EvalObjv(interp, objc, objv, flags)
- Tcl_Interp * interp;
- int objc;
- Tcl_Obj *CONST objv[];
- int flags;
-{
- return (tclStubsPtr->tcl_EvalObjv)(interp, objc, objv, flags);
-}
-
-/* Slot 293 */
-int
-Tcl_EvalObjEx(interp, objPtr, flags)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- int flags;
-{
- return (tclStubsPtr->tcl_EvalObjEx)(interp, objPtr, flags);
-}
-
-/* Slot 294 */
-void
-Tcl_ExitThread(status)
- int status;
-{
- (tclStubsPtr->tcl_ExitThread)(status);
-}
-
-/* Slot 295 */
-int
-Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
- Tcl_Interp * interp;
- Tcl_Encoding encoding;
- CONST char * src;
- int srcLen;
- int flags;
- Tcl_EncodingState * statePtr;
- char * dst;
- int dstLen;
- int * srcReadPtr;
- int * dstWrotePtr;
- int * dstCharsPtr;
-{
- return (tclStubsPtr->tcl_ExternalToUtf)(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr);
-}
-
-/* Slot 296 */
-char *
-Tcl_ExternalToUtfDString(encoding, src, srcLen, dsPtr)
- Tcl_Encoding encoding;
- CONST char * src;
- int srcLen;
- Tcl_DString * dsPtr;
-{
- return (tclStubsPtr->tcl_ExternalToUtfDString)(encoding, src, srcLen, dsPtr);
-}
-
-/* Slot 297 */
-void
-Tcl_FinalizeThread()
-{
- (tclStubsPtr->tcl_FinalizeThread)();
-}
-
-/* Slot 298 */
-void
-Tcl_FinalizeNotifier(clientData)
- ClientData clientData;
-{
- (tclStubsPtr->tcl_FinalizeNotifier)(clientData);
-}
-
-/* Slot 299 */
-void
-Tcl_FreeEncoding(encoding)
- Tcl_Encoding encoding;
-{
- (tclStubsPtr->tcl_FreeEncoding)(encoding);
-}
-
-/* Slot 300 */
-Tcl_ThreadId
-Tcl_GetCurrentThread()
-{
- return (tclStubsPtr->tcl_GetCurrentThread)();
-}
-
-/* Slot 301 */
-Tcl_Encoding
-Tcl_GetEncoding(interp, name)
- Tcl_Interp * interp;
- CONST char * name;
-{
- return (tclStubsPtr->tcl_GetEncoding)(interp, name);
-}
-
-/* Slot 302 */
-char *
-Tcl_GetEncodingName(encoding)
- Tcl_Encoding encoding;
-{
- return (tclStubsPtr->tcl_GetEncodingName)(encoding);
-}
-
-/* Slot 303 */
-void
-Tcl_GetEncodingNames(interp)
- Tcl_Interp * interp;
-{
- (tclStubsPtr->tcl_GetEncodingNames)(interp);
-}
-
-/* Slot 304 */
-int
-Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- char ** tablePtr;
- int offset;
- char * msg;
- int flags;
- int * indexPtr;
-{
- return (tclStubsPtr->tcl_GetIndexFromObjStruct)(interp, objPtr, tablePtr, offset, msg, flags, indexPtr);
-}
-
-/* Slot 305 */
-VOID *
-Tcl_GetThreadData(keyPtr, size)
- Tcl_ThreadDataKey * keyPtr;
- int size;
-{
- return (tclStubsPtr->tcl_GetThreadData)(keyPtr, size);
-}
-
-/* Slot 306 */
-Tcl_Obj *
-Tcl_GetVar2Ex(interp, part1, part2, flags)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- int flags;
-{
- return (tclStubsPtr->tcl_GetVar2Ex)(interp, part1, part2, flags);
-}
-
-/* Slot 307 */
-ClientData
-Tcl_InitNotifier()
-{
- return (tclStubsPtr->tcl_InitNotifier)();
-}
-
-/* Slot 308 */
-void
-Tcl_MutexLock(mutexPtr)
- Tcl_Mutex * mutexPtr;
-{
- (tclStubsPtr->tcl_MutexLock)(mutexPtr);
-}
-
-/* Slot 309 */
-void
-Tcl_MutexUnlock(mutexPtr)
- Tcl_Mutex * mutexPtr;
-{
- (tclStubsPtr->tcl_MutexUnlock)(mutexPtr);
-}
-
-/* Slot 310 */
-void
-Tcl_ConditionNotify(condPtr)
- Tcl_Condition * condPtr;
-{
- (tclStubsPtr->tcl_ConditionNotify)(condPtr);
-}
-
-/* Slot 311 */
-void
-Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
- Tcl_Condition * condPtr;
- Tcl_Mutex * mutexPtr;
- Tcl_Time * timePtr;
-{
- (tclStubsPtr->tcl_ConditionWait)(condPtr, mutexPtr, timePtr);
-}
-
-/* Slot 312 */
-int
-Tcl_NumUtfChars(src, len)
- CONST char * src;
- int len;
-{
- return (tclStubsPtr->tcl_NumUtfChars)(src, len);
-}
-
-/* Slot 313 */
-int
-Tcl_ReadChars(channel, objPtr, charsToRead, appendFlag)
- Tcl_Channel channel;
- Tcl_Obj * objPtr;
- int charsToRead;
- int appendFlag;
-{
- return (tclStubsPtr->tcl_ReadChars)(channel, objPtr, charsToRead, appendFlag);
-}
-
-/* Slot 314 */
-void
-Tcl_RestoreResult(interp, statePtr)
- Tcl_Interp * interp;
- Tcl_SavedResult * statePtr;
-{
- (tclStubsPtr->tcl_RestoreResult)(interp, statePtr);
-}
-
-/* Slot 315 */
-void
-Tcl_SaveResult(interp, statePtr)
- Tcl_Interp * interp;
- Tcl_SavedResult * statePtr;
-{
- (tclStubsPtr->tcl_SaveResult)(interp, statePtr);
-}
-
-/* Slot 316 */
-int
-Tcl_SetSystemEncoding(interp, name)
- Tcl_Interp * interp;
- CONST char * name;
-{
- return (tclStubsPtr->tcl_SetSystemEncoding)(interp, name);
-}
-
-/* Slot 317 */
-Tcl_Obj *
-Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- Tcl_Obj * newValuePtr;
- int flags;
-{
- return (tclStubsPtr->tcl_SetVar2Ex)(interp, part1, part2, newValuePtr, flags);
-}
-
-/* Slot 318 */
-void
-Tcl_ThreadAlert(threadId)
- Tcl_ThreadId threadId;
-{
- (tclStubsPtr->tcl_ThreadAlert)(threadId);
-}
-
-/* Slot 319 */
-void
-Tcl_ThreadQueueEvent(threadId, evPtr, position)
- Tcl_ThreadId threadId;
- Tcl_Event* evPtr;
- Tcl_QueuePosition position;
-{
- (tclStubsPtr->tcl_ThreadQueueEvent)(threadId, evPtr, position);
-}
-
-/* Slot 320 */
-Tcl_UniChar
-Tcl_UniCharAtIndex(src, index)
- CONST char * src;
- int index;
-{
- return (tclStubsPtr->tcl_UniCharAtIndex)(src, index);
-}
-
-/* Slot 321 */
-Tcl_UniChar
-Tcl_UniCharToLower(ch)
- int ch;
-{
- return (tclStubsPtr->tcl_UniCharToLower)(ch);
-}
-
-/* Slot 322 */
-Tcl_UniChar
-Tcl_UniCharToTitle(ch)
- int ch;
-{
- return (tclStubsPtr->tcl_UniCharToTitle)(ch);
-}
-
-/* Slot 323 */
-Tcl_UniChar
-Tcl_UniCharToUpper(ch)
- int ch;
-{
- return (tclStubsPtr->tcl_UniCharToUpper)(ch);
-}
-
-/* Slot 324 */
-int
-Tcl_UniCharToUtf(ch, buf)
- int ch;
- char * buf;
-{
- return (tclStubsPtr->tcl_UniCharToUtf)(ch, buf);
-}
-
-/* Slot 325 */
-char *
-Tcl_UtfAtIndex(src, index)
- CONST char * src;
- int index;
-{
- return (tclStubsPtr->tcl_UtfAtIndex)(src, index);
-}
-
-/* Slot 326 */
-int
-Tcl_UtfCharComplete(src, len)
- CONST char * src;
- int len;
-{
- return (tclStubsPtr->tcl_UtfCharComplete)(src, len);
-}
-
-/* Slot 327 */
-int
-Tcl_UtfBackslash(src, readPtr, dst)
- CONST char * src;
- int * readPtr;
- char * dst;
-{
- return (tclStubsPtr->tcl_UtfBackslash)(src, readPtr, dst);
-}
-
-/* Slot 328 */
-char *
-Tcl_UtfFindFirst(src, ch)
- CONST char * src;
- int ch;
-{
- return (tclStubsPtr->tcl_UtfFindFirst)(src, ch);
-}
-
-/* Slot 329 */
-char *
-Tcl_UtfFindLast(src, ch)
- CONST char * src;
- int ch;
-{
- return (tclStubsPtr->tcl_UtfFindLast)(src, ch);
-}
-
-/* Slot 330 */
-char *
-Tcl_UtfNext(src)
- CONST char * src;
-{
- return (tclStubsPtr->tcl_UtfNext)(src);
-}
-
-/* Slot 331 */
-char *
-Tcl_UtfPrev(src, start)
- CONST char * src;
- CONST char * start;
-{
- return (tclStubsPtr->tcl_UtfPrev)(src, start);
-}
-
-/* Slot 332 */
-int
-Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
- Tcl_Interp * interp;
- Tcl_Encoding encoding;
- CONST char * src;
- int srcLen;
- int flags;
- Tcl_EncodingState * statePtr;
- char * dst;
- int dstLen;
- int * srcReadPtr;
- int * dstWrotePtr;
- int * dstCharsPtr;
-{
- return (tclStubsPtr->tcl_UtfToExternal)(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr);
-}
-
-/* Slot 333 */
-char *
-Tcl_UtfToExternalDString(encoding, src, srcLen, dsPtr)
- Tcl_Encoding encoding;
- CONST char * src;
- int srcLen;
- Tcl_DString * dsPtr;
-{
- return (tclStubsPtr->tcl_UtfToExternalDString)(encoding, src, srcLen, dsPtr);
-}
-
-/* Slot 334 */
-int
-Tcl_UtfToLower(src)
- char * src;
-{
- return (tclStubsPtr->tcl_UtfToLower)(src);
-}
-
-/* Slot 335 */
-int
-Tcl_UtfToTitle(src)
- char * src;
-{
- return (tclStubsPtr->tcl_UtfToTitle)(src);
-}
-
-/* Slot 336 */
-int
-Tcl_UtfToUniChar(src, chPtr)
- CONST char * src;
- Tcl_UniChar * chPtr;
-{
- return (tclStubsPtr->tcl_UtfToUniChar)(src, chPtr);
-}
-
-/* Slot 337 */
-int
-Tcl_UtfToUpper(src)
- char * src;
-{
- return (tclStubsPtr->tcl_UtfToUpper)(src);
-}
-
-/* Slot 338 */
-int
-Tcl_WriteChars(chan, src, srcLen)
- Tcl_Channel chan;
- CONST char * src;
- int srcLen;
-{
- return (tclStubsPtr->tcl_WriteChars)(chan, src, srcLen);
-}
-
-/* Slot 339 */
-int
-Tcl_WriteObj(chan, objPtr)
- Tcl_Channel chan;
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_WriteObj)(chan, objPtr);
-}
-
-/* Slot 340 */
-char *
-Tcl_GetString(objPtr)
- Tcl_Obj * objPtr;
-{
- return (tclStubsPtr->tcl_GetString)(objPtr);
-}
-
-/* Slot 341 */
-char *
-Tcl_GetDefaultEncodingDir()
-{
- return (tclStubsPtr->tcl_GetDefaultEncodingDir)();
-}
-
-/* Slot 342 */
-void
-Tcl_SetDefaultEncodingDir(path)
- char * path;
-{
- (tclStubsPtr->tcl_SetDefaultEncodingDir)(path);
-}
-
-/* Slot 343 */
-void
-Tcl_AlertNotifier(clientData)
- ClientData clientData;
-{
- (tclStubsPtr->tcl_AlertNotifier)(clientData);
-}
-
-/* Slot 344 */
-void
-Tcl_ServiceModeHook(mode)
- int mode;
-{
- (tclStubsPtr->tcl_ServiceModeHook)(mode);
-}
-
-
-/* !END!: Do not edit above this line. */
*/
#define TCL_TEST
-
#include "tclInt.h"
#include "tclPort.h"
+
+/*
+ * Required for Testregexp*Cmd
+ */
#include "tclRegexp.h"
-#include "tclIO.h"
+
+/*
+ * Required for TestlocaleCmd
+ */
#include <locale.h>
/*
+ * Required for the TestChannelCmd and TestChannelEventCmd
+ */
+#include "tclIO.h"
+
+/*
* Declare external functions used in Windows tests.
*/
static int freeCount;
/*
+ * Boolean flag used by the "testsetmainloop" and "testexitmainloop"
+ * commands.
+ */
+static int exitMainLoop = 0;
+
+/*
* Forward declarations for procedures defined later in this file:
*/
static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static void CmdTraceDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
int argc, char **argv));
static int CreatedCommandProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
- int argc, char **argv));
+ int argc, CONST char **argv));
static int CreatedCommandProc2 _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
- int argc, char **argv));
+ int argc, CONST char **argv));
static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
static int DelCmdProc _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static void DelDeleteProc _ANSI_ARGS_((ClientData clientData));
static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData,
static void ExitProcEven _ANSI_ARGS_((ClientData clientData));
static void ExitProcOdd _ANSI_ARGS_((ClientData clientData));
static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static void MainLoop _ANSI_ARGS_((void));
static int NoopCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
+ Tcl_Interp* interp,
+ int level,
+ CONST char* command,
+ Tcl_Command commandToken,
+ int objc,
+ Tcl_Obj *CONST objv[] ));
+static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Parse *parsePtr));
+ Tcl_Parse *parsePtr));
static void SpecialFree _ANSI_ARGS_((char *blockPtr));
static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int PretendTclpAccess _ANSI_ARGS_((CONST char *path,
+ int mode));
static int TestAccessProc1 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestAccessProc2 _ANSI_ARGS_((CONST char *path,
static int TestAccessProc3 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestasyncCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestchmodCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdcallCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdelCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetvarfullnameCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr));
-static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((Tcl_Interp *interp,
- char *filename, char *modeString, int permissions));
-static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp,
- char *filename, char *modeString, int permissions));
-static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp,
- char *filename, char *modeString, int permissions));
+static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_((
+ Tcl_Interp *interp, CONST char *fileName,
+ CONST char *modeString, int permissions));
+static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((
+ Tcl_Interp *interp, CONST char *fileName,
+ CONST char *modeString, int permissions));
+static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((
+ Tcl_Interp *interp, CONST char *fileName,
+ CONST char *modeString, int permissions));
+static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((
+ Tcl_Interp *interp, CONST char *fileName,
+ CONST char *modeString, int permissions));
static int TestpanicCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
Tcl_Obj *CONST objv[]));
static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetobjerrorcodeCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
-static int TestopenfilechannelprocCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+static int TestopenfilechannelprocCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp, int argc,
+ CONST char **argv));
static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
-static int TestsetrecursionlimitCmd _ANSI_ARGS_((
- ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[]));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int PretendTclpStat _ANSI_ARGS_((CONST char *path,
+ struct stat *buf));
static int TestStatProc1 _ANSI_ARGS_((CONST char *path,
struct stat *buf));
static int TestStatProc2 _ANSI_ARGS_((CONST char *path,
static int TestStatProc3 _ANSI_ARGS_((CONST char *path,
struct stat *buf));
static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
-static int TestChannelCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
-static int TestChannelEventCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestWrongNumArgsObjCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+static int TestChannelCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, CONST char **argv));
+/* Filesystem testing */
+
+static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+
+static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2));
+
+static Tcl_Obj *TestReportGetNativePath(Tcl_Obj* pathObjPtr);
+
+static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
+ Tcl_StatBuf *buf));
+static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,
+ int mode));
+static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ ((
+ Tcl_Interp *interp, Tcl_Obj *fileName,
+ int mode, int permissions));
+static int TestReportMatchInDirectory _ANSI_ARGS_ ((
+ Tcl_Interp *interp, Tcl_Obj *resultPtr,
+ Tcl_Obj *dirPtr, CONST char *pattern,
+ Tcl_GlobTypeData *types));
+static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));
+static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,
+ Tcl_StatBuf *buf));
+static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,
+ Tcl_Obj *dst));
+static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));
+static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,
+ Tcl_Obj *dst));
+static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));
+static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,
+ Tcl_Obj *dst, Tcl_Obj **errorPtr));
+static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,
+ int recursive, Tcl_Obj **errorPtr));
+static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,
+ Tcl_Obj *fileName,
+ Tcl_LoadHandle *handlePtr,
+ Tcl_FSUnloadFileProc **unloadProcPtr));
+static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,
+ Tcl_Obj *to, int linkType));
+static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ ((
+ Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
+static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,
+ int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
+static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,
+ int index, Tcl_Obj *fileName, Tcl_Obj *objPtr));
+static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,
+ struct utimbuf *tval));
+static int TestReportNormalizePath _ANSI_ARGS_ ((
+ Tcl_Interp *interp, Tcl_Obj *pathPtr,
+ int nextCheckpoint));
+static int TestReportInFilesystem _ANSI_ARGS_ ((Tcl_Obj *pathPtr, ClientData *clientDataPtr));
+static void TestReportFreeInternalRep _ANSI_ARGS_ ((ClientData clientData));
+static ClientData TestReportDupInternalRep _ANSI_ARGS_ ((ClientData clientData));
+
+static Tcl_Filesystem testReportingFilesystem = {
+ "reporting",
+ sizeof(Tcl_Filesystem),
+ TCL_FILESYSTEM_VERSION_1,
+ &TestReportInFilesystem, /* path in */
+ &TestReportDupInternalRep,
+ &TestReportFreeInternalRep,
+ NULL, /* native to norm */
+ NULL, /* convert to native */
+ &TestReportNormalizePath,
+ NULL, /* path type */
+ NULL, /* separator */
+ &TestReportStat,
+ &TestReportAccess,
+ &TestReportOpenFileChannel,
+ &TestReportMatchInDirectory,
+ &TestReportUtime,
+ &TestReportLink,
+ NULL /* list volumes */,
+ &TestReportFileAttrStrings,
+ &TestReportFileAttrsGet,
+ &TestReportFileAttrsSet,
+ &TestReportCreateDirectory,
+ &TestReportRemoveDirectory,
+ &TestReportDeleteFile,
+ &TestReportCopyFile,
+ &TestReportRenameFile,
+ &TestReportCopyDirectory,
+ &TestReportLstat,
+ &TestReportLoadFile,
+ NULL /* cwd */,
+ &TestReportChdir
+};
+\f
/*
* External (platform specific) initialization routine, these declarations
* explicitly don't use EXTERN since this code does not get compiled
Tcl_Interp *interp; /* Interpreter for application. */
{
Tcl_ValueType t3ArgTypes[2];
-
+
+ Tcl_Obj *listPtr;
+ Tcl_Obj **objv;
+ int objc, index;
+ static CONST char *specialOptions[] = {
+ "-appinitprocerror", "-appinitprocdeleteinterp",
+ "-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL
+ };
+
if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
return TCL_ERROR;
}
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
+ TestGetIndexFromObjStructObjCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testfile", TestfileCmd,
+ Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testsetrecursionlimit",
- TestsetrecursionlimitCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
(ClientData) 345);
Tcl_CreateCommand(interp, "teststatproc", TeststatprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
#endif
/*
+ * Check for special options used in ../tests/main.test
+ */
+
+ listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
+ if (listPtr != NULL) {
+ if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL,
+ TCL_EXACT, &index) == TCL_OK)) {
+ switch (index) {
+ case 0: {
+ return TCL_ERROR;
+ }
+ case 1: {
+ Tcl_DeleteInterp(interp);
+ return TCL_ERROR;
+ }
+ case 2: {
+ int mode;
+ Tcl_UnregisterChannel(interp,
+ Tcl_GetChannel(interp, "stderr", &mode));
+ return TCL_ERROR;
+ }
+ case 3: {
+ if (objc-1) {
+ Tcl_SetVar2Ex(interp, "tcl_rcFileName", NULL,
+ objv[1], TCL_GLOBAL_ONLY);
+ }
+ return TCL_ERROR;
+ }
+ }
+ }
+ }
+
+ /*
* And finally add any platform specific test commands.
*/
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
break;
}
}
- Tcl_SetResult(interp, argv[3], TCL_VOLATILE);
+ Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE);
return code;
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
int code; /* Current return code from command. */
{
TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
- char *listArgv[4];
- char string[TCL_INTEGER_SPACE], *cmd;
+ CONST char *listArgv[4], *cmd;
+ char string[TCL_INTEGER_SPACE];
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
- listArgv[1] = Tcl_GetStringResult(interp);
+ listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
- code = Tcl_Eval(interp, cmd);
- ckfree(cmd);
+ if (interp != NULL) {
+ code = Tcl_Eval(interp, cmd);
+ } else {
+ /*
+ * this should not happen, but by definition of how async
+ * handlers are invoked, it's possible. Better error
+ * checking is needed here.
+ */
+ }
+ ckfree((char *)cmd);
return code;
}
\f
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
(char *) NULL);
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
(char *) NULL);
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_Command token;
- long int l;
+ int *l;
char buf[30];
if (argc != 3) {
if (strcmp(argv[1], "create") == 0) {
token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
(ClientData) "original", (Tcl_CmdDeleteProc *) NULL);
- sprintf(buf, "%lx", (long int) token);
+ sprintf(buf, "%p", (VOID *)token);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "name") == 0) {
Tcl_Obj *objPtr;
-
- if (sscanf(argv[2], "%lx", &l) != 1) {
+
+ if (sscanf(argv[2], "%p", &l) != 1) {
Tcl_AppendResult(interp, "bad command token \"", argv[2],
"\"", (char *) NULL);
return TCL_ERROR;
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) l, objPtr);
-
+
Tcl_AppendElement(interp,
Tcl_GetCommandName(interp, (Tcl_Command) l));
Tcl_AppendElement(interp, Tcl_GetString(objPtr));
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_DString buffer;
int result;
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
Tcl_Eval(interp, argv[2]);
+ } else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
+ /* Create an object-based trace, then eval a script. This is used
+ * to test return codes other than TCL_OK from the trace engine.
+ */
+ static int deleteCalled;
+ deleteCalled = 0;
+ cmdTrace = Tcl_CreateObjTrace( interp, 50000,
+ TCL_ALLOW_INLINE_COMPILATION,
+ ObjTraceProc,
+ (ClientData) &deleteCalled,
+ ObjTraceDeleteProc );
+ result = Tcl_Eval( interp, argv[ 2 ] );
+ Tcl_DeleteTrace( interp, cmdTrace );
+ if ( !deleteCalled ) {
+ Tcl_SetResult( interp, "Delete wasn't called", TCL_STATIC );
+ return TCL_ERROR;
+ } else {
+ return result;
+ }
+
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be tracetest or deletetest", (char *) NULL);
+ "\": must be tracetest, deletetest or resulttest",
+ (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
Tcl_DeleteTrace(interp, cmdTrace);
}
\f
+static int
+ObjTraceProc( clientData, interp, level, command, token, objc, objv )
+ ClientData clientData; /* unused */
+ Tcl_Interp* interp; /* Tcl interpreter */
+ int level; /* Execution level */
+ CONST char* command; /* Command being executed */
+ Tcl_Command token; /* Command information */
+ int objc; /* Parameter count */
+ Tcl_Obj *CONST objv[]; /* Parameter list */
+{
+ CONST char* word = Tcl_GetString( objv[ 0 ] );
+ if ( !strcmp( word, "Error" ) ) {
+ Tcl_SetObjResult( interp, Tcl_NewStringObj( command, -1 ) );
+ return TCL_ERROR;
+ } else if ( !strcmp( word, "Break" ) ) {
+ return TCL_BREAK;
+ } else if ( !strcmp( word, "Continue" ) ) {
+ return TCL_CONTINUE;
+ } else if ( !strcmp( word, "Return" ) ) {
+ return TCL_RETURN;
+ } else if ( !strcmp( word, "OtherStatus" ) ) {
+ return 6;
+ } else {
+ return TCL_OK;
+ }
+}
+\f
+static void
+ObjTraceDeleteProc( clientData )
+ ClientData clientData;
+{
+ int * intPtr = (int *) clientData;
+ *intPtr = 1; /* Record that the trace was deleted */
+}
+\f
/*
*----------------------------------------------------------------------
*
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int i, id;
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *slave;
ClientData clientData; /* String result to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
DelCmd *dPtr = (DelCmd *) clientData;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int count;
int index, length;
char *string;
TclEncoding *encodingPtr;
- static char *optionStrings[] = {
+ static CONST char *optionStrings[] = {
"create", "delete", "path",
NULL
};
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int value;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
/*
*----------------------------------------------------------------------
*
+ * TestfilelinkCmd --
+ *
+ * This procedure implements the "testfilelink" command. It is used
+ * to test the effects of creating and manipulating filesystem links
+ * in Tcl.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May create a link on disk.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestfilelinkCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ Tcl_Obj *contents;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "source ?target?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ /* Create link from source to target */
+ contents = Tcl_FSLink(objv[1], objv[2],
+ TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not create link from \"",
+ Tcl_GetString(objv[1]), "\" to \"",
+ Tcl_GetString(objv[2]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ /* Read link */
+ contents = Tcl_FSLink(objv[1], NULL, 0);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not read link \"",
+ Tcl_GetString(objv[1]), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, contents);
+ if (objc == 2) {
+ /*
+ * If we are creating a link, this will actually just
+ * be objv[3], and we don't own it
+ */
+ Tcl_DecrRefCount(contents);
+ }
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TestgetassocdataCmd --
*
* This procedure implements the "testgetassocdata" command. It is
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
char *res;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
- static char *platformStrings[] = { "unix", "mac", "windows" };
+ static CONST char *platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
#ifdef __WIN32__
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_Interp *slaveToDelete;
" path\"", (char *) NULL);
return TCL_ERROR;
}
- if (argv[1][0] == '\0') {
- Tcl_AppendResult(interp, "cannot delete current interpreter",
- (char *) NULL);
- return TCL_ERROR;
- }
slaveToDelete = Tcl_GetSlave(interp, argv[1]);
if (slaveToDelete == (Tcl_Interp *) NULL) {
return TCL_ERROR;
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
+ static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
static char *stringVar = NULL;
static int created = 0;
- char buffer[TCL_DOUBLE_SPACE];
+ char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
+ Tcl_Obj *tmp;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg arg?\"", (char *) NULL);
+ " option ?arg arg arg arg arg?\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
+ if (argc != 7) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " ", argv[1],
+ " intRO realRO boolRO stringRO wideRO\"", (char *) NULL);
+ return TCL_ERROR;
+ }
if (created) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
+ Tcl_UnlinkVar(interp, "wide");
}
created = 1;
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
TCL_LINK_STRING | flag) != TCL_OK) {
return TCL_ERROR;
}
+ if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "wide", (char *) &wideVar,
+ TCL_LINK_WIDE_INT | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
+ Tcl_UnlinkVar(interp, "wide");
created = 0;
} else if (strcmp(argv[1], "get") == 0) {
TclFormatInt(buffer, intVar);
TclFormatInt(buffer, boolVar);
Tcl_AppendElement(interp, buffer);
Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
+ /*
+ * Wide ints only have an object-based interface.
+ */
+ tmp = Tcl_NewWideIntObj(wideVar);
+ Tcl_AppendElement(interp, Tcl_GetString(tmp));
+ Tcl_DecrRefCount(tmp);
} else if (strcmp(argv[1], "set") == 0) {
- if (argc != 6) {
+ if (argc != 7) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " ", argv[1],
- "intValue realValue boolValue stringValue\"", (char *) NULL);
+ argv[0], " ", argv[1],
+ " intValue realValue boolValue stringValue wideValue\"",
+ (char *) NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
strcpy(stringVar, argv[5]);
}
}
+ if (argv[6][0] != 0) {
+ tmp = Tcl_NewStringObj(argv[6], -1);
+ if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
+ Tcl_DecrRefCount(tmp);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(tmp);
+ }
} else if (strcmp(argv[1], "update") == 0) {
- if (argc != 6) {
+ if (argc != 7) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " ", argv[1],
- "intValue realValue boolValue stringValue\"", (char *) NULL);
+ argv[0], " ", argv[1],
+ "intValue realValue boolValue stringValue wideValue\"",
+ (char *) NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
}
Tcl_UpdateLinkedVar(interp, "string");
}
+ if (argv[6][0] != 0) {
+ tmp = Tcl_NewStringObj(argv[6], -1);
+ if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
+ Tcl_DecrRefCount(tmp);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(tmp);
+ Tcl_UpdateLinkedVar(interp, "wide");
+ }
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be create, delete, get, set, or update",
int index;
char *locale;
- static char *optionStrings[] = {
+ static CONST char *optionStrings[] = {
"ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (args[1].type == TCL_WIDE_INT) {
+ Tcl_WideInt w0 = Tcl_LongAsWide(i0);
+ Tcl_WideInt w1 = args[1].wideValue;
+
+ resultPtr->type = TCL_WIDE_INT;
+ resultPtr->wideValue = ((w0 > w1)? w0 : w1);
+#endif
} else {
- Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC);
+ Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
} else if (args[0].type == TCL_DOUBLE) {
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (args[1].type == TCL_WIDE_INT) {
+ double d1 = Tcl_WideAsDouble(args[1].wideValue);
+
+ resultPtr->type = TCL_DOUBLE;
+ resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
+#endif
+ } else {
+ Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
+ result = TCL_ERROR;
+ }
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (args[0].type == TCL_WIDE_INT) {
+ Tcl_WideInt w0 = args[0].wideValue;
+
+ if (args[1].type == TCL_INT) {
+ Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
+
+ resultPtr->type = TCL_WIDE_INT;
+ resultPtr->wideValue = ((w0 > w1)? w0 : w1);
+ } else if (args[1].type == TCL_DOUBLE) {
+ double d0 = Tcl_WideAsDouble(w0);
+ double d1 = args[1].doubleValue;
+
+ resultPtr->type = TCL_DOUBLE;
+ resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
+ } else if (args[1].type == TCL_WIDE_INT) {
+ Tcl_WideInt w1 = args[1].wideValue;
+
+ resultPtr->type = TCL_WIDE_INT;
+ resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
- Tcl_SetResult(interp, "T2: wrong type for arg 2", TCL_STATIC);
+ Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
+#endif
} else {
- Tcl_SetResult(interp, "T2: wrong type for arg 1", TCL_STATIC);
+ Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
result = TCL_ERROR;
}
return result;
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
- char *name, *value, *termPtr;
+ CONST char *value;
+ CONST char *name, *termPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName");
*/
/* ARGSUSED */
-int
+static int
TestregexpObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
char *string;
Tcl_Obj *objPtr;
Tcl_RegExpInfo info;
- static char *options[] = {
+ static CONST char *options[] = {
"-indices", "-nocase", "-about", "-expanded",
"-line", "-linestop", "-lineanchor",
"-xflags",
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags®_EXPECT) && indices) {
- char *varName, *value;
+ char *varName;
+ CONST char *value;
int start, end;
char info[TCL_INTEGER_SPACE * 2];
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
char *buf;
char *oldData;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
/*
*----------------------------------------------------------------------
*
- * TestsetrecursionlimitCmd --
- *
- * This procedure implements the "testsetrecursionlimit" command. It is
- * used to change the interp recursion limit (to test the effects
- * of Tcl_SetRecursionLimit).
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Sets the interp's recursion limit.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestsetrecursionlimitCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
-{
- int value;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "integer");
- return TCL_ERROR;
- }
- if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) {
- return TCL_ERROR;
- }
- value = Tcl_SetRecursionLimit(interp, value);
- Tcl_SetIntObj(Tcl_GetObjResult(interp), value);
- return TCL_OK;
-}
-
-
-\f
-/*
- *----------------------------------------------------------------------
- *
* TeststaticpkgCmd --
*
* This procedure implements the "teststaticpkg" command.
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int safe, loaded;
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_DString buffer;
- char *result;
+ CONST char *result;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int flags = 0;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_DeleteInterp(interp2);
}
interp2 = Tcl_CreateInterp();
- return TCL_OK;
+ return Tcl_Init(interp2);
} else if (strcmp(argv[1], "delete") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
- char *argString;
+ CONST char *argString;
/*
* Put the arguments into a var args structure
argString = Tcl_Merge(argc-1, argv+1);
panic(argString);
- ckfree(argString);
+ ckfree((char *)argString);
return TCL_OK;
}
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int i, mode;
char *rest;
for (i = 2; i < argc; i++) {
Tcl_DString buffer;
+ CONST char *translated;
- argv[i] = Tcl_TranslateFileName(interp, argv[i], &buffer);
- if (argv[i] == NULL) {
+ translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
+ if (translated == NULL) {
return TCL_ERROR;
}
- if (chmod(argv[i], (unsigned) mode) != 0) {
- Tcl_AppendResult(interp, argv[i], ": ", Tcl_PosixError(interp),
+ if (chmod(translated, (unsigned) mode) != 0) {
+ Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
(char *) NULL);
return TCL_ERROR;
}
TestfileCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int argc; /* Number of arguments. */
+ Tcl_Obj *CONST argv[]; /* The argument objects. */
{
int force, i, j, result;
- Tcl_DString error, name[2];
+ Tcl_Obj *error = NULL;
+ char *subcmd;
if (argc < 3) {
return TCL_ERROR;
force = 0;
i = 2;
- if (strcmp(argv[2], "-force") == 0) {
+ if (strcmp(Tcl_GetString(argv[2]), "-force") == 0) {
force = 1;
i = 3;
}
- Tcl_DStringInit(&name[0]);
- Tcl_DStringInit(&name[1]);
- Tcl_DStringInit(&error);
-
if (argc - i > 2) {
return TCL_ERROR;
}
for (j = i; j < argc; j++) {
- argv[j] = Tcl_TranslateFileName(interp, argv[j], &name[j - i]);
- if (argv[j] == NULL) {
+ if (Tcl_FSGetTranslatedPath(interp, argv[j]) == NULL) {
return TCL_ERROR;
}
}
- if (strcmp(argv[1], "mv") == 0) {
- result = TclpRenameFile(argv[i], argv[i + 1]);
- } else if (strcmp(argv[1], "cp") == 0) {
- result = TclpCopyFile(argv[i], argv[i + 1]);
- } else if (strcmp(argv[1], "rm") == 0) {
- result = TclpDeleteFile(argv[i]);
- } else if (strcmp(argv[1], "mkdir") == 0) {
- result = TclpCreateDirectory(argv[i]);
- } else if (strcmp(argv[1], "cpdir") == 0) {
- result = TclpCopyDirectory(argv[i], argv[i + 1], &error);
- } else if (strcmp(argv[1], "rmdir") == 0) {
- result = TclpRemoveDirectory(argv[i], force, &error);
+ subcmd = Tcl_GetString(argv[1]);
+
+ if (strcmp(subcmd, "mv") == 0) {
+ result = TclpObjRenameFile(argv[i], argv[i + 1]);
+ } else if (strcmp(subcmd, "cp") == 0) {
+ result = TclpObjCopyFile(argv[i], argv[i + 1]);
+ } else if (strcmp(subcmd, "rm") == 0) {
+ result = TclpObjDeleteFile(argv[i]);
+ } else if (strcmp(subcmd, "mkdir") == 0) {
+ result = TclpObjCreateDirectory(argv[i]);
+ } else if (strcmp(subcmd, "cpdir") == 0) {
+ result = TclpObjCopyDirectory(argv[i], argv[i + 1], &error);
+ } else if (strcmp(subcmd, "rmdir") == 0) {
+ result = TclpObjRemoveDirectory(argv[i], force, &error);
} else {
result = TCL_ERROR;
goto end;
}
if (result != TCL_OK) {
- if (Tcl_DStringValue(&error)[0] != '\0') {
- Tcl_AppendResult(interp, Tcl_DStringValue(&error), " ", NULL);
+ if (error != NULL) {
+ if (Tcl_GetString(error)[0] != '\0') {
+ Tcl_AppendResult(interp, Tcl_GetString(error), " ", NULL);
+ }
+ Tcl_DecrRefCount(error);
}
Tcl_AppendResult(interp, Tcl_ErrnoId(), (char *) NULL);
}
end:
- Tcl_DStringFree(&error);
- Tcl_DStringFree(&name[0]);
- Tcl_DStringFree(&name[1]);
return result;
}
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
- char **argv; /* The argument strings. */
+ CONST char **argv; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
Tcl_Time start, stop;
Tcl_Obj *objPtr;
Tcl_Obj **objv;
- char *s;
+ CONST char *s;
char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
ckfree((char *) objPtr);
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000);
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc\n", timePer/5000);
/* free 5000 times */
fprintf(stderr, "free 5000 6 word items\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
ckfree((char *) objv[i]);
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per free\n", timePer/5000);
/* Tcl_NewObj 5000 times */
fprintf(stderr, "Tcl_NewObj 5000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = Tcl_NewObj();
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_NewObj\n", timePer/5000);
/* Tcl_DecrRefCount 5000 times */
fprintf(stderr, "Tcl_DecrRefCount 5000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
ckfree((char *) objv);
/* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", -1);
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per TclGetStringFromObj of \"12345\"\n",
timePer/100000);
/* Tcl_GetIntFromObj 100000 times */
fprintf(stderr, "Tcl_GetIntFromObj of \"12345\" 100000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
if (Tcl_GetIntFromObj(interp, objPtr, &n) != TCL_OK) {
return TCL_ERROR;
}
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetIntFromObj of \"12345\"\n",
timePer/100000);
/* Tcl_GetInt 100000 times */
fprintf(stderr, "Tcl_GetInt of \"12345\" 100000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
if (Tcl_GetInt(interp, "12345", &n) != TCL_OK) {
return TCL_ERROR;
}
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetInt of \"12345\"\n",
timePer/100000);
/* sprintf 100000 times */
fprintf(stderr, "sprintf of 12345 100000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
sprintf(newString, "%d", 12345);
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per sprintf of 12345\n",
timePer/100000);
/* hashtable lookup 100000 times */
fprintf(stderr, "hashtable lookup of \"gettimes\" 100000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "gettimes");
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per hashtable lookup of \"gettimes\"\n",
timePer/100000);
/* Tcl_SetVar 100000 times */
fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_SetVar of a to \"12345\"\n",
timePer/100000);
/* Tcl_GetVar 100000 times */
fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n");
- TclpGetTime(&start);
+ Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG);
if (s == NULL) {
return TCL_ERROR;
}
}
- TclpGetTime(&stop);
+ Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_GetVar of a==\"12345\"\n",
timePer/100000);
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
- char **argv; /* The argument strings. */
+ CONST char **argv; /* The argument strings. */
{
return TCL_OK;
}
ClientData data; /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int flags = (int) data;
- char *value;
+ CONST char *value;
if (argc == 2) {
Tcl_SetResult(interp, "before get", TCL_STATIC);
int discard, result, index;
Tcl_SavedResult state;
Tcl_Obj *objPtr;
- static char *optionStrings[] = {
+ static CONST char *optionStrings[] = {
"append", "dynamic", "free", "object", "small", NULL
};
enum options {
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
TclStatProc_ *proc;
int retVal;
}
if (strcmp(argv[2], "TclpStat") == 0) {
- proc = TclpStat;
+ proc = PretendTclpStat;
} else if (strcmp(argv[2], "TestStatProc1") == 0) {
proc = TestStatProc1;
} else if (strcmp(argv[2], "TestStatProc2") == 0) {
}
if (strcmp(argv[1], "insert") == 0) {
- if (proc == TclpStat) {
+ if (proc == PretendTclpStat) {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be ",
"TestStatProc1, TestStatProc2, or TestStatProc3",
return retVal;
}
+static int PretendTclpStat(path, buf)
+ CONST char *path;
+ struct stat *buf;
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
+#ifdef TCL_WIDE_INT_IS_LONG
+ Tcl_IncrRefCount(pathPtr);
+ ret = TclpObjStat(pathPtr, buf);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+#else /* TCL_WIDE_INT_IS_LONG */
+ Tcl_StatBuf realBuf;
+ Tcl_IncrRefCount(pathPtr);
+ ret = TclpObjStat(pathPtr, &realBuf);
+ Tcl_DecrRefCount(pathPtr);
+ if (ret != -1) {
+# define OUT_OF_RANGE(x) \
+ (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
+ ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
+# define OUT_OF_URANGE(x) \
+ (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
+
+ /*
+ * Perform the result-buffer overflow check manually.
+ *
+ * Note that ino_t/ino64_t is unsigned...
+ */
+
+ if (OUT_OF_URANGE(realBuf.st_ino) || OUT_OF_RANGE(realBuf.st_size)
+# ifdef HAVE_ST_BLOCKS
+ || OUT_OF_RANGE(realBuf.st_blocks)
+# endif
+ ) {
+# ifdef EOVERFLOW
+ errno = EOVERFLOW;
+# else
+# ifdef EFBIG
+ errno = EFBIG;
+# else
+# error "what error should be returned for a value out of range?"
+# endif
+# endif
+ return -1;
+ }
+
+# undef OUT_OF_RANGE
+# undef OUT_OF_URANGE
+
+ /*
+ * Copy across all supported fields, with possible type
+ * coercions on those fields that change between the normal
+ * and lf64 versions of the stat structure (on Solaris at
+ * least.) This is slow when the structure sizes coincide,
+ * but that's what you get for mixing interfaces...
+ */
+
+ buf->st_mode = realBuf.st_mode;
+ buf->st_ino = (ino_t) realBuf.st_ino;
+ buf->st_dev = realBuf.st_dev;
+ buf->st_rdev = realBuf.st_rdev;
+ buf->st_nlink = realBuf.st_nlink;
+ buf->st_uid = realBuf.st_uid;
+ buf->st_gid = realBuf.st_gid;
+ buf->st_size = (off_t) realBuf.st_size;
+ buf->st_atime = realBuf.st_atime;
+ buf->st_mtime = realBuf.st_mtime;
+ buf->st_ctime = realBuf.st_ctime;
+# ifdef HAVE_ST_BLOCKS
+ buf->st_blksize = realBuf.st_blksize;
+ buf->st_blocks = (blkcnt_t) realBuf.st_blocks;
+# endif
+ }
+ return ret;
+#endif /* TCL_WIDE_INT_IS_LONG */
+}
+
/* Be careful in the compares in these tests, since the Macintosh puts a
* leading : in the beginning of non-absolute paths before passing them
* into the file command procedures.
*/
-
+
static int
TestStatProc1(path, buf)
CONST char *path;
struct stat *buf;
{
+ memset(buf, 0, sizeof(struct stat));
buf->st_size = 1234;
return ((strstr(path, "testStat1%.fil") == NULL) ? -1 : 0);
}
CONST char *path;
struct stat *buf;
{
+ memset(buf, 0, sizeof(struct stat));
buf->st_size = 2345;
return ((strstr(path, "testStat2%.fil") == NULL) ? -1 : 0);
}
CONST char *path;
struct stat *buf;
{
+ memset(buf, 0, sizeof(struct stat));
buf->st_size = 3456;
return ((strstr(path, "testStat3%.fil") == NULL) ? -1 : 0);
}
/*
*----------------------------------------------------------------------
*
- * TestaccessprocCmd --
+ * TestmainthreadCmd --
*
- * Implements the "testTclAccessProc" cmd that is used to test the
- * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis.
+ * Implements the "testmainthread" cmd that is used to test the
+ * 'Tcl_GetCurrentThread' API.
*
* Results:
* A standard Tcl result.
*/
static int
-TestaccessprocCmd (dummy, interp, argc, argv)
+TestmainthreadCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
- TclAccessProc_ *proc;
- int retVal;
+ if (argc == 1) {
+ Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
+ Tcl_SetObjResult(interp, idObj);
+ return TCL_OK;
+ } else {
+ Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ return TCL_ERROR;
+ }
+}
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " option arg\"", (char *) NULL);
- return TCL_ERROR;
- }
+/*
+ *----------------------------------------------------------------------
+ *
+ * MainLoop --
+ *
+ * A main loop set by TestsetmainloopCmd below.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Event handlers could do anything.
+ *
+ *----------------------------------------------------------------------
+ */
- if (strcmp(argv[2], "TclpAccess") == 0) {
- proc = TclpAccess;
- } else if (strcmp(argv[2], "TestAccessProc1") == 0) {
- proc = TestAccessProc1;
- } else if (strcmp(argv[2], "TestAccessProc2") == 0) {
- proc = TestAccessProc2;
- } else if (strcmp(argv[2], "TestAccessProc3") == 0) {
- proc = TestAccessProc3;
- } else {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
- "must be TclpAccess, ",
- "TestAccessProc1, TestAccessProc2, or TestAccessProc3",
- (char *) NULL);
- return TCL_ERROR;
+static void
+MainLoop(void)
+{
+ while (!exitMainLoop) {
+ Tcl_DoOneEvent(0);
}
+ fprintf(stdout,"Exit MainLoop\n");
+ fflush(stdout);
+}
- if (strcmp(argv[1], "insert") == 0) {
- if (proc == TclpAccess) {
- Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
- "must be ",
- "TestAccessProc1, TestAccessProc2, or TestAccessProc3",
- (char *) NULL);
- return TCL_ERROR;
- }
- retVal = TclAccessInsertProc(proc);
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestsetmainloopCmd --
+ *
+ * Implements the "testsetmainloop" cmd that is used to test the
+ * 'Tcl_SetMainLoop' API.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetmainloopCmd (dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ register Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ CONST char **argv; /* Argument strings. */
+{
+ exitMainLoop = 0;
+ Tcl_SetMainLoop(MainLoop);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestexitmainloopCmd --
+ *
+ * Implements the "testexitmainloop" cmd that is used to test the
+ * 'Tcl_SetMainLoop' API.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexitmainloopCmd (dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ register Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ CONST char **argv; /* Argument strings. */
+{
+ exitMainLoop = 1;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestaccessprocCmd --
+ *
+ * Implements the "testTclAccessProc" cmd that is used to test the
+ * 'TclAccessInsertProc' & 'TclAccessDeleteProc' C Apis.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestaccessprocCmd (dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ register Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ CONST char **argv; /* Argument strings. */
+{
+ TclAccessProc_ *proc;
+ int retVal;
+
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " option arg\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (strcmp(argv[2], "TclpAccess") == 0) {
+ proc = PretendTclpAccess;
+ } else if (strcmp(argv[2], "TestAccessProc1") == 0) {
+ proc = TestAccessProc1;
+ } else if (strcmp(argv[2], "TestAccessProc2") == 0) {
+ proc = TestAccessProc2;
+ } else if (strcmp(argv[2], "TestAccessProc3") == 0) {
+ proc = TestAccessProc3;
+ } else {
+ Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
+ "must be TclpAccess, ",
+ "TestAccessProc1, TestAccessProc2, or TestAccessProc3",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (strcmp(argv[1], "insert") == 0) {
+ if (proc == PretendTclpAccess) {
+ Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
+ "must be ",
+ "TestAccessProc1, TestAccessProc2, or TestAccessProc3",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ retVal = TclAccessInsertProc(proc);
} else if (strcmp(argv[1], "delete") == 0) {
retVal = TclAccessDeleteProc(proc);
} else {
return retVal;
}
+static int PretendTclpAccess(path, mode)
+ CONST char *path;
+ int mode;
+{
+ int ret;
+ Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = TclpObjAccess(pathPtr, mode);
+ Tcl_DecrRefCount(pathPtr);
+ return ret;
+}
static int
TestAccessProc1(path, mode)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
TclOpenFileChannelProc_ *proc;
int retVal;
}
if (strcmp(argv[2], "TclpOpenFileChannel") == 0) {
- proc = TclpOpenFileChannel;
+ proc = PretendTclpOpenFileChannel;
} else if (strcmp(argv[2], "TestOpenFileChannelProc1") == 0) {
proc = TestOpenFileChannelProc1;
} else if (strcmp(argv[2], "TestOpenFileChannelProc2") == 0) {
}
if (strcmp(argv[1], "insert") == 0) {
- if (proc == TclpOpenFileChannel) {
+ if (proc == PretendTclpOpenFileChannel) {
Tcl_AppendResult(interp, "bad arg \"", argv[1], "\": ",
"must be ",
"TestOpenFileChannelProc1, TestOpenFileChannelProc2, or ",
return retVal;
}
+static Tcl_Channel
+PretendTclpOpenFileChannel(interp, fileName, modeString, permissions)
+ Tcl_Interp *interp; /* Interpreter for error reporting;
+ * can be NULL. */
+ CONST char *fileName; /* Name of file to open. */
+ CONST char *modeString; /* A list of POSIX open modes or
+ * a string such as "rw". */
+ int permissions; /* If the open involves creating a
+ * file, with what modes to create
+ * it? */
+{
+ Tcl_Channel ret;
+ int mode, seekFlag;
+ Tcl_Obj *pathPtr;
+ mode = TclGetOpenMode(interp, modeString, &seekFlag);
+ if (mode == -1) {
+ return NULL;
+ }
+ pathPtr = Tcl_NewStringObj(fileName, -1);
+ Tcl_IncrRefCount(pathPtr);
+ ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);
+ Tcl_DecrRefCount(pathPtr);
+ if (ret != NULL) {
+ if (seekFlag) {
+ if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp,
+ "could not seek to end of file while opening \"",
+ fileName, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ Tcl_Close(NULL, ret);
+ return NULL;
+ }
+ }
+ }
+ return ret;
+}
static Tcl_Channel
TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
- char *fileName; /* Name of file to open. */
- char *modeString; /* A list of POSIX open modes or
+ CONST char *fileName; /* Name of file to open. */
+ CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
- if (!strcmp("testOpenFileChannel1%.fil", fileName)) {
- return (TclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil",
+ CONST char *expectname="testOpenFileChannel1%.fil";
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(1, &expectname, &ds);
+
+ if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
+ Tcl_DStringFree(&ds);
+ return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel1%__.fil",
modeString, permissions));
} else {
+ Tcl_DStringFree(&ds);
return (NULL);
}
}
TestOpenFileChannelProc2(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
- char *fileName; /* Name of file to open. */
- char *modeString; /* A list of POSIX open modes or
+ CONST char *fileName; /* Name of file to open. */
+ CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
- if (!strcmp("testOpenFileChannel2%.fil", fileName)) {
- return (TclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil",
+ CONST char *expectname="testOpenFileChannel2%.fil";
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(1, &expectname, &ds);
+
+ if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
+ Tcl_DStringFree(&ds);
+ return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel2%__.fil",
modeString, permissions));
} else {
+ Tcl_DStringFree(&ds);
return (NULL);
}
}
TestOpenFileChannelProc3(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
- char *fileName; /* Name of file to open. */
- char *modeString; /* A list of POSIX open modes or
+ CONST char *fileName; /* Name of file to open. */
+ CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
- if (!strcmp("testOpenFileChannel3%.fil", fileName)) {
- return (TclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",
+ CONST char *expectname="testOpenFileChannel3%.fil";
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(1, &expectname, &ds);
+
+ if (!strcmp(Tcl_DStringValue(&ds), fileName)) {
+ Tcl_DStringFree(&ds);
+ return (PretendTclpOpenFileChannel(interp, "__testOpenFileChannel3%__.fil",
modeString, permissions));
} else {
+ Tcl_DStringFree(&ds);
return (NULL);
}
}
*/
/* ARGSUSED */
-int
+static int
TestChannelCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for result. */
int argc; /* Count of additional args. */
- char **argv; /* Additional arg strings. */
+ CONST char **argv; /* Additional arg strings. */
{
- char *cmdName; /* Sub command. */
+ CONST char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
chan = NULL;
}
+ if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " cut channelName\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_CutChannel(chan);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'c') &&
+ (strncmp(cmdName, "clearchannelhandlers", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " clearchannelhandlers channelName\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_ClearChannelHandlers(chan);
+ return TCL_OK;
+ }
+
if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
return TCL_ERROR;
}
Tcl_AppendElement(interp, argv[2]);
- Tcl_AppendElement(interp, chanPtr->typePtr->typeName);
+ Tcl_AppendElement(interp, Tcl_ChannelName(chanPtr->typePtr));
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, "read");
} else {
TclFormatInt(buf, IOQueued);
Tcl_AppendElement(interp, buf);
- TclFormatInt(buf, Tcl_Tell((Tcl_Channel) chanPtr));
+ TclFormatInt(buf, (int)Tcl_Tell((Tcl_Channel) chanPtr));
Tcl_AppendElement(interp, buf);
TclFormatInt(buf, statePtr->refCount);
return TCL_OK;
}
+ if ((cmdName[0] == 'i') && (strncmp(cmdName, "isshared", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, Tcl_IsChannelShared(chan));
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
+ if ((cmdName[0] == 'i') && (strncmp(cmdName, "isstandard", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, Tcl_IsStandardChannel(chan));
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
return TCL_OK;
}
+ if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ TclFormatInt(buf, (long) Tcl_GetChannelThread(chan));
+ Tcl_AppendResult(interp, buf, (char *) NULL);
+ return TCL_OK;
+ }
+
if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
return TCL_OK;
}
+ if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) {
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "channel name required", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_SpliceChannel(chan);
+ return TCL_OK;
+ }
+
if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "channel name required",
(char *) NULL);
return TCL_ERROR;
}
- Tcl_AppendResult(interp, chanPtr->typePtr->typeName,
+ Tcl_AppendResult(interp, Tcl_ChannelName(chanPtr->typePtr),
(char *) NULL);
return TCL_OK;
}
}
Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ",
- "info, open, readable, writable, transform, unstack",
+ "cut, clearchannelhandlers, info, isshared, mode, open, "
+ "readable, splice, writable, transform, unstack",
(char *) NULL);
return TCL_ERROR;
}
*/
/* ARGSUSED */
-int
+static int
TestChannelEventCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
- char *cmd;
+ CONST char *cmd;
int index, i, mask, len;
if ((argc < 3) || (argc > 5)) {
"add, delete, list, set, or removeall", (char *) NULL);
return TCL_ERROR;
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestWrongNumArgsObjCmd --
+ *
+ * Test the Tcl_WrongNumArgs function.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * Sets interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestWrongNumArgsObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int i, length;
+ char *msg;
+
+ if (objc < 3) {
+ /*
+ * Don't use Tcl_WrongNumArgs here, as that is the function
+ * we want to test!
+ */
+ Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ msg = Tcl_GetStringFromObj(objv[2], &length);
+ if (length == 0) {
+ msg = NULL;
+ }
+
+ if (i > objc - 3) {
+ /*
+ * Asked for more arguments than were given.
+ */
+ Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ Tcl_WrongNumArgs(interp, i, &(objv[3]), msg);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestGetIndexFromObjStructObjCmd --
+ *
+ * Test the Tcl_GetIndexFromObjStruct function.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * Sets interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *ary[] = {
+ "a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL
+ };
+ int idx,target;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *),
+ "dummy", 0, &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (idx != target) {
+ char buffer[64];
+ sprintf(buffer, "%d", idx);
+ Tcl_AppendResult(interp, "index value comparison failed: got ",
+ buffer, NULL);
+ sprintf(buffer, "%d", target);
+ Tcl_AppendResult(interp, " when ", buffer, " expected", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_WrongNumArgs(interp, 3, objv, NULL);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestFilesystemObjCmd --
+ *
+ * This procedure implements the "testfilesystem" command. It is
+ * used to test Tcl_FSRegister, Tcl_FSUnregister, and can be used
+ * to test that the pluggable filesystem works.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Inserts or removes a filesystem from Tcl's stack.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestFilesystemObjCmd(dummy, interp, objc, objv)
+ ClientData dummy;
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+{
+ int res, boolVal;
+ char *msg;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "boolean");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[1], &boolVal) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (boolVal) {
+ res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem);
+ msg = (res == TCL_OK) ? "registered" : "failed";
+ } else {
+ res = Tcl_FSUnregister(&testReportingFilesystem);
+ msg = (res == TCL_OK) ? "unregistered" : "failed";
+ }
+ Tcl_SetResult(interp, msg, TCL_VOLATILE);
+ return res;
+}
+
+static int
+TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr)
+{
+ static Tcl_Obj* lastPathPtr = NULL;
+
+ if (pathPtr == lastPathPtr) {
+ /* Reject all files second time around */
+ return -1;
+ } else {
+ Tcl_Obj * newPathPtr;
+ /* Try to claim all files first time around */
+
+ newPathPtr = Tcl_DuplicateObj(pathPtr);
+ lastPathPtr = newPathPtr;
+ Tcl_IncrRefCount(newPathPtr);
+ if (Tcl_FSGetFileSystemForPath(newPathPtr) == NULL) {
+ /* Nothing claimed it. Therefore we don't either */
+ Tcl_DecrRefCount(newPathPtr);
+ lastPathPtr = NULL;
+ return -1;
+ } else {
+ lastPathPtr = NULL;
+ *clientDataPtr = (ClientData) newPathPtr;
+ return TCL_OK;
+ }
+ }
+}
+
+/*
+ * Simple helper function to extract the native vfs representation of a
+ * path object, or NULL if no such representation exists.
+ */
+static Tcl_Obj*
+TestReportGetNativePath(Tcl_Obj* pathObjPtr) {
+ return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);
+}
+
+static void
+TestReportFreeInternalRep(ClientData clientData) {
+ Tcl_Obj *nativeRep = (Tcl_Obj*)clientData;
+ if (nativeRep != NULL) {
+ /* Free the path */
+ Tcl_DecrRefCount(nativeRep);
+ }
+}
+
+static ClientData
+TestReportDupInternalRep(ClientData clientData) {
+ Tcl_Obj *original = (Tcl_Obj*)clientData;
+ Tcl_IncrRefCount(original);
+ return clientData;
+}
+
+static void
+TestReport(cmd, path, arg2)
+ CONST char* cmd;
+ Tcl_Obj* path;
+ Tcl_Obj* arg2;
+{
+ Tcl_Interp* interp = (Tcl_Interp*) Tcl_FSData(&testReportingFilesystem);
+ if (interp == NULL) {
+ /* This is bad, but not much we can do about it */
+ } else {
+ /*
+ * No idea why I decided to program this up using the
+ * old string-based API, but there you go. We should
+ * convert it to objects.
+ */
+ Tcl_SavedResult savedResult;
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
+ Tcl_DStringAppend(&ds, "lappend filesystemReport ",-1);
+ Tcl_DStringStartSublist(&ds);
+ Tcl_DStringAppendElement(&ds, cmd);
+ if (path != NULL) {
+ Tcl_DStringAppendElement(&ds, Tcl_GetString(path));
+ }
+ if (arg2 != NULL) {
+ Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
+ }
+ Tcl_DStringEndSublist(&ds);
+ Tcl_SaveResult(interp, &savedResult);
+ Tcl_Eval(interp, Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+ Tcl_RestoreResult(interp, &savedResult);
+ }
+}
+
+static int
+TestReportStat(path, buf)
+ Tcl_Obj *path; /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf; /* Filled with results of stat call. */
+{
+ TestReport("stat",path, NULL);
+ return Tcl_FSStat(TestReportGetNativePath(path),buf);
+}
+static int
+TestReportLstat(path, buf)
+ Tcl_Obj *path; /* Path of file to stat (in current CP). */
+ Tcl_StatBuf *buf; /* Filled with results of stat call. */
+{
+ TestReport("lstat",path, NULL);
+ return Tcl_FSLstat(TestReportGetNativePath(path),buf);
+}
+static int
+TestReportAccess(path, mode)
+ Tcl_Obj *path; /* Path of file to access (in current CP). */
+ int mode; /* Permission setting. */
+{
+ TestReport("access",path,NULL);
+ return Tcl_FSAccess(TestReportGetNativePath(path),mode);
+}
+static Tcl_Channel
+TestReportOpenFileChannel(interp, fileName, mode, permissions)
+ Tcl_Interp *interp; /* Interpreter for error reporting;
+ * can be NULL. */
+ Tcl_Obj *fileName; /* Name of file to open. */
+ int mode; /* POSIX open mode. */
+ int permissions; /* If the open involves creating a
+ * file, with what modes to create
+ * it? */
+{
+ TestReport("open",fileName, NULL);
+ return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
+ mode, permissions);
+}
+static int
+TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
+ Tcl_Interp *interp; /* Interpreter to receive results. */
+ Tcl_Obj *resultPtr; /* Directory separators to pass to TclDoGlob. */
+ Tcl_Obj *dirPtr; /* Contains path to directory to search. */
+ CONST char *pattern; /* Pattern to match against. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. */
+{
+ TestReport("matchindirectory",dirPtr, NULL);
+ return Tcl_FSMatchInDirectory(interp, resultPtr,
+ TestReportGetNativePath(dirPtr), pattern,
+ types);
+}
+static int
+TestReportChdir(dirName)
+ Tcl_Obj *dirName;
+{
+ TestReport("chdir",dirName,NULL);
+ return Tcl_FSChdir(TestReportGetNativePath(dirName));
+}
+static int
+TestReportLoadFile(interp, fileName,
+ handlePtr, unloadProcPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Obj *fileName; /* Name of the file containing the desired
+ * code. */
+ Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
+ * file which will be passed back to
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
+{
+ TestReport("loadfile",fileName,NULL);
+ return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,
+ NULL, NULL, handlePtr, unloadProcPtr);
+}
+static Tcl_Obj *
+TestReportLink(path, to, linkType)
+ Tcl_Obj *path; /* Path of file to readlink or link */
+ Tcl_Obj *to; /* Path of file to link to, or NULL */
+ int linkType;
+{
+ TestReport("link",path,to);
+ return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);
+}
+static int
+TestReportRenameFile(src, dst)
+ Tcl_Obj *src; /* Pathname of file or dir to be renamed
+ * (UTF-8). */
+ Tcl_Obj *dst; /* New pathname of file or directory
+ * (UTF-8). */
+{
+ TestReport("renamefile",src,dst);
+ return Tcl_FSRenameFile(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst));
+}
+static int
+TestReportCopyFile(src, dst)
+ Tcl_Obj *src; /* Pathname of file to be copied (UTF-8). */
+ Tcl_Obj *dst; /* Pathname of file to copy to (UTF-8). */
+{
+ TestReport("copyfile",src,dst);
+ return Tcl_FSCopyFile(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst));
+}
+static int
+TestReportDeleteFile(path)
+ Tcl_Obj *path; /* Pathname of file to be removed (UTF-8). */
+{
+ TestReport("deletefile",path,NULL);
+ return Tcl_FSDeleteFile(TestReportGetNativePath(path));
+}
+static int
+TestReportCreateDirectory(path)
+ Tcl_Obj *path; /* Pathname of directory to create (UTF-8). */
+{
+ TestReport("createdirectory",path,NULL);
+ return Tcl_FSCreateDirectory(TestReportGetNativePath(path));
+}
+static int
+TestReportCopyDirectory(src, dst, errorPtr)
+ Tcl_Obj *src; /* Pathname of directory to be copied
+ * (UTF-8). */
+ Tcl_Obj *dst; /* Pathname of target directory (UTF-8). */
+ Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
+ * of file causing error. */
+{
+ TestReport("copydirectory",src,dst);
+ return Tcl_FSCopyDirectory(TestReportGetNativePath(src),
+ TestReportGetNativePath(dst), errorPtr);
+}
+static int
+TestReportRemoveDirectory(path, recursive, errorPtr)
+ Tcl_Obj *path; /* Pathname of directory to be removed
+ * (UTF-8). */
+ int recursive; /* If non-zero, removes directories that
+ * are nonempty. Otherwise, will only remove
+ * empty directories. */
+ Tcl_Obj **errorPtr; /* If non-NULL, to be filled with UTF-8 name
+ * of file causing error. */
+{
+ TestReport("removedirectory",path,NULL);
+ return Tcl_FSRemoveDirectory(TestReportGetNativePath(path), recursive,
+ errorPtr);
+}
+static CONST char**
+TestReportFileAttrStrings(fileName, objPtrRef)
+ Tcl_Obj* fileName;
+ Tcl_Obj** objPtrRef;
+{
+ TestReport("fileattributestrings",fileName,NULL);
+ return Tcl_FSFileAttrStrings(TestReportGetNativePath(fileName), objPtrRef);
+}
+static int
+TestReportFileAttrsGet(interp, index, fileName, objPtrRef)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *fileName; /* filename we are operating on. */
+ Tcl_Obj **objPtrRef; /* for output. */
+{
+ TestReport("fileattributesget",fileName,NULL);
+ return Tcl_FSFileAttrsGet(interp, index,
+ TestReportGetNativePath(fileName), objPtrRef);
+}
+static int
+TestReportFileAttrsSet(interp, index, fileName, objPtr)
+ Tcl_Interp *interp; /* The interpreter for error reporting. */
+ int index; /* index of the attribute command. */
+ Tcl_Obj *fileName; /* filename we are operating on. */
+ Tcl_Obj *objPtr; /* for input. */
+{
+ TestReport("fileattributesset",fileName,objPtr);
+ return Tcl_FSFileAttrsSet(interp, index,
+ TestReportGetNativePath(fileName), objPtr);
+}
+static int
+TestReportUtime (fileName, tval)
+ Tcl_Obj* fileName;
+ struct utimbuf *tval;
+{
+ TestReport("utime",fileName,NULL);
+ return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
+}
+static int
+TestReportNormalizePath(interp, pathPtr, nextCheckpoint)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+ int nextCheckpoint;
+{
+ TestReport("normalizepath",pathPtr,NULL);
+ return nextCheckpoint;
+}
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
- char **argv;
- static char *tablePtr[] = {"a", "b", "check", (char *) NULL};
+ CONST char **argv;
+ static CONST char *tablePtr[] = {"a", "b", "check", (char *) NULL};
+ /*
+ * Keep this structure declaration in sync with tclIndexObj.c
+ */
+ struct IndexRep {
+ VOID *tablePtr; /* Pointer to the table of strings */
+ int offset; /* Offset between table entries */
+ int index; /* Selected index into table. */
+ };
+ struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
* returned on subsequent lookups.
*/
- Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
- "token", 0, &index);
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
- objv[1]->internalRep.twoPtrValue.ptr2 = (VOID *) index2;
+
+ Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], tablePtr,
+ "token", 0, &index);
+ indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
+ indexRep->index = index2;
result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
return TCL_ERROR;
}
- argv = (char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
+ argv = (CONST char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
* the index object, clear out the object's cached state.
*/
- if ((objv[3]->typePtr == Tcl_GetObjType("index"))
- && (objv[3]->internalRep.twoPtrValue.ptr1 == (VOID *) argv)) {
- objv[3]->typePtr = NULL;
+ if ( objv[3]->typePtr != NULL
+ && !strcmp( "index", objv[3]->typePtr->name ) ) {
+ indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
+ if (indexRep->tablePtr == (VOID *) argv) {
+ objv[3]->typePtr->freeIntRepProc(objv[3]);
+ objv[3]->typePtr = NULL;
+ }
}
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
varPtr[i] = NULL;
}
}
+ } else if ( strcmp ( subCmd, "invalidateStringRep" ) == 0 ) {
+ if ( objc != 3 ) {
+ goto wrongNumArgs;
+ }
+ index = Tcl_GetString( objv[2] );
+ if ( GetVariableIndex( interp, index, &varIndex ) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
+ }
+ Tcl_InvalidateStringRep( varPtr[varIndex] );
+ Tcl_SetObjResult( interp, varPtr[varIndex] );
} else if (strcmp(subCmd, "newobj") == 0) {
if (objc != 3) {
goto wrongNumArgs;
#define MAX_STRINGS 11
char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
- static char *options[] = {
+ static CONST char *options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "ualloc", (char *) NULL
};
EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp,
- CONST char *script));
+ char *script, int joinable));
EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id,
char *script, int wait));
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
-Tcl_ThreadCreateType NewThread _ANSI_ARGS_((ClientData clientData));
+Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData));
static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
* This procedure is invoked to process the "testthread" Tcl command.
* See the user documentation for details on what it does.
*
- * thread create
+ * thread create ?-joinable? ?script?
* thread send id ?-async? script
* thread exit
* thread info id
* thread names
* thread wait
* thread errorproc proc
+ * thread join id
*
* Results:
* A standard Tcl result.
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
- static char *threadOptions[] = {"create", "exit", "id", "names",
- "send", "wait", "errorproc", (char *) NULL};
- enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_NAMES,
- THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};
+ static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names",
+ "send", "wait", "errorproc",
+ (char *) NULL};
+ enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN,
+ THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
switch ((enum options)option) {
case THREAD_CREATE: {
char *script;
+ int joinable, len;
+
if (objc == 2) {
- script = "testthread wait"; /* Just enter the event loop */
+ /* Neither joinable nor special script
+ */
+
+ joinable = 0;
+ script = "testthread wait"; /* Just enter the event loop */
+
} else if (objc == 3) {
- script = Tcl_GetString(objv[2]);
+ /* Possibly -joinable, then no special script,
+ * no joinable, then its a script.
+ */
+
+ script = Tcl_GetString(objv[2]);
+ len = strlen (script);
+
+ if ((len > 1) &&
+ (script [0] == '-') && (script [1] == 'j') &&
+ (0 == strncmp (script, "-joinable", (size_t) len))) {
+ joinable = 1;
+ script = "testthread wait"; /* Just enter the event loop
+ */
+ } else {
+ /* Remember the script */
+ joinable = 0;
+ }
+ } else if (objc == 4) {
+ /* Definitely a script available, but is the flag
+ * -joinable ?
+ */
+
+ script = Tcl_GetString(objv[2]);
+ len = strlen (script);
+
+ joinable = ((len > 1) &&
+ (script [0] == '-') && (script [1] == 'j') &&
+ (0 == strncmp (script, "-joinable", (size_t) len)));
+
+ script = Tcl_GetString(objv[3]);
} else {
- Tcl_WrongNumArgs(interp, 2, objv, "?script?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
- return TclCreateThread(interp, script);
+ return TclCreateThread(interp, script, joinable);
}
case THREAD_EXIT: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
+ case THREAD_JOIN: {
+ long id;
+ int result, status;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "join id");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
+ if (result == TCL_OK) {
+ Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
+ } else {
+ char buf [20];
+ sprintf (buf, "%ld", id);
+ Tcl_AppendResult (interp, "cannot join thread ", buf, NULL);
+ }
+ return result;
+ }
case THREAD_NAMES: {
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
/* ARGSUSED */
int
-TclCreateThread(interp, script)
+TclCreateThread(interp, script, joinable)
Tcl_Interp *interp; /* Current interpreter. */
- CONST char *script; /* Script to execute */
+ char *script; /* Script to execute */
+ int joinable; /* Flag, joinable thread or not */
{
ThreadCtrl ctrl;
Tcl_ThreadId id;
- ctrl.script = (char *) script;
+ ctrl.script = script;
ctrl.condWait = NULL;
ctrl.flags = 0;
+ joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
+
Tcl_MutexLock(&threadMutex);
- if (Tcl_CreateThread(&id, NewThread, (ClientData) &ctrl,
- TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) {
+ if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
+ TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp,"can't create a new thread",0);
ckfree((void*)ctrl.script);
/*
*------------------------------------------------------------------------
*
- * NewThread --
+ * NewTestThread --
*
* This routine is the "main()" for a new thread whose task is to
* execute a single TCL script. The argument to this function is
*------------------------------------------------------------------------
*/
Tcl_ThreadCreateType
-NewThread(clientData)
+NewTestThread(clientData)
ClientData clientData;
{
ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
Tcl_Interp *interp; /* Interp that failed */
{
Tcl_Channel errChannel;
- char *errorInfo, *script;
- char *argv[3];
+ CONST char *errorInfo, *argv[3];
+ char *script;
char buf[TCL_DOUBLE_SPACE+1];
sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
*
*------------------------------------------------------------------------
*/
-int
+static int
ThreadEventProc(evPtr, mask)
Tcl_Event *evPtr; /* Really ThreadEvent */
int mask;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
- char *result, *errorCode, *errorInfo;
+ CONST char *result, *errorCode, *errorInfo;
if (interp == NULL) {
code = TCL_ERROR;
*------------------------------------------------------------------------
*/
/* ARGSUSED */
-void
+static void
ThreadFreeProc(clientData)
ClientData clientData;
{
*------------------------------------------------------------------------
*/
/* ARGSUSED */
-int
+static int
ThreadDeleteEvent(eventPtr, clientData)
Tcl_Event *eventPtr; /* Really ThreadEvent */
ClientData clientData; /* dummy */
*------------------------------------------------------------------------
*/
/* ARGSUSED */
-void
+static void
ThreadExitProc(clientData)
ClientData clientData;
{
}
#endif /* TCL_THREADS */
-
* None.
*
* Side effects:
- * Removes the timer and idle event sources.
+ * Removes the timer and idle event sources and remaining events.
*
*----------------------------------------------------------------------
*/
TimerExitProc(clientData)
ClientData clientData; /* Not used. */
{
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
+
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
+ if (tsdPtr != NULL) {
+ register TimerHandler *timerHandlerPtr;
+ timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
+ while (timerHandlerPtr != NULL) {
+ tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
+ ckfree((char *) timerHandlerPtr);
+ timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
+ }
+ }
}
\f
/*
* Compute when the event should fire.
*/
- TclpGetTime(&time);
+ Tcl_GetTime(&time);
timerHandlerPtr->time.sec = time.sec + milliseconds/1000;
timerHandlerPtr->time.usec = time.usec + (milliseconds%1000)*1000;
if (timerHandlerPtr->time.usec >= 1000000) {
* Compute the timeout for the next timer on the list.
*/
- TclpGetTime(&blockTime);
+ Tcl_GetTime(&blockTime);
blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
blockTime.usec;
* Compute the timeout for the next timer on the list.
*/
- TclpGetTime(&blockTime);
+ Tcl_GetTime(&blockTime);
blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
blockTime.usec;
tsdPtr->timerPending = 0;
currentTimerId = tsdPtr->lastTimerId;
- TclpGetTime(&time);
+ Tcl_GetTime(&time);
while (1) {
nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
char *argString;
int index;
char buf[16 + TCL_INTEGER_SPACE];
- static char *afterSubCmds[] = {"cancel", "idle", "info", (char *) NULL};
+ static CONST char *afterSubCmds[] = {
+ "cancel", "idle", "info", (char *) NULL
+ };
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
/*
- * tclUtfData.c --
+ * tclUniData.c --
*
* Declarations of Unicode character information tables. This file is
* automatically generated by the tools/uniParse.tcl script. Do not
*/
static unsigned char pageMap[] = {
- 0, 1, 2, 3, 0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18,
- 19, 20, 21, 22, 23, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 7, 33,
- 7, 34, 35, 16, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48,
- 49, 50, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66,
- 55, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 77, 78,
- 81, 82, 77, 16, 16, 16, 16, 83, 84, 85, 16, 86, 87, 88, 16, 89, 90,
- 91, 92, 93, 94, 16, 16, 16, 16, 16, 16, 16, 95, 96, 97, 47, 47, 98,
- 47, 47, 99, 47, 100, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 7,
- 7, 7, 7, 101, 7, 7, 102, 103, 104, 105, 106, 104, 107, 108, 109, 110,
- 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124,
- 125, 126, 126, 126, 126, 126, 126, 126, 127, 128, 129, 123, 130, 16,
- 16, 16, 16, 123, 131, 125, 132, 133, 134, 135, 136, 123, 123, 123,
- 123, 137, 123, 123, 138, 139, 123, 123, 138, 16, 16, 16, 16, 140, 141,
- 142, 143, 144, 145, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 146, 147, 83, 47, 148, 83, 47, 149, 150, 151, 47, 47, 152,
- 16, 16, 16, 153, 154, 155, 156, 154, 157, 158, 159, 123, 123, 123,
- 160, 123, 123, 161, 159, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 47, 47, 47, 47, 47, 47, 47,
+ 0, 1, 2, 3, 0, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 7, 15, 16, 17,
+ 18, 19, 20, 21, 22, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 7, 32,
+ 7, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 47,
+ 48, 49, 50, 51, 52, 35, 47, 53, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69,
+ 58, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 80, 81,
+ 84, 85, 80, 86, 87, 88, 89, 90, 91, 92, 35, 93, 94, 95, 35, 96, 97,
+ 98, 99, 100, 101, 102, 35, 47, 103, 104, 35, 35, 105, 106, 107, 47,
+ 47, 108, 47, 47, 109, 47, 110, 111, 47, 112, 47, 113, 114, 115, 116,
+ 114, 47, 117, 118, 35, 47, 47, 119, 90, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 120, 121, 47, 47, 122,
+ 35, 35, 35, 35, 47, 123, 124, 125, 126, 47, 127, 128, 47, 129, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 7, 7, 7, 7, 130, 7, 7, 131, 132, 133, 134,
+ 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148,
+ 149, 150, 151, 152, 153, 154, 155, 156, 156, 156, 156, 156, 156, 156,
+ 157, 158, 159, 160, 161, 162, 35, 35, 35, 160, 163, 164, 165, 166,
+ 167, 168, 169, 160, 160, 160, 160, 170, 171, 172, 173, 174, 160, 160,
+ 175, 35, 35, 35, 35, 176, 177, 178, 179, 180, 181, 35, 35, 160, 160,
+ 160, 160, 160, 160, 160, 160, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 182, 160, 160, 155, 160, 160, 160, 160, 160, 160, 170, 183, 184, 185,
+ 90, 47, 186, 90, 47, 187, 188, 189, 47, 47, 190, 128, 35, 35, 191,
+ 192, 193, 194, 192, 195, 196, 197, 160, 160, 160, 198, 160, 160, 199,
+ 197, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 200, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
- 162, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16,
- 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 16, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 201, 35, 35, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 202, 203, 204, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
- 47, 47, 47, 47, 47, 47, 163, 16, 16, 164, 164, 164, 164, 164, 164,
- 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164,
- 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164,
- 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164,
- 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164, 164,
- 164, 164, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165, 165,
- 165, 165, 165, 165, 165, 165, 47, 47, 47, 47, 47, 47, 47, 47, 47, 166,
- 16, 16, 16, 16, 16, 16, 167, 168, 169, 47, 47, 170, 171, 47, 47, 47,
- 47, 47, 47, 47, 47, 47, 47, 172, 173, 47, 174, 47, 175, 176, 16, 177,
- 178, 179, 47, 47, 47, 180, 181, 2, 182, 183, 184, 185, 186, 187
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 205, 35, 35, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
+ 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
+ 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
+ 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206,
+ 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 206, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 47, 47, 47, 47, 47, 47, 47, 47, 47, 208, 35, 35, 35, 35,
+ 35, 35, 209, 210, 211, 47, 47, 212, 213, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 214, 215, 47, 216, 47, 217, 218, 35, 219, 220, 221, 47,
+ 47, 47, 222, 223, 2, 224, 225, 226, 227, 228, 229, 230, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 231, 35, 232, 233,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47, 47,
+ 47, 208, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 47, 234, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 235, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207, 207,
+ 207, 207, 207, 236, 207, 207, 207, 207, 207, 207, 207, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35, 35,
+ 35, 35, 35, 35, 35
};
/*
10, 10, 10, 10, 10, 10, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 5, 7, 6, 7, 1, 2, 3, 4, 4, 4, 4, 14, 14, 11, 14, 15, 16,
- 7, 8, 14, 11, 14, 7, 17, 17, 11, 15, 14, 3, 11, 17, 15, 18, 17, 17,
+ 7, 8, 14, 11, 14, 7, 17, 17, 11, 18, 14, 3, 11, 17, 15, 19, 17, 17,
17, 3, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 7, 10, 10, 10, 10, 10, 10, 10, 15,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
- 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, 13, 13, 13, 19, 20, 21,
- 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
- 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 22, 23, 20, 21, 20,
- 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
- 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
- 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 24,
- 20, 21, 20, 21, 20, 21, 25, 15, 26, 20, 21, 20, 21, 27, 20, 21, 28,
- 28, 20, 21, 15, 29, 30, 31, 20, 21, 28, 32, 15, 33, 34, 20, 21, 15,
- 15, 33, 35, 15, 36, 20, 21, 20, 21, 20, 21, 37, 20, 21, 37, 38, 15,
- 20, 21, 37, 20, 21, 39, 39, 20, 21, 20, 21, 40, 20, 21, 15, 38, 20,
- 21, 38, 38, 38, 38, 38, 38, 41, 42, 43, 41, 42, 43, 41, 42, 43, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 44, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
- 15, 41, 42, 43, 20, 21, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21,
- 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
- 21, 20, 21, 20, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 45,
- 46, 15, 47, 47, 15, 48, 15, 49, 15, 15, 15, 15, 47, 15, 15, 50, 15,
- 15, 15, 15, 51, 52, 15, 15, 15, 15, 15, 52, 15, 15, 53, 15, 15, 54,
- 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 55, 15, 15, 55, 15, 15, 15,
- 15, 55, 15, 56, 56, 15, 15, 15, 15, 15, 15, 57, 15, 15, 15, 15, 15,
- 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
- 0, 0, 0, 0, 0, 0, 0, 58, 58, 58, 58, 58, 58, 58, 58, 58, 11, 11, 58,
- 58, 58, 58, 58, 58, 58, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
- 11, 11, 11, 58, 58, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
- 11, 0, 58, 58, 58, 58, 58, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59,
- 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59,
- 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 60, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11,
- 0, 0, 0, 0, 58, 0, 0, 0, 3, 0, 0, 0, 0, 0, 11, 11, 61, 3, 62, 62, 62,
- 0, 63, 0, 64, 64, 15, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
- 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 65, 66,
- 66, 66, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
- 13, 13, 13, 67, 13, 13, 13, 13, 13, 13, 13, 13, 13, 68, 69, 69, 0,
- 70, 71, 72, 72, 72, 73, 74, 0, 0, 0, 72, 0, 72, 0, 72, 0, 72, 0, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 75, 76, 44, 38,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 77, 77, 77, 77, 77, 77, 77,
- 77, 77, 77, 77, 77, 0, 77, 77, 10, 10, 10, 10, 10, 10, 10, 10, 10,
+ 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, 13, 13, 13, 20, 21, 22,
+ 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21,
+ 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22,
+ 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 23, 24, 21, 22, 21,
+ 22, 21, 22, 15, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21,
+ 22, 21, 22, 15, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21,
+ 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22,
+ 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 25,
+ 21, 22, 21, 22, 21, 22, 26, 15, 27, 21, 22, 21, 22, 28, 21, 22, 29,
+ 29, 21, 22, 15, 30, 31, 32, 21, 22, 29, 33, 34, 35, 36, 21, 22, 15,
+ 15, 35, 37, 15, 38, 21, 22, 21, 22, 21, 22, 39, 21, 22, 39, 15, 15,
+ 21, 22, 39, 21, 22, 40, 40, 21, 22, 21, 22, 41, 21, 22, 15, 42, 21,
+ 22, 15, 43, 42, 42, 42, 42, 44, 45, 46, 44, 45, 46, 44, 45, 46, 21,
+ 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 47, 21,
+ 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22,
+ 15, 44, 45, 46, 21, 22, 48, 49, 21, 22, 21, 22, 21, 22, 21, 22, 0,
+ 0, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22,
+ 21, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 50, 51, 15, 52, 52, 15, 53, 15,
+ 54, 15, 15, 15, 15, 52, 15, 15, 55, 15, 15, 15, 15, 56, 57, 15, 15,
+ 15, 15, 15, 57, 15, 15, 58, 15, 15, 59, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 60, 15, 15, 60, 15, 15, 15, 15, 60, 15, 61, 61, 15, 15,
+ 15, 15, 15, 15, 62, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 63,
+ 63, 63, 63, 63, 63, 63, 63, 63, 11, 11, 63, 63, 63, 63, 63, 63, 63,
+ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 63, 11,
+ 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 63, 63, 63,
+ 63, 11, 11, 11, 11, 11, 11, 11, 11, 11, 63, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 65, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64,
+ 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 11, 11,
+ 0, 0, 0, 0, 63, 0, 0, 0, 3, 0, 0, 0, 0, 0, 11, 11, 66, 3, 67, 67, 67,
+ 0, 68, 0, 69, 69, 15, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
+ 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, 10, 10, 10, 70, 71,
+ 71, 71, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 72, 13, 13, 13, 13, 13, 13, 13, 13, 13, 73, 74, 74, 0,
+ 75, 76, 77, 77, 77, 78, 79, 15, 0, 0, 21, 22, 21, 22, 21, 22, 21, 22,
+ 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 80, 81, 47,
+ 15, 82, 83, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 84, 84, 84, 84, 84, 84, 84,
+ 84, 84, 84, 84, 84, 84, 84, 84, 84, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
- 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
- 13, 13, 13, 13, 0, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76, 76,
- 0, 76, 76, 20, 21, 14, 59, 59, 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 38, 20,
- 21, 20, 21, 0, 0, 20, 21, 0, 0, 20, 21, 0, 0, 0, 20, 21, 20, 21, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
- 20, 21, 20, 21, 20, 21, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0,
- 20, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78,
- 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78,
- 78, 78, 78, 78, 78, 78, 0, 0, 58, 3, 3, 3, 3, 3, 3, 0, 79, 79, 79,
- 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79,
- 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79, 79,
- 79, 15, 0, 3, 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, 59, 59,
- 59, 59, 59, 59, 59, 59, 59, 59, 59, 0, 59, 59, 59, 59, 59, 59, 59,
- 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 0,
- 59, 59, 59, 3, 59, 3, 59, 59, 3, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 0, 38, 38,
- 38, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0,
- 3, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 0, 58, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 59, 59, 59, 59, 59, 59, 59, 59, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3,
- 3, 3, 3, 0, 0, 59, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 38, 38, 38, 38, 38, 0, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38,
- 38, 3, 38, 59, 59, 59, 59, 59, 59, 59, 80, 80, 59, 59, 59, 59, 59,
- 59, 58, 58, 59, 59, 14, 59, 59, 59, 59, 0, 0, 9, 9, 9, 9, 9, 9, 9,
- 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 59, 59, 81, 0, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 59, 38, 81,
- 81, 81, 59, 59, 59, 59, 59, 59, 59, 59, 81, 81, 81, 81, 59, 0, 0, 38,
- 59, 59, 59, 59, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 59,
- 59, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 59, 81, 81, 0, 38, 38, 38, 38, 38, 38, 38,
- 38, 0, 0, 38, 38, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38,
- 38, 38, 0, 38, 0, 0, 0, 38, 38, 38, 38, 0, 0, 59, 0, 81, 81, 81, 59,
- 59, 59, 59, 0, 0, 81, 81, 0, 0, 81, 81, 59, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 81, 0, 0, 0, 0, 38, 38, 0, 38, 38, 38, 59, 59, 0, 0, 9, 9, 9, 9,
- 9, 9, 9, 9, 9, 9, 38, 38, 4, 4, 17, 17, 17, 17, 17, 17, 14, 0, 0, 0,
- 0, 0, 0, 0, 59, 0, 0, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 38, 38, 0,
- 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 0,
- 38, 38, 0, 38, 38, 0, 0, 59, 0, 81, 81, 81, 59, 59, 0, 0, 0, 0, 59,
- 59, 0, 0, 59, 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, 38,
- 38, 0, 38, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 59, 59,
- 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 59, 59, 81, 0, 38,
- 38, 38, 38, 38, 38, 38, 0, 38, 0, 38, 38, 38, 0, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 0, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 0, 38, 38, 38, 38, 38, 0,
- 0, 59, 38, 81, 81, 81, 59, 59, 59, 59, 59, 0, 59, 59, 81, 0, 81, 81,
- 59, 0, 0, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 0, 0,
- 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38,
- 38, 38, 38, 38, 0, 38, 38, 0, 0, 38, 38, 38, 38, 0, 0, 59, 38, 81,
- 59, 81, 59, 59, 59, 0, 0, 0, 81, 81, 0, 0, 81, 81, 59, 0, 0, 0, 0,
- 0, 0, 0, 0, 59, 81, 0, 0, 0, 0, 38, 38, 0, 38, 38, 38, 0, 0, 0, 0,
- 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 59, 81, 0, 38, 38, 38, 38, 38, 38, 0, 0, 0, 38, 38,
- 38, 0, 38, 38, 38, 38, 0, 0, 0, 38, 38, 0, 38, 0, 38, 38, 0, 0, 0,
- 38, 38, 0, 0, 0, 38, 38, 38, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38,
- 0, 38, 38, 38, 0, 0, 0, 0, 81, 81, 59, 81, 81, 0, 0, 0, 81, 81, 81,
- 0, 81, 81, 81, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 81, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 81, 81, 81, 0, 38, 38, 38, 38,
- 38, 38, 38, 38, 0, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 0, 0, 0, 0,
- 59, 59, 59, 81, 81, 81, 81, 0, 59, 59, 59, 0, 59, 59, 59, 59, 0, 0,
- 0, 0, 0, 0, 0, 59, 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, 0, 0, 0,
- 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 81, 81, 0, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38,
- 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 0, 38, 38, 38, 38, 38, 0, 0, 0, 0, 81, 59, 81, 81, 81,
- 81, 81, 0, 59, 81, 81, 0, 81, 81, 59, 59, 0, 0, 0, 0, 0, 0, 0, 81,
- 81, 0, 0, 0, 0, 0, 0, 0, 38, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 0, 0, 0, 0, 81, 81, 81, 59, 59, 59, 0, 0, 81, 81, 81, 0, 81, 81, 81,
- 59, 0, 0, 0, 0, 0, 0, 0, 0, 0, 81, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 59, 38, 38, 59, 59,
- 59, 59, 59, 59, 59, 0, 0, 0, 0, 4, 38, 38, 38, 38, 38, 38, 58, 59,
- 59, 59, 59, 59, 59, 59, 59, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3,
- 0, 0, 0, 0, 0, 38, 38, 0, 38, 0, 0, 38, 38, 0, 38, 0, 0, 38, 0, 0,
- 0, 0, 0, 0, 38, 38, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38,
- 38, 0, 38, 0, 38, 0, 0, 38, 38, 0, 38, 38, 38, 38, 59, 38, 38, 59,
- 59, 59, 59, 59, 59, 0, 59, 59, 38, 0, 0, 38, 38, 38, 38, 38, 0, 58,
- 0, 59, 59, 59, 59, 59, 59, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
- 38, 38, 0, 0, 38, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
- 3, 3, 14, 14, 14, 14, 14, 59, 59, 14, 14, 14, 14, 14, 14, 9, 9, 9,
- 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 59,
- 14, 59, 14, 59, 5, 6, 5, 6, 81, 81, 38, 38, 38, 38, 38, 38, 38, 38,
- 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59,
- 59, 59, 81, 59, 59, 59, 59, 59, 3, 59, 59, 38, 38, 38, 38, 0, 0, 0,
- 0, 59, 59, 59, 59, 59, 59, 0, 59, 0, 59, 59, 59, 59, 59, 59, 59, 59,
- 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 0, 0, 0, 59, 59,
- 59, 59, 59, 59, 59, 0, 59, 0, 0, 0, 0, 0, 0, 78, 78, 78, 78, 78, 78,
- 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78,
- 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
- 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
- 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 3, 0, 0, 0, 0,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 0, 38, 38, 38, 38,
- 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 0, 0, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
- 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 15, 15, 15, 15, 15,
- 82, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
- 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0, 0, 0, 0,
- 0, 83, 83, 83, 83, 83, 83, 83, 83, 84, 84, 84, 84, 84, 84, 84, 84,
- 83, 83, 83, 83, 83, 83, 0, 0, 84, 84, 84, 84, 84, 84, 0, 0, 83, 83,
- 83, 83, 83, 83, 83, 83, 84, 84, 84, 84, 84, 84, 84, 84, 83, 83, 83,
- 83, 83, 83, 83, 83, 84, 84, 84, 84, 84, 84, 84, 84, 83, 83, 83, 83,
- 83, 83, 0, 0, 84, 84, 84, 84, 84, 84, 0, 0, 15, 83, 15, 83, 15, 83,
- 15, 83, 0, 84, 0, 84, 0, 84, 0, 84, 83, 83, 83, 83, 83, 83, 83, 83,
- 84, 84, 84, 84, 84, 84, 84, 84, 85, 85, 86, 86, 86, 86, 87, 87, 88,
- 88, 89, 89, 90, 90, 0, 0, 83, 83, 83, 83, 83, 83, 83, 83, 84, 84, 84,
- 84, 84, 84, 84, 84, 83, 83, 15, 91, 15, 0, 15, 15, 84, 84, 92, 92,
- 93, 11, 94, 11, 11, 11, 15, 91, 15, 0, 15, 15, 95, 95, 95, 95, 93,
- 11, 11, 11, 83, 83, 15, 15, 0, 0, 15, 15, 84, 84, 96, 96, 0, 11, 11,
- 11, 83, 83, 15, 15, 15, 97, 15, 15, 84, 84, 98, 98, 99, 11, 11, 11,
- 0, 0, 15, 91, 15, 0, 15, 15, 100, 100, 101, 101, 93, 11, 11, 0, 2,
- 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 102, 102, 102, 102, 8, 8, 8, 8, 8,
- 8, 3, 3, 16, 18, 5, 16, 16, 18, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 103,
- 104, 102, 102, 102, 102, 102, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 18,
- 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 13, 13, 13, 13, 13, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81, 81,
+ 81, 81, 81, 81, 21, 22, 14, 64, 64, 64, 64, 0, 85, 85, 0, 0, 21, 22,
+ 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21,
+ 22, 77, 21, 22, 21, 22, 0, 0, 21, 22, 0, 0, 21, 22, 0, 0, 0, 21, 22,
+ 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21,
+ 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22,
+ 21, 22, 0, 0, 21, 22, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 102, 102, 102, 102, 102, 102, 17, 0, 0, 0, 17, 17, 17, 17, 17,
- 17, 7, 7, 7, 5, 6, 15, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 7, 7,
- 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 4,
- 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 59,
- 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 59, 80, 80, 80, 80, 59,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86,
+ 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
+ 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
+ 0, 0, 63, 3, 3, 3, 3, 3, 3, 0, 87, 87, 87, 87, 87, 87, 87, 87, 87,
+ 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87,
+ 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 87, 15, 0, 3, 8, 0, 0,
+ 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 0, 64, 64, 64, 3, 64, 3, 64,
+ 64, 3, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 0, 0, 0, 0, 0, 42, 42, 42, 3, 3, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 3, 0, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 0, 0, 0, 0, 0, 63, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 64, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 3, 42, 64,
+ 64, 64, 64, 64, 64, 64, 85, 85, 64, 64, 64, 64, 64, 64, 63, 63, 64,
+ 64, 14, 64, 64, 64, 64, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 42, 42,
+ 42, 14, 14, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 88, 42,
+ 64, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64,
+ 64, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 0, 0, 64, 42, 89, 89, 89, 64, 64, 64, 64, 64, 64,
+ 64, 64, 89, 89, 89, 89, 64, 0, 0, 42, 64, 64, 64, 64, 0, 0, 0, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 64, 64, 3, 3, 9, 9, 9, 9, 9, 9,
+ 9, 9, 9, 9, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64,
+ 89, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 0, 0, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42, 0, 0, 0, 42,
+ 42, 42, 42, 0, 0, 64, 0, 89, 89, 89, 64, 64, 64, 64, 0, 0, 89, 89,
+ 0, 0, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 0, 0, 42, 42,
+ 0, 42, 42, 42, 64, 64, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 42, 42,
+ 4, 4, 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, 0, 0, 0, 0, 64, 0, 0, 42,
+ 42, 42, 42, 42, 42, 0, 0, 0, 0, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0,
+ 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 0, 42, 42, 0, 42, 42, 0, 0,
+ 64, 0, 89, 89, 89, 64, 64, 0, 0, 0, 0, 64, 64, 0, 0, 64, 64, 64, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 0, 42, 0, 0, 0, 0, 0,
+ 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 64, 64, 42, 42, 42, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 89, 0, 42, 42, 42, 42, 42, 42, 42,
+ 0, 42, 0, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42,
+ 42, 42, 0, 42, 42, 0, 42, 42, 42, 42, 42, 0, 0, 64, 42, 89, 89, 89,
+ 64, 64, 64, 64, 64, 0, 64, 64, 89, 0, 89, 89, 64, 0, 0, 42, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 0, 0, 0, 0, 0, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42,
+ 42, 0, 0, 42, 42, 42, 42, 0, 0, 64, 42, 89, 64, 89, 64, 64, 64, 0,
+ 0, 0, 89, 89, 0, 0, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 64, 89, 0,
+ 0, 0, 0, 42, 42, 0, 42, 42, 42, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
+ 9, 9, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 89,
+ 0, 42, 42, 42, 42, 42, 42, 0, 0, 0, 42, 42, 42, 0, 42, 42, 42, 42,
+ 0, 0, 0, 42, 42, 0, 42, 0, 42, 42, 0, 0, 0, 42, 42, 0, 0, 0, 42, 42,
+ 42, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 0, 0, 0,
+ 0, 89, 89, 64, 89, 89, 0, 0, 0, 89, 89, 89, 0, 89, 89, 89, 64, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 89, 89, 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42,
+ 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 0, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 89, 89,
+ 89, 89, 0, 64, 64, 64, 0, 64, 64, 64, 64, 0, 0, 0, 0, 0, 0, 0, 64,
+ 64, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9,
+ 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89,
+ 89, 0, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 0, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42,
+ 42, 42, 0, 0, 0, 0, 89, 64, 89, 89, 89, 89, 89, 0, 64, 89, 89, 0, 89,
+ 89, 64, 64, 0, 0, 0, 0, 0, 0, 0, 89, 89, 0, 0, 0, 0, 0, 0, 0, 42, 0,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 89, 89, 89, 64, 64,
+ 64, 0, 0, 89, 89, 89, 0, 89, 89, 89, 64, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 89, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, 0, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 0, 0,
+ 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 64, 0, 0, 0, 0, 89, 89, 89, 64,
+ 64, 64, 0, 64, 0, 89, 89, 89, 89, 89, 89, 89, 89, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 89, 89, 3, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 64, 42, 42, 64, 64, 64, 64, 64, 64, 64, 0, 0, 0, 0, 4, 42, 42,
+ 42, 42, 42, 42, 63, 64, 64, 64, 64, 64, 64, 64, 64, 3, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 42, 42, 0, 42, 0, 0, 42, 42,
+ 0, 42, 0, 0, 42, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 0, 42, 42, 42, 42,
+ 42, 42, 42, 0, 42, 42, 42, 0, 42, 0, 42, 0, 0, 42, 42, 0, 42, 42, 42,
+ 42, 64, 42, 42, 64, 64, 64, 64, 64, 64, 0, 64, 64, 42, 0, 0, 42, 42,
+ 42, 42, 42, 0, 63, 0, 64, 64, 64, 64, 64, 64, 0, 0, 9, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 0, 0, 42, 42, 0, 0, 42, 14, 14, 14, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 64, 64, 14, 14, 14,
+ 14, 14, 14, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 14, 64, 14, 64, 14, 64, 5, 6, 5, 6, 89, 89, 42, 42, 42,
+ 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 64, 64, 89, 64, 64, 64, 64, 64, 3, 64, 64, 42,
+ 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 0, 64, 64,
+ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 0, 14, 14, 14, 14, 14, 14, 14, 14, 64, 14, 14, 14, 14, 14, 14, 0, 0,
+ 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 0, 42,
+ 42, 42, 42, 42, 0, 42, 42, 0, 89, 64, 64, 64, 64, 89, 64, 0, 0, 0,
+ 64, 64, 89, 64, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3,
+ 3, 3, 3, 3, 3, 42, 42, 42, 42, 42, 42, 89, 89, 64, 64, 0, 0, 0, 0,
+ 0, 0, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77,
+ 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77,
+ 77, 77, 77, 77, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 0, 0, 0, 0, 3, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0,
+ 0, 0, 0, 0, 42, 42, 42, 42, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 42, 42, 42,
+ 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42,
+ 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 0, 42,
+ 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42,
+ 42, 0, 42, 0, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 42, 0,
+ 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3,
+ 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 3, 3, 42, 42, 42, 42, 42,
+ 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 5, 6, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 3, 3, 3, 90, 90, 90, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 89, 89, 89, 64, 64, 64, 64, 64, 64, 64, 89, 89, 89, 89, 89,
+ 89, 89, 89, 64, 89, 89, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 3, 3, 3, 3, 3, 3, 3, 4, 3, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3,
+ 3, 3, 3, 3, 8, 3, 3, 3, 3, 88, 88, 88, 88, 0, 9, 9, 9, 9, 9, 9, 9,
+ 9, 9, 9, 0, 0, 0, 0, 0, 0, 42, 42, 42, 63, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0,
+ 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 64, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 22, 21, 22, 21, 22, 21,
+ 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 15, 15,
+ 15, 15, 15, 91, 0, 0, 0, 0, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22,
+ 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 21, 22, 0,
+ 0, 0, 0, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93,
+ 93, 93, 93, 92, 92, 92, 92, 92, 92, 0, 0, 93, 93, 93, 93, 93, 93, 0,
+ 0, 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93,
+ 92, 92, 92, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 92,
+ 92, 92, 92, 92, 92, 0, 0, 93, 93, 93, 93, 93, 93, 0, 0, 15, 92, 15,
+ 92, 15, 92, 15, 92, 0, 93, 0, 93, 0, 93, 0, 93, 92, 92, 92, 92, 92,
+ 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93, 94, 94, 95, 95, 95, 95,
+ 96, 96, 97, 97, 98, 98, 99, 99, 0, 0, 92, 92, 92, 92, 92, 92, 92, 92,
+ 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 92, 92, 92, 92, 92,
+ 92, 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 92, 92, 92, 92,
+ 92, 92, 100, 100, 100, 100, 100, 100, 100, 100, 92, 92, 15, 101, 15,
+ 0, 15, 15, 93, 93, 102, 102, 103, 11, 104, 11, 11, 11, 15, 101, 15,
+ 0, 15, 15, 105, 105, 105, 105, 103, 11, 11, 11, 92, 92, 15, 15, 0,
+ 0, 15, 15, 93, 93, 106, 106, 0, 11, 11, 11, 92, 92, 15, 15, 15, 107,
+ 15, 15, 93, 93, 108, 108, 109, 11, 11, 11, 0, 0, 15, 101, 15, 0, 15,
+ 15, 110, 110, 111, 111, 103, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 88, 88, 88, 88, 8, 8, 8, 8, 8, 8, 3, 3, 16, 19, 5, 16, 16,
+ 19, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 112, 113, 88, 88, 88, 88, 88, 2,
+ 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, 19, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7,
+ 5, 6, 0, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, 88, 88, 88, 88, 88, 17,
+ 0, 0, 0, 17, 17, 17, 17, 17, 17, 7, 7, 7, 5, 6, 15, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 7, 7, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 14, 14, 72, 14, 14, 14, 14, 72, 14, 14, 15, 72,
- 72, 72, 15, 15, 72, 72, 72, 15, 14, 72, 14, 14, 15, 72, 72, 72, 72,
- 72, 14, 14, 14, 14, 14, 14, 72, 14, 72, 14, 72, 14, 72, 72, 72, 72,
- 15, 15, 72, 72, 14, 72, 15, 38, 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17,
- 17, 17, 17, 17, 17, 17, 17, 17, 17, 105, 105, 105, 105, 105, 105, 105,
- 105, 105, 105, 105, 105, 105, 105, 105, 105, 106, 106, 106, 106, 106,
- 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 107, 107, 107,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
+ 64, 64, 64, 85, 85, 85, 85, 64, 85, 85, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 77,
+ 14, 14, 14, 14, 77, 14, 14, 15, 77, 77, 77, 15, 15, 77, 77, 77, 15,
+ 14, 77, 14, 14, 14, 77, 77, 77, 77, 77, 14, 14, 14, 14, 14, 14, 77,
+ 14, 114, 14, 77, 14, 115, 116, 77, 77, 14, 15, 77, 77, 14, 77, 15,
+ 42, 42, 42, 42, 15, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117, 117,
+ 117, 117, 117, 117, 117, 118, 118, 118, 118, 118, 118, 118, 118, 118,
+ 118, 118, 118, 118, 118, 118, 118, 90, 90, 90, 90, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14,
+ 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 14, 14, 7,
+ 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
- 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, 14, 7,
- 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14,
- 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
- 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 108, 108, 108, 108, 108, 108, 108,
- 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
- 108, 108, 108, 108, 108, 109, 109, 109, 109, 109, 109, 109, 109, 109,
- 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109,
- 109, 109, 109, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 119, 119, 119, 119, 119, 119,
+ 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119, 119,
+ 119, 119, 119, 119, 119, 119, 120, 120, 120, 120, 120, 120, 120, 120,
+ 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120, 120,
+ 120, 120, 120, 120, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0,
- 0, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 0, 14, 14, 14, 14, 0,
- 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 0, 14,
- 14, 14, 14, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14,
- 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17,
+ 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
+ 14, 14, 14, 0, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 0, 14, 0, 14, 14, 14, 14, 0, 0, 0, 14, 0, 14, 14,
+ 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
- 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, 14, 14, 14,
+ 17, 17, 17, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 0, 2, 3, 3, 3, 14, 58, 38, 107, 5, 6, 5, 6, 5, 6, 5, 6, 5,
- 6, 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 107, 107, 107, 107,
- 107, 107, 107, 107, 107, 59, 59, 59, 59, 59, 59, 8, 58, 58, 58, 58,
- 58, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 59,
- 59, 11, 11, 58, 58, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 12,
- 58, 58, 58, 0, 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 14, 14, 17, 17,
- 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
+ 0, 0, 0, 2, 3, 3, 3, 14, 63, 42, 90, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6,
+ 14, 14, 5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 90, 90, 90, 90, 90,
+ 90, 90, 90, 90, 64, 64, 64, 64, 64, 64, 8, 63, 63, 63, 63, 63, 14,
+ 14, 90, 90, 90, 0, 0, 0, 14, 14, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64,
+ 11, 11, 63, 63, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 12, 63,
+ 63, 63, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 14, 14, 17, 17, 17,
+ 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17,
- 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
+ 14, 14, 14, 14, 14, 14, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 38, 38, 38, 38, 38,
- 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 38, 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 110, 110, 110, 110,
- 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
- 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110, 110,
- 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111,
- 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111, 111,
- 111, 111, 111, 111, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
- 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
- 15, 15, 0, 0, 0, 0, 0, 0, 59, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 7, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 38, 38, 38,
- 38, 38, 0, 38, 0, 38, 38, 0, 38, 38, 0, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0, 0, 59, 59, 59, 59,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 0, 14, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 42, 42, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 121, 121, 121, 121, 121, 121, 121,
+ 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121,
+ 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 121, 122, 122, 122,
+ 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122,
+ 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122,
+ 122, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
+ 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 0,
+ 0, 0, 0, 0, 42, 64, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 7, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 42, 42, 42, 42,
+ 42, 0, 42, 0, 42, 42, 0, 42, 42, 0, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0, 0, 64, 64, 64, 64,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5,
6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 0, 0, 0, 0, 3, 3, 3, 3, 12, 12, 12,
3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6, 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7,
- 0, 3, 4, 3, 3, 0, 0, 0, 0, 38, 38, 38, 0, 38, 0, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 0, 0, 102, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9,
+ 0, 3, 4, 3, 3, 0, 0, 0, 0, 42, 42, 42, 0, 42, 0, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 0, 0, 88, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 11, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
- 13, 13, 13, 5, 7, 6, 7, 0, 0, 3, 5, 6, 3, 12, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 58, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 58,
- 58, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38,
- 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 38, 0, 0, 0,
- 38, 38, 38, 38, 38, 38, 0, 0, 38, 38, 38, 38, 38, 38, 0, 0, 38, 38,
- 38, 38, 38, 38, 0, 0, 38, 38, 38, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0,
- 14, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
- 14, 0, 0
+ 13, 13, 13, 5, 7, 6, 7, 0, 0, 3, 5, 6, 3, 12, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 63,
+ 63, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42,
+ 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 0, 0, 0,
+ 42, 42, 42, 42, 42, 42, 0, 0, 42, 42, 42, 42, 42, 42, 0, 0, 42, 42,
+ 42, 42, 42, 42, 0, 0, 42, 42, 42, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0,
+ 14, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 88, 88, 88, 14,
+ 14, 42, 17, 42, 42, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 123, 123, 123,
+ 126, 126, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 89, 64, 14, 14, 14,
+ 14, 14, 0, 0, 77, 77, 15, 15, 77, 15, 15, 77, 77, 15, 77, 77, 15, 77,
+ 77, 15, 15, 77, 15, 15, 77, 77, 15, 77, 77, 15, 77, 77, 15, 15, 77,
+ 15, 15, 77, 77, 15, 77, 77, 15, 77, 77, 15, 15, 77, 77, 15, 15, 77,
+ 15, 15, 77, 77, 15, 15, 77, 15, 15, 77, 77, 15, 15, 9, 9, 9, 42, 42,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 88, 0, 88, 88, 88, 88, 88, 88, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 122, 122,
+ 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122,
+ 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122, 122,
+ 122
};
/*
static int groups[] = {
0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 134217793, 28, 19, 134217858,
- 29, 2, 23, 11, 24, -507510654, 4194369, 4194434, -834666431, 973078658,
- -507510719, 1258291330, 880803905, 864026689, 859832385, 331350081,
- 847249473, 851443777, 868220993, 884998209, 876609601, 893386817,
- 897581121, 914358337, 5, 910164033, 918552641, 8388705, 4194499,
- 8388770, 331350146, 880803970, 864026754, 859832450, 847249538,
- 851443842, 868221058, 876609666, 884998274, 893386882, 897581186,
- 914358402, 910164098, 918552706, 4, 6, -352321338, 159383617,
- 155189313, 268435521, 264241217, 159383682, 155189378, 130023554,
- 268435586, 264241282, 260046978, 239075458, 1, 197132418, 226492546,
- 360710274, 335544450, 335544385, 201326657, 201326722, 7, 8, 247464066,
- -33554302, -33554367, -310378366, -360710014, -419430270, -536870782,
- -469761918, -528482174, -37748606, -310378431, -37748671, 155189442,
- -360710079, -419430335, -29359998, -469761983, -29360063, -536870847,
- -528482239, 16, 13, 14, 67108938, 67109002, 10, 109051997, 109052061,
- 18, 17
+ 29, 2, 23, 11, 1178599554, 24, -507510654, 4194369, 4194434, -834666431,
+ 973078658, -507510719, 1258291330, 880803905, 864026689, 859832385,
+ 331350081, 847249473, 851443777, 868220993, -406847358, 884998209,
+ 876609601, 893386817, 897581121, 914358337, 910164033, 918552641,
+ 5, -234880894, 8388705, 4194499, 8388770, 331350146, -406847423,
+ -234880959, 880803970, 864026754, 859832450, 847249538, 851443842,
+ 868221058, 876609666, 884998274, 893386882, 897581186, 914358402,
+ 910164098, 918552706, 4, 6, -352321402, 159383617, 155189313,
+ 268435521, 264241217, 159383682, 155189378, 130023554, 268435586,
+ 264241282, 260046978, 239075458, 1, 197132418, 226492546, 360710274,
+ 335544450, -251658175, 402653314, 335544385, 7, 201326657, 201326722,
+ 16, 8, 10, 247464066, -33554302, -33554367, -310378366, -360710014,
+ -419430270, -536870782, -469761918, -528482174, -33554365, -37748606,
+ -310378431, -37748669, 155189378, -360710079, -419430335, -29359998,
+ -469761983, -29360063, -536870847, -528482239, 13, 14, -1463812031,
+ -801111999, -293601215, 67108938, 67109002, 109051997, 109052061,
+ 18, 17, 8388673, 12582977, 8388738, 12583042
};
/*
#define GetCaseType(info) (((info) & 0xE0) >> 5)
#define GetCategory(info) ((info) & 0x1F)
-#define GetDelta(infO) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22)))
+#define GetDelta(info) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22)))
/*
* This macro extracts the information about a character from the
* The following structures are used when mapping between Unicode (UCS-2)
* and UTF-8.
*/
-
-CONST unsigned char totalBytes[256] = {
+
+static CONST unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
*---------------------------------------------------------------------------
*/
-static int
+INLINE static int
UtfCount(ch)
int ch; /* The Tcl_UniChar whose size is returned. */
{
* Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
* characters representing themselves.
*/
-
+
*chPtr = (Tcl_UniChar) byte;
return 1;
} else if (byte < 0xE0) {
/*
* Two-byte-character lead-byte followed by a trail-byte.
*/
-
+
*chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (str[1] & 0x3F));
return 2;
}
* A two-byte-character lead-byte not followed by trail-byte
* represents itself.
*/
-
+
*chPtr = (Tcl_UniChar) byte;
return 1;
} else if (byte < 0xF0) {
*
*---------------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_UtfFindFirst(string, ch)
CONST char *string; /* The UTF-8 string to be searched. */
int ch; /* The Tcl_UniChar to search for. */
while (1) {
len = Tcl_UtfToUniChar(string, &find);
if (find == ch) {
- return (char *) string;
+ return string;
}
if (*string == '\0') {
return NULL;
*---------------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_UtfFindLast(string, ch)
CONST char *string; /* The UTF-8 string to be searched. */
int ch; /* The Tcl_UniChar to search for. */
}
string += len;
}
- return (char *) last;
+ return last;
}
\f
/*
*---------------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_UtfNext(str)
CONST char *str; /* The current location in the string. */
{
Tcl_UniChar ch;
- return (char *) str + Tcl_UtfToUniChar(str, &ch);
+ return str + Tcl_UtfToUniChar(str, &ch);
}
\f
/*
* Tcl_UtfPrev --
*
* Given a pointer to some current location in a UTF-8 string,
- * move backwards one character.
+ * move backwards one character. This works correctly when the
+ * pointer is in the middle of a UTF-8 character.
*
* Results:
* The return value is a pointer to the previous character in the
*---------------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_UtfPrev(str, start)
CONST char *str; /* The current location in the string. */
CONST char *start; /* Pointer to the beginning of the
byte = *((unsigned char *) look);
if (byte < 0x80) {
break;
- }
+ }
if (byte >= 0xC0) {
- if (totalBytes[byte] != i + 1) {
- break;
- }
- return (char *) look;
+ return look;
}
look--;
}
- return (char *) str;
+ return str;
}
\f
/*
*---------------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_UtfAtIndex(src, index)
register CONST char *src; /* The UTF-8 string. */
register int index; /* The position of the desired character. */
index--;
src += Tcl_UtfToUniChar(src, &ch);
}
- return (char *) src;
+ return src;
}
\f
/*
char *dst; /* Filled with the bytes represented by the
* backslash sequence. */
{
- register CONST char *p = src+1;
- int result, count, n;
- char buf[TCL_UTF_MAX];
-
- if (dst == NULL) {
- dst = buf;
+#define LINE_LENGTH 128
+ int numRead;
+ int result;
+
+ result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);
+ if (numRead == LINE_LENGTH) {
+ /* We ate a whole line. Pay the price of a strlen() */
+ result = TclParseBackslash(src, (int)strlen(src), &numRead, dst);
}
-
- count = 2;
- switch (*p) {
- /*
- * Note: in the conversions below, use absolute values (e.g.,
- * 0xa) rather than symbolic values (e.g. \n) that get converted
- * by the compiler. It's possible that compilers on some
- * platforms will do the symbolic conversions differently, which
- * could result in non-portable Tcl scripts.
- */
-
- case 'a':
- result = 0x7;
- break;
- case 'b':
- result = 0x8;
- break;
- case 'f':
- result = 0xc;
- break;
- case 'n':
- result = 0xa;
- break;
- case 'r':
- result = 0xd;
- break;
- case 't':
- result = 0x9;
- break;
- case 'v':
- result = 0xb;
- break;
- case 'x':
- if (isxdigit(UCHAR(p[1]))) { /* INTL: digit */
- char *end;
-
- result = (unsigned char) strtoul(p+1, &end, 16);
- count = end - src;
- } else {
- count = 2;
- result = 'x';
- }
- break;
- case 'u':
- result = 0;
- for (count = 0; count < 4; count++) {
- p++;
- if (!isxdigit(UCHAR(*p))) { /* INTL: digit */
- break;
- }
- n = *p - '0';
- if (n > 9) {
- n = n + '0' + 10 - 'A';
- }
- if (n > 16) {
- n = n + 'A' - 'a';
- }
- result = (result << 4) + n;
- }
- if (count == 0) {
- result = 'u';
- }
- count += 2;
- break;
-
- case '\n':
- do {
- p++;
- } while ((*p == ' ') || (*p == '\t'));
- result = ' ';
- count = p - src;
- break;
- case 0:
- result = '\\';
- count = 1;
- break;
- default:
- /*
- * Check for an octal number \oo?o?
- */
- if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */
- result = (unsigned char)(*p - '0');
- p++;
- if (!isdigit(UCHAR(*p)) || (UCHAR(*p) >= '8')) { /* INTL: digit */
- break;
- }
- count = 3;
- result = (unsigned char)((result << 3) + (*p - '0'));
- p++;
- if (!isdigit(UCHAR(*p)) || (UCHAR(*p) >= '8')) { /* INTL: digit */
- break;
- }
- count = 4;
- result = (unsigned char)((result << 3) + (*p - '0'));
- break;
- }
- result = *p;
- count = 2;
- break;
- }
-
if (readPtr != NULL) {
- *readPtr = count;
+ *readPtr = numRead;
}
- return Tcl_UniCharToUtf(result, dst);
+ return result;
}
\f
/*
/*
*----------------------------------------------------------------------
*
+ * TclpUtfNcmp2 --
+ *
+ * Compare at most n bytes of utf-8 strings cs and ct. Both cs
+ * and ct are assumed to be at least n bytes long.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpUtfNcmp2(cs, ct, n)
+ CONST char *cs; /* UTF string to compare to ct. */
+ CONST char *ct; /* UTF string cs is compared to. */
+ unsigned long n; /* Number of *bytes* to compare. */
+{
+ /*
+ * We can't simply call 'memcmp(cs, ct, n);' because we need to check
+ * for Tcl's \xC0\x80 non-utf-8 null encoding.
+ * Otherwise utf-8 lexes fine in the strcmp manner.
+ */
+ register int result = 0;
+
+ for ( ; n != 0; n--, cs++, ct++) {
+ if (*cs != *ct) {
+ result = UCHAR(*cs) - UCHAR(*ct);
+ break;
+ }
+ }
+ if (n && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) {
+ unsigned char c1, c2;
+ c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs);
+ c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct);
+ result = (c1 - c2);
+ }
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_UtfNcmp --
*
* Compare at most n UTF chars of string cs to string ct. Both cs
{
Tcl_UniChar ch1, ch2;
/*
- * Another approach that should work is:
- * return memcmp(cs, ct, (unsigned) (Tcl_UtfAtIndex(cs, n) - cs));
- * That assumes that ct is a properly formed UTF, so we will just
- * be comparing the bytes that compromise those strings to the
- * char length n.
+ * Cannot use 'memcmp(cs, ct, n);' as byte representation of
+ * \u0000 (the pair of bytes 0xc0,0x80) is larger than byte
+ * representation of \u0001 (the byte 0x01.)
*/
while (n-- > 0) {
/*
int
Tcl_UniCharLen(str)
- Tcl_UniChar *str; /* Unicode string to find length of. */
+ CONST Tcl_UniChar *str; /* Unicode string to find length of. */
{
int len = 0;
CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */
unsigned long n; /* Number of unichars to compare. */
{
- for ( ; n != 0; n--, cs++, ct++) {
+#ifdef WORDS_BIGENDIAN
+ /*
+ * We are definitely on a big-endian machine; memcmp() is safe
+ */
+ return memcmp(cs, ct, n*sizeof(Tcl_UniChar));
+
+#else /* !WORDS_BIGENDIAN */
+ /*
+ * We can't simply call memcmp() because that is not lexically correct.
+ */
+ for ( ; n != 0; cs++, ct++, n--) {
if (*cs != *ct) {
- return *cs - *ct;
+ return (*cs - *ct);
}
- if (*cs == '\0') {
- break;
+ }
+ return 0;
+#endif /* WORDS_BIGENDIAN */
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharNcasecmp --
+ *
+ * Compare at most n unichars of string cs to string ct case
+ * insensitive. Both cs and ct are assumed to be at least n
+ * unichars long.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharNcasecmp(cs, ct, n)
+ CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */
+ CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */
+ unsigned long n; /* Number of unichars to compare. */
+{
+ for ( ; n != 0; n--, cs++, ct++) {
+ if ((*cs != *ct) &&
+ (Tcl_UniCharToLower(*cs) != Tcl_UniCharToLower(*ct))) {
+ return (*cs - *ct);
}
}
return 0;
return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> category) & 1);
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharCaseMatch --
+ *
+ * See if a particular Unicode string matches a particular pattern.
+ * Allows case insensitivity. This is the Unicode equivalent of
+ * the char* Tcl_StringCaseMatch.
+ *
+ * Results:
+ * The return value is 1 if string matches pattern, and
+ * 0 otherwise. The matching operation permits the following
+ * special characters in the pattern: *?\[] (see the manual
+ * entry for details on what these mean).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharCaseMatch(string, pattern, nocase)
+ CONST Tcl_UniChar *string; /* Unicode String. */
+ CONST Tcl_UniChar *pattern; /* Pattern, which may contain special
+ * characters. */
+ int nocase; /* 0 for case sensitive, 1 for insensitive */
+{
+ Tcl_UniChar ch1, p;
+
+ while (1) {
+ p = *pattern;
+
+ /*
+ * See if we're at the end of both the pattern and the string. If
+ * so, we succeeded. If we're at the end of the pattern but not at
+ * the end of the string, we failed.
+ */
+
+ if (p == 0) {
+ return (*string == 0);
+ }
+ if ((*string == 0) && (p != '*')) {
+ return 0;
+ }
+
+ /*
+ * Check for a "*" as the next pattern character. It matches any
+ * substring. We handle this by skipping all the characters up to the
+ * next matching one in the pattern, and then calling ourselves
+ * recursively for each postfix of string, until either we match or we
+ * reach the end of the string.
+ */
+
+ if (p == '*') {
+ /*
+ * Skip all successive *'s in the pattern
+ */
+ while (*(++pattern) == '*') {}
+ p = *pattern;
+ if (p == 0) {
+ return 1;
+ }
+ if (nocase) {
+ p = Tcl_UniCharToLower(p);
+ }
+ while (1) {
+ /*
+ * Optimization for matching - cruise through the string
+ * quickly if the next char in the pattern isn't a special
+ * character
+ */
+ if ((p != '[') && (p != '?') && (p != '\\')) {
+ if (nocase) {
+ while (*string && (p != *string)
+ && (p != Tcl_UniCharToLower(*string))) {
+ string++;
+ }
+ } else {
+ while (*string && (p != *string)) { string++; }
+ }
+ }
+ if (Tcl_UniCharCaseMatch(string, pattern, nocase)) {
+ return 1;
+ }
+ if (*string == 0) {
+ return 0;
+ }
+ string++;
+ }
+ }
+
+ /*
+ * Check for a "?" as the next pattern character. It matches
+ * any single character.
+ */
+
+ if (p == '?') {
+ pattern++;
+ string++;
+ continue;
+ }
+
+ /*
+ * Check for a "[" as the next pattern character. It is followed
+ * by a list of characters that are acceptable, or by a range
+ * (two characters separated by "-").
+ */
+
+ if (p == '[') {
+ Tcl_UniChar startChar, endChar;
+
+ pattern++;
+ ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
+ string++;
+ while (1) {
+ if ((*pattern == ']') || (*pattern == 0)) {
+ return 0;
+ }
+ startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);
+ pattern++;
+ if (*pattern == '-') {
+ pattern++;
+ if (*pattern == 0) {
+ return 0;
+ }
+ endChar = (nocase ? Tcl_UniCharToLower(*pattern)
+ : *pattern);
+ pattern++;
+ if (((startChar <= ch1) && (ch1 <= endChar))
+ || ((endChar <= ch1) && (ch1 <= startChar))) {
+ /*
+ * Matches ranges of form [a-z] or [z-a].
+ */
+ break;
+ }
+ } else if (startChar == ch1) {
+ break;
+ }
+ }
+ while (*pattern != ']') {
+ if (*pattern == 0) {
+ pattern--;
+ break;
+ }
+ pattern++;
+ }
+ pattern++;
+ continue;
+ }
+
+ /*
+ * If the next pattern character is '\', just strip off the '\'
+ * so we do exact matching on the character that follows.
+ */
+
+ if (p == '\\') {
+ if (*(++pattern) == '\0') {
+ return 0;
+ }
+ }
+
+ /*
+ * There's no special character. Just make sure that the next
+ * bytes of each string match.
+ */
+
+ if (nocase) {
+ if (Tcl_UniCharToLower(*string) != Tcl_UniCharToLower(*pattern)) {
+ return 0;
+ }
+ } else if (*string != *pattern) {
+ return 0;
+ }
+ string++;
+ pattern++;
+ }
+}
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* to sprintf. */
TCL_DECLARE_MUTEX(precisionMutex)
+/*
+ * Prototypes for procedures defined later in this file.
+ */
+
+static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
+static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
+ Tcl_Obj* objPtr));
+
+/*
+ * The following is the Tcl object type definition for an object
+ * that represents a list index in the form, "end-offset". It is
+ * used as a performance optimization in TclGetIntForIndex. The
+ * internal rep is an integer, so no memory management is required
+ * for it.
+ */
+
+Tcl_ObjType tclEndOffsetType = {
+ "end-offset", /* name */
+ (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */
+ (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
+ UpdateStringOfEndOffset, /* updateStringProc */
+ SetEndOffsetFromAny
+};
+
\f
/*
*----------------------------------------------------------------------
* Copy a string and eliminate any backslashes that aren't in braces.
*
* Results:
- * There is no return value. Count characters get copied from src to
- * dst. Along the way, if backslash sequences are found outside braces,
- * the backslashes are eliminated in the copy. After scanning count
- * chars from source, a null character is placed at the end of dst.
- * Returns the number of characters that got copied.
+ * Count characters get copied from src to dst. Along the way, if
+ * backslash sequences are found outside braces, the backslashes are
+ * eliminated in the copy. After scanning count chars from source, a
+ * null character is placed at the end of dst. Returns the number
+ * of characters that got copied.
*
* Side effects:
* None.
CONST char *list; /* Pointer to string with list structure. */
int *argcPtr; /* Pointer to location to fill in with
* the number of elements in the list. */
- char ***argvPtr; /* Pointer to place to store pointer to
+ CONST char ***argvPtr; /* Pointer to place to store pointer to
* array of pointers to list elements. */
{
- char **argv;
+ CONST char **argv;
CONST char *l;
char *p;
int length, size, i, result, elSize, brace;
}
}
size++; /* Leave space for final NULL pointer. */
- argv = (char **) ckalloc((unsigned)
+ argv = (CONST char **) ckalloc((unsigned)
((size * sizeof(char *)) + (l - list) + 1));
length = strlen(list);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
char *
Tcl_Merge(argc, argv)
int argc; /* How many strings to merge. */
- char **argv; /* Array of string values. */
+ CONST char * CONST *argv; /* Array of string values. */
{
# define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr;
char *
Tcl_Concat(argc, argv)
int argc; /* Number of strings to concatenate. */
- char **argv; /* Array of strings to concatenate. */
+ CONST char * CONST *argv; /* Array of strings to concatenate. */
{
int totalSize, i;
char *p;
return result;
}
for (p = result, i = 0; i < argc; i++) {
- char *element;
+ CONST char *element;
int length;
/*
for (i = 0; i < objc; i++) {
objPtr = objv[i];
element = Tcl_GetStringFromObj(objPtr, &elemLength);
- while ((elemLength > 0)
- && (isspace(UCHAR(*element)))) { /* INTL: ISO space. */
+ while ((elemLength > 0) && (UCHAR(*element) < 127)
+ && isspace(UCHAR(*element))) { /* INTL: ISO C space. */
element++;
elemLength--;
}
* this case it could be significant.
*/
- while ((elemLength > 0)
- && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */
+ while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127)
+ && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */
&& ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
elemLength--;
}
CONST char *pattern; /* Pattern, which may contain special
* characters. */
{
- int p, s;
- CONST char *pstart = pattern;
-
- while (1) {
- p = *pattern;
- s = *string;
-
- /*
- * See if we're at the end of both the pattern and the string. If
- * so, we succeeded. If we're at the end of the pattern but not at
- * the end of the string, we failed.
- */
-
- if (p == '\0') {
- if (s == '\0') {
- return 1;
- } else {
- return 0;
- }
- }
- if ((s == '\0') && (p != '*')) {
- return 0;
- }
-
- /* Check for a "*" as the next pattern character. It matches
- * any substring. We handle this by calling ourselves
- * recursively for each postfix of string, until either we
- * match or we reach the end of the string.
- */
-
- if (p == '*') {
- pattern++;
- if (*pattern == '\0') {
- return 1;
- }
- while (1) {
- if (Tcl_StringMatch(string, pattern)) {
- return 1;
- }
- if (*string == '\0') {
- return 0;
- }
- string++;
- }
- }
-
- /* Check for a "?" as the next pattern character. It matches
- * any single character.
- */
-
- if (p == '?') {
- Tcl_UniChar ch;
-
- pattern++;
- string += Tcl_UtfToUniChar(string, &ch);
- continue;
- }
-
- /* Check for a "[" as the next pattern character. It is followed
- * by a list of characters that are acceptable, or by a range
- * (two characters separated by "-").
- */
-
- if (p == '[') {
- Tcl_UniChar ch, startChar, endChar;
-
- pattern++;
- string += Tcl_UtfToUniChar(string, &ch);
-
- while (1) {
- if ((*pattern == ']') || (*pattern == '\0')) {
- return 0;
- }
- pattern += Tcl_UtfToUniChar(pattern, &startChar);
- if (*pattern == '-') {
- pattern++;
- if (*pattern == '\0') {
- return 0;
- }
- pattern += Tcl_UtfToUniChar(pattern, &endChar);
- if (((startChar <= ch) && (ch <= endChar))
- || ((endChar <= ch) && (ch <= startChar))) {
- /*
- * Matches ranges of form [a-z] or [z-a].
- */
-
- break;
- }
- } else if (startChar == ch) {
- break;
- }
- }
- while (*pattern != ']') {
- if (*pattern == '\0') {
- pattern = Tcl_UtfPrev(pattern, pstart);
- break;
- }
- pattern++;
- }
- pattern++;
- continue;
- }
-
- /* If the next pattern character is '\', just strip off the '\'
- * so we do exact matching on the character that follows.
- */
-
- if (p == '\\') {
- pattern++;
- p = *pattern;
- if (p == '\0') {
- return 0;
- }
- }
-
- /* There's no special character. Just make sure that the next
- * bytes of each string match.
- */
-
- if (s != p) {
- return 0;
- }
- pattern++;
- string++;
- }
+ return Tcl_StringCaseMatch(string, pattern, 0);
}
\f
/*
* characters. */
int nocase; /* 0 for case sensitive, 1 for insensitive */
{
- int p, s;
+ int p;
CONST char *pstart = pattern;
Tcl_UniChar ch1, ch2;
while (1) {
p = *pattern;
- s = *string;
/*
* See if we're at the end of both the pattern and the string. If
*/
if (p == '\0') {
- return (s == '\0');
+ return (*string == '\0');
}
- if ((s == '\0') && (p != '*')) {
+ if ((*string == '\0') && (p != '*')) {
return 0;
}
- /* Check for a "*" as the next pattern character. It matches
+ /*
+ * Check for a "*" as the next pattern character. It matches
* any substring. We handle this by calling ourselves
* recursively for each postfix of string, until either we
* match or we reach the end of the string.
*/
if (p == '*') {
- pattern++;
- if (*pattern == '\0') {
+ /*
+ * Skip all successive *'s in the pattern
+ */
+ while (*(++pattern) == '*') {}
+ p = *pattern;
+ if (p == '\0') {
return 1;
}
+ Tcl_UtfToUniChar(pattern, &ch2);
+ if (nocase) {
+ ch2 = Tcl_UniCharToLower(ch2);
+ }
while (1) {
+ /*
+ * Optimization for matching - cruise through the string
+ * quickly if the next char in the pattern isn't a special
+ * character
+ */
+ if ((p != '[') && (p != '?') && (p != '\\')) {
+ if (nocase) {
+ while (*string) {
+ int charLen = Tcl_UtfToUniChar(string, &ch1);
+ if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
+ break;
+ }
+ string += charLen;
+ }
+ } else {
+ /*
+ * There's no point in trying to make this code
+ * shorter, as the number of bytes you want to
+ * compare each time is non-constant.
+ */
+ while (*string) {
+ int charLen = Tcl_UtfToUniChar(string, &ch1);
+ if (ch2 == ch1) {
+ break;
+ }
+ string += charLen;
+ }
+ }
+ }
if (Tcl_StringCaseMatch(string, pattern, nocase)) {
return 1;
}
if (*string == '\0') {
return 0;
}
- string++;
+ string += Tcl_UtfToUniChar(string, &ch1);
}
}
- /* Check for a "?" as the next pattern character. It matches
+ /*
+ * Check for a "?" as the next pattern character. It matches
* any single character.
*/
continue;
}
- /* Check for a "[" as the next pattern character. It is followed
+ /*
+ * Check for a "[" as the next pattern character. It is followed
* by a list of characters that are acceptable, or by a range
* (two characters separated by "-").
*/
-
+
if (p == '[') {
Tcl_UniChar startChar, endChar;
continue;
}
- /* If the next pattern character is '\', just strip off the '\'
+ /*
+ * If the next pattern character is '\', just strip off the '\'
* so we do exact matching on the character that follows.
*/
-
+
if (p == '\\') {
pattern++;
- p = *pattern;
- if (p == '\0') {
+ if (*pattern == '\0') {
return 0;
}
}
- /* There's no special character. Just make sure that the next
+ /*
+ * There's no special character. Just make sure that the next
* bytes of each string match.
*/
-
+
string += Tcl_UtfToUniChar(string, &ch1);
pattern += Tcl_UtfToUniChar(pattern, &ch2);
if (nocase) {
CONST char *string; /* String to append. Must be
* null-terminated. */
{
- int newSize, flags;
+ int newSize, flags, strSize;
char *dst;
- newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
+ strSize = ((string == NULL) ? 0 : strlen(string));
+ newSize = Tcl_ScanCountedElement(string, strSize, &flags)
+ + dsPtr->length + 1;
/*
* Allocate a larger buffer for the string if the current one isn't
dst++;
dsPtr->length++;
}
- dsPtr->length += Tcl_ConvertElement(string, dst, flags);
+ dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags);
return dsPtr->string;
}
\f
TclPrecTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter containing variable. */
- char *name1; /* Name of variable. */
- char *name2; /* Second part of variable name. */
+ CONST char *name1; /* Name of variable. */
+ CONST char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
{
- char *value, *end;
+ CONST char *value;
+ char *end;
int prec;
/*
int
TclNeedSpace(start, end)
- char *start; /* First character in string. */
- char *end; /* End of string (place where space will
+ CONST char *start; /* First character in string. */
+ CONST char *end; /* End of string (place where space will
* be added, if appropriate). */
{
+ Tcl_UniChar ch;
+
/*
* A space is needed unless either
* (a) we're at the start of the string, or
if (end == start) {
return 0;
}
- end--;
+ end = Tcl_UtfPrev(end, start);
if (*end != '{') {
- if (isspace(UCHAR(*end)) /* INTL: ISO space. */
- && ((end == start) || (end[-1] != '\\'))) {
+ Tcl_UtfToUniChar(end, &ch);
+ /*
+ * Direct char comparison on next line is safe as it is with
+ * a character in the ASCII subset, and so single-byte in UTF8.
+ */
+ if (Tcl_UniCharIsSpace(ch) && ((end == start) || (end[-1] != '\\'))) {
return 0;
}
return 1;
if (end == start) {
return 0;
}
- end--;
+ end = Tcl_UtfPrev(end, start);
} while (*end == '{');
- if (isspace(UCHAR(*end))) { /* INTL: ISO space. */
+ Tcl_UtfToUniChar(end, &ch);
+ if (Tcl_UniCharIsSpace(ch)) {
return 0;
}
return 1;
int
TclLooksLikeInt(bytes, length)
- register char *bytes; /* Points to first byte of the string. */
+ register CONST char *bytes; /* Points to first byte of the string. */
int length; /* Number of bytes in the string. If < 0
* bytes up to the first null byte are
* considered (if they may appear in an
* integer). */
{
- register char *p, *end;
+ register CONST char *p;
+
+ if ((bytes == NULL) && (length > 0)) {
+ Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
+ }
if (length < 0) {
- length = (bytes? strlen(bytes) : 0);
+ length = (bytes? strlen(bytes) : 0);
}
- end = (bytes + length);
p = bytes;
- while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */
- p++;
+ while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
+ length--; p++;
}
- if (p == end) {
- return 0;
+ if (length == 0) {
+ return 0;
}
-
if ((*p == '+') || (*p == '-')) {
- p++;
- }
- if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */
- return 0;
- }
- p++;
- while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */
- p++;
- }
- if (p == end) {
- return 1;
- }
- if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
- return 1;
+ p++; length--;
}
- return 0;
+
+ return (0 != TclParseInteger(p, length));
}
\f
/*
*
* Side effects:
* The object referenced by "objPtr" might be converted to an
- * integer object.
+ * integer, wide integer, or end-based-index object.
*
*----------------------------------------------------------------------
*/
* representing an index. */
{
char *bytes;
- int length, offset;
+ int offset;
+#ifndef TCL_WIDE_INT_IS_LONG
+ Tcl_WideInt wideOffset;
+#endif
+
+ /*
+ * If the object is already an integer, use it.
+ */
if (objPtr->typePtr == &tclIntType) {
*indexPtr = (int)objPtr->internalRep.longValue;
return TCL_OK;
}
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ /*
+ * If the object is already a wide-int, and it is not out of range
+ * for an integer, use it. [Bug #526717]
+ */
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (objPtr->typePtr == &tclWideIntType) {
+ Tcl_WideInt wideOffset = objPtr->internalRep.wideValue;
+ if (wideOffset >= Tcl_LongAsWide(INT_MIN)
+ && wideOffset <= Tcl_LongAsWide(INT_MAX)) {
+ *indexPtr = (int) Tcl_WideAsLong(wideOffset);
+ return TCL_OK;
+ }
+ }
+#endif /* TCL_WIDE_INT_IS_LONG */
- if ((*bytes != 'e') || (strncmp(bytes, "end",
- (size_t)((length > 3) ? 3 : length)) != 0)) {
- if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) {
- goto intforindex_error;
+ if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
+ /*
+ * If the object is already an offset from the end of the
+ * list, or can be converted to one, use it.
+ */
+
+ *indexPtr = endValue + objPtr->internalRep.longValue;
+
+#ifdef TCL_WIDE_INT_IS_LONG
+ } else if (Tcl_GetIntFromObj(NULL, objPtr, &offset) == TCL_OK) {
+ /*
+ * If the object can be converted to an integer, use that.
+ */
+
+ *indexPtr = offset;
+
+#else /* !TCL_WIDE_INT_IS_LONG */
+ } else if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideOffset) == TCL_OK) {
+ /*
+ * If the object can be converted to a wide integer, use
+ * that. [Bug #526717]
+ */
+
+ offset = (int) Tcl_WideAsLong(wideOffset);
+ if (Tcl_LongAsWide(offset) == wideOffset) {
+ /*
+ * But it is representable as a narrow integer, so we
+ * prefer that (so preserving old behaviour in the
+ * majority of cases.)
+ */
+ objPtr->typePtr = &tclIntType;
+ objPtr->internalRep.longValue = offset;
}
*indexPtr = offset;
+
+#endif /* TCL_WIDE_INT_IS_LONG */
+ } else {
+ /*
+ * Report a parse error.
+ */
+
+ if (interp != NULL) {
+ bytes = Tcl_GetString(objPtr);
+ /*
+ * The result might not be empty; this resets it which
+ * should be both a cheap operation, and of little problem
+ * because this is an error-generation path anyway.
+ */
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad index \"", bytes,
+ "\": must be integer or end?-integer?",
+ (char *) NULL);
+ if (!strncmp(bytes, "end-", 3)) {
+ bytes += 3;
+ }
+ TclCheckBadOctal(interp, bytes);
+ }
+
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfEndOffset --
+ *
+ * Update the string rep of a Tcl object holding an "end-offset"
+ * expression.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Stores a valid string in the object's string rep.
+ *
+ * This procedure does NOT free any earlier string rep. If it is
+ * called on an object that already has a valid string rep, it will
+ * leak memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfEndOffset(objPtr)
+ register Tcl_Obj* objPtr;
+{
+ char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
+ register int len;
+
+ strcpy(buffer, "end");
+ len = sizeof("end") - 1;
+ if (objPtr->internalRep.longValue != 0) {
+ buffer[len++] = '-';
+ len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
+ }
+ objPtr->bytes = ckalloc((unsigned) (len+1));
+ strcpy(objPtr->bytes, buffer);
+ objPtr->length = len;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetEndOffsetFromAny --
+ *
+ * Look for a string of the form "end-offset" and convert it
+ * to an internal representation holding the offset.
+ *
+ * Results:
+ * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
+ *
+ * Side effects:
+ * If interp is not NULL, stores an error message in the
+ * interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetEndOffsetFromAny(interp, objPtr)
+ Tcl_Interp* interp; /* Tcl interpreter or NULL */
+ Tcl_Obj* objPtr; /* Pointer to the object to parse */
+{
+ int offset; /* Offset in the "end-offset" expression */
+ Tcl_ObjType* oldTypePtr = objPtr->typePtr;
+ /* Old internal rep type of the object */
+ register char* bytes; /* String rep of the object */
+ int length; /* Length of the object's string rep */
+
+ /* If it's already the right type, we're fine. */
+
+ if (objPtr->typePtr == &tclEndOffsetType) {
return TCL_OK;
}
+ /* Check for a string rep of the right form. */
+
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ if ((*bytes != 'e') || (strncmp(bytes, "end",
+ (size_t)((length > 3) ? 3 : length)) != 0)) {
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad index \"", bytes,
+ "\": must be end?-integer?",
+ (char*) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /* Convert the string rep */
+
if (length <= 3) {
- *indexPtr = endValue;
+ offset = 0;
} else if (bytes[3] == '-') {
/*
* This is our limited string expression evaluator
if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) {
return TCL_ERROR;
}
- *indexPtr = endValue + offset;
+
} else {
- intforindex_error:
- if ((Interp *)interp != NULL) {
+ /*
+ * Conversion failed. Report the error.
+ */
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad index \"", bytes,
- "\": must be integer or end?-integer?", (char *) NULL);
- TclCheckBadOctal(interp, bytes);
+ "bad index \"", bytes,
+ "\": must be integer or end?-integer?",
+ (char *) NULL);
}
return TCL_ERROR;
}
+
+ /*
+ * The conversion succeeded. Free the old internal rep and set
+ * the new one.
+ */
+
+ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+ oldTypePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->internalRep.longValue = offset;
+ objPtr->typePtr = &tclEndOffsetType;
+
return TCL_OK;
-}
+}
\f
/*
*----------------------------------------------------------------------
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
- char *value; /* String to check. */
+ CONST char *value; /* String to check. */
{
- register char *p = value;
+ register CONST char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted
if (*p == '\0') {
/* Reached end of string */
if (interp != NULL) {
+ /*
+ * Don't reset the result here because we want this result
+ * to be added to an existing error message as extra info.
+ */
Tcl_AppendResult(interp, " (looks like invalid octal number)",
(char *) NULL);
}
CONST char *
Tcl_GetNameOfExecutable()
{
- return (tclExecutableName);
+ return tclExecutableName;
}
\f
/*
*----------------------------------------------------------------------
*
- * Tcl_GetCwd --
+ * TclpGetTime --
*
- * This function replaces the library version of getcwd().
+ * Deprecated synonym for Tcl_GetTime.
*
* Results:
- * The result is a pointer to a string specifying the current
- * directory, or NULL if the current directory could not be
- * determined. If NULL is returned, an error message is left in the
- * interp's result. Storage for the result string is allocated in
- * bufferPtr; the caller must call Tcl_DStringFree() when the result
- * is no longer needed.
- *
- * Side effects:
* None.
*
- *----------------------------------------------------------------------
- */
-
-char *
-Tcl_GetCwd(interp, cwdPtr)
- Tcl_Interp *interp;
- Tcl_DString *cwdPtr;
-{
- return TclpGetCwd(interp, cwdPtr);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Chdir --
- *
- * This function replaces the library version of chdir().
- *
- * Results:
- * See chdir() documentation.
- *
- * Side effects:
- * See chdir() documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_Chdir(dirName)
- CONST char *dirName;
-{
- return TclpChdir(dirName);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Access --
- *
- * This function replaces the library version of access().
- *
- * Results:
- * See access() documentation.
- *
* Side effects:
- * See access() documentation.
+ * Stores current time in the buffer designated by "timePtr"
*
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_Access(path, mode)
- CONST char *path; /* Path of file to access (UTF-8). */
- int mode; /* Permission setting. */
-{
- return TclAccess(path, mode);
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Stat --
- *
- * This function replaces the library version of stat().
- *
- * Results:
- * See stat() documentation.
- *
- * Side effects:
- * See stat() documentation.
+ * This procedure is provided for the benefit of extensions written
+ * before Tcl_GetTime was exported from the library.
*
*----------------------------------------------------------------------
*/
-int
-Tcl_Stat(path, bufPtr)
- CONST char *path; /* Path of file to stat (in UTF-8). */
- struct stat *bufPtr; /* Filled with results of stat call. */
+void
+TclpGetTime(timePtr)
+ Tcl_Time* timePtr;
{
- return TclStat(path, bufPtr);
+ Tcl_GetTime(timePtr);
}
* Copyright (c) 1987-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
* variable access is denied.
*/
-static char *noSuchVar = "no such variable";
-static char *isArray = "variable is array";
-static char *needArray = "variable isn't array";
-static char *noSuchElement = "no such element in array";
-static char *danglingElement = "upvar refers to element in deleted array";
-static char *danglingVar = "upvar refers to variable in deleted namespace";
-static char *badNamespace = "parent namespace doesn't exist";
-static char *missingName = "missing variable name";
-static char *isArrayElement = "name refers to an element in an array";
+static CONST char *noSuchVar = "no such variable";
+static CONST char *isArray = "variable is array";
+static CONST char *needArray = "variable isn't array";
+static CONST char *noSuchElement = "no such element in array";
+static CONST char *danglingElement =
+ "upvar refers to element in deleted array";
+static CONST char *danglingVar =
+ "upvar refers to variable in deleted namespace";
+static CONST char *badNamespace = "parent namespace doesn't exist";
+static CONST char *missingName = "missing variable name";
+static CONST char *isArrayElement = "name refers to an element in an array";
/*
* Forward references to procedures defined later in this file:
*/
-static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
- Var *varPtr, char *part1, char *part2,
- int flags));
+static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
+ Var *varPtr, CONST char *part1, CONST char *part2,
+ int flags, CONST int leaveErrMsg));
static void CleanupVar _ANSI_ARGS_((Var *varPtr,
Var *arrayPtr));
static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void DeleteArray _ANSI_ARGS_((Interp *iPtr,
- char *arrayName, Var *varPtr, int flags));
-static int MakeUpvar _ANSI_ARGS_((
- Interp *iPtr, CallFrame *framePtr,
- char *otherP1, char *otherP2, int otherFlags,
- char *myName, int myFlags));
+ CONST char *arrayName, Var *varPtr, int flags));
+static void DisposeTraceResult _ANSI_ARGS_((int flags,
+ char *result));
+static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp,
+ CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
+ CONST char *otherP2, CONST int otherFlags,
+ CONST char *myName, CONST int myFlags, int index));
static Var * NewVar _ANSI_ARGS_((void));
static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
- Var *varPtr, char *varName, char *string));
+ CONST Var *varPtr, CONST char *varName,
+ Tcl_Obj *handleObj));
static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
- char *part1, char *part2, char *operation,
- char *reason));
+ CONST char *part1, CONST char *part2,
+ CONST char *operation, CONST char *reason));
+static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+
+
+/*
+ * Functions defined in this file that may be exported in the future
+ * for use by the bytecode compiler and engine or to the public interface.
+ */
+
+Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *varName, int flags, CONST int create,
+ CONST char **errMsgPtr, int *indexPtr));
+int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *part1Ptr, CONST char *part2, int flags));
+
+static Tcl_FreeInternalRepProc FreeLocalVarName;
+static Tcl_DupInternalRepProc DupLocalVarName;
+static Tcl_UpdateStringProc UpdateLocalVarName;
+static Tcl_FreeInternalRepProc FreeNsVarName;
+static Tcl_DupInternalRepProc DupNsVarName;
+static Tcl_FreeInternalRepProc FreeParsedVarName;
+static Tcl_DupInternalRepProc DupParsedVarName;
+static Tcl_UpdateStringProc UpdateParsedVarName;
+
+/*
+ * Types of Tcl_Objs used to cache variable lookups.
+ *
+ *
+ * localVarName - INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1 = pointer to the corresponding Proc
+ * twoPtrValue.ptr2 = index into locals table
+ *
+ * nsVarName - INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1: pointer to the namespace containing the
+ * reference
+ * twoPtrValue.ptr2: pointer to the corresponding Var
+ *
+ * parsedVarName - INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj,
+ * or NULL if it is a scalar variable
+ * twoPtrValue.ptr2 = pointer to the element name string
+ * (owned by this Tcl_Obj), or NULL if
+ * it is a scalar variable
+ */
+
+Tcl_ObjType tclLocalVarNameType = {
+ "localVarName",
+ FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL
+};
+
+Tcl_ObjType tclNsVarNameType = {
+ "namespaceVarName",
+ FreeNsVarName, DupNsVarName, NULL, NULL
+};
+
+Tcl_ObjType tclParsedVarNameType = {
+ "parsedVarName",
+ FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL
+};
+
+/*
+ * Type of Tcl_Objs used to speed up array searches.
+ *
+ * INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
+ * twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
+ *
+ * Note that the value stored in ptr2 is the offset into the string of
+ * the start of the variable name and not the address of the variable
+ * name itself, as this can be safely copied.
+ */
+Tcl_ObjType tclArraySearchType = {
+ "array search",
+ NULL, NULL, NULL, SetArraySearchObj
+};
+
\f
/*
*----------------------------------------------------------------------
*
* TclLookupVar --
*
- * This procedure is used by virtually all of the variable code to
- * locate a variable given its name(s).
+ * This procedure is used to locate a variable given its name(s). It
+ * has been mostly superseded by TclObjLookupVar, it is now only used
+ * by the string-based interfaces. It is kept in tcl8.4 mainly because
+ * it is in the internal stubs table, so that some extension may be
+ * calling it.
*
* Results:
* The return value is a pointer to the variable structure indicated by
*
*----------------------------------------------------------------------
*/
-
Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
arrayPtrPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
- register char *part1; /* If part2 isn't NULL, this is the name of
+ CONST char *part1; /* If part2 isn't NULL, this is the name of
* an array. Otherwise, this
* is a full variable name that could
* include a parenthesized array element. */
- char *part2; /* Name of element within array, or NULL. */
+ CONST char *part2; /* Name of element within array, or NULL. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
- char *msg; /* Verb to use in error messages, e.g.
+ CONST char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
int createPart1; /* If 1, create hash table entry for part 1
* address of array variable. Otherwise
* this is set to NULL. */
{
- Interp *iPtr = (Interp *) interp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- /* Points to the procedure call frame whose
- * variables are currently in use. Same as
- * the current procedure's frame, if any,
- * unless an "uplevel" is executing. */
- Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which
- * to look up the variable. */
- Tcl_Var var; /* Used to search for global names. */
- Var *varPtr; /* Points to the Var structure returned for
- * the variable. */
- char *elName; /* Name of array element or NULL; may be
+ Var *varPtr;
+ CONST char *elName; /* Name of array element or NULL; may be
* same as part2, or may be openParen+1. */
- char *openParen, *closeParen;
+ int openParen, closeParen;
/* If this procedure parses a name into
- * array and index, these point to the
- * parens around the index. Otherwise they
- * are NULL. These are needed to restore
- * the parens after parsing the name. */
- Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
- ResolverScheme *resPtr;
- Tcl_HashEntry *hPtr;
- register char *p;
- int new, i, result;
+ * array and index, these are the offsets to
+ * the parens around the index. Otherwise
+ * they are -1. */
+ register CONST char *p;
+ CONST char *errMsg = NULL;
+ int index;
+#define VAR_NAME_BUF_SIZE 26
+ char buffer[VAR_NAME_BUF_SIZE];
+ char *newVarName = buffer;
varPtr = NULL;
*arrayPtrPtr = NULL;
- openParen = closeParen = NULL;
- varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
+ openParen = closeParen = -1;
/*
* Parse part1 into array name and index.
elName = part2;
for (p = part1; *p ; p++) {
if (*p == '(') {
- openParen = p;
+ openParen = p - part1;
do {
p++;
} while (*p != '\0');
p--;
if (*p == ')') {
if (part2 != NULL) {
- openParen = NULL;
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, msg, needArray);
}
- goto done;
+ return NULL;
}
- closeParen = p;
- *openParen = 0;
- elName = openParen+1;
+ closeParen = p - part1;
} else {
- openParen = NULL;
+ openParen = -1;
}
break;
}
}
+ if (openParen != -1) {
+ if (closeParen >= VAR_NAME_BUF_SIZE) {
+ newVarName = ckalloc((unsigned int) (closeParen+1));
+ }
+ memcpy(newVarName, part1, (unsigned int) closeParen);
+ newVarName[openParen] = '\0';
+ newVarName[closeParen] = '\0';
+ part1 = newVarName;
+ elName = newVarName + openParen + 1;
+ }
+
+ varPtr = TclLookupSimpleVar(interp, part1, flags,
+ createPart1, &errMsg, &index);
+ if (varPtr == NULL) {
+ if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
+ VarErrMsg(interp, part1, elName, msg, errMsg);
+ }
+ } else {
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ if (elName != NULL) {
+ *arrayPtrPtr = varPtr;
+ varPtr = TclLookupArrayElement(interp, part1, elName, flags,
+ msg, createPart1, createPart2, varPtr);
+ }
+ }
+ if (newVarName != buffer) {
+ ckfree(newVarName);
+ }
+
+ return varPtr;
+
+#undef VAR_NAME_BUF_SIZE
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjLookupVar --
+ *
+ * This procedure is used by virtually all of the variable code to
+ * locate a variable given its name(s). The parsing into array/element
+ * components and (if possible) the lookup results are cached in
+ * part1Ptr, which is converted to one of the varNameTypes.
+ *
+ * Results:
+ * The return value is a pointer to the variable structure indicated by
+ * part1Ptr and part2, or NULL if the variable couldn't be found. If
+ * the variable is found, *arrayPtrPtr is filled with the address of the
+ * variable structure for the array that contains the variable (or NULL
+ * if the variable is a scalar). If the variable can't be found and
+ * either createPart1 or createPart2 are 1, a new as-yet-undefined
+ * (VAR_UNDEFINED) variable structure is created, entered into a hash
+ * table, and returned.
+ *
+ * If the variable isn't found and creation wasn't specified, or some
+ * other error occurs, NULL is returned and an error message is left in
+ * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
+ *
+ * Note: it's possible for the variable returned to be VAR_UNDEFINED
+ * even if createPart1 or createPart2 are 1 (these only cause the hash
+ * table entry or array to be created). For example, the variable might
+ * be a global that has been unset but is still referenced by a
+ * procedure, or a variable that has been unset but it only being kept
+ * in existence (if VAR_UNDEFINED) by a trace.
+ *
+ * Side effects:
+ * New hashtable entries may be created if createPart1 or createPart2
+ * are 1.
+ * The object part1Ptr is converted to one of tclLocalVarNameType,
+ * tclNsVarNameType or tclParsedVarNameType and caches as much of the
+ * lookup as it can.
+ *
+ *----------------------------------------------------------------------
+ */
+Var *
+TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
+ arrayPtrPtr)
+ Tcl_Interp *interp; /* Interpreter to use for lookup. */
+ register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name
+ * of an array. Otherwise, this is a full
+ * variable name that could include a parenthesized
+ * array element. */
+ CONST char *part2; /* Name of element within array, or NULL. */
+ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * and TCL_LEAVE_ERR_MSG bits matter. */
+ CONST char *msg; /* Verb to use in error messages, e.g.
+ * "read" or "set". Only needed if
+ * TCL_LEAVE_ERR_MSG is set in flags. */
+ CONST int createPart1; /* If 1, create hash table entry for part 1
+ * of name, if it doesn't already exist. If
+ * 0, return error if it doesn't exist. */
+ CONST int createPart2; /* If 1, create hash table entry for part 2
+ * of name, if it doesn't already exist. If
+ * 0, return error if it doesn't exist. */
+ Var **arrayPtrPtr; /* If the name refers to an element of an
+ * array, *arrayPtrPtr gets filled in with
+ * address of array variable. Otherwise
+ * this is set to NULL. */
+{
+ Interp *iPtr = (Interp *) interp;
+ register Var *varPtr; /* Points to the variable's in-frame Var
+ * structure. */
+ char *part1;
+ int index, len1, len2;
+ int parsed = 0;
+ Tcl_Obj *objPtr;
+ Tcl_ObjType *typePtr = part1Ptr->typePtr;
+ CONST char *errMsg = NULL;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Namespace *nsPtr;
+
+ /*
+ * If part1Ptr is a tclParsedVarNameType, separate it into the
+ * pre-parsed parts.
+ */
+
+ *arrayPtrPtr = NULL;
+ if (typePtr == &tclParsedVarNameType) {
+ if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
+ if (part2 != NULL) {
+ /*
+ * ERROR: part1Ptr is already an array element, cannot
+ * specify a part2.
+ */
+
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ part1 = TclGetString(part1Ptr);
+ VarErrMsg(interp, part1, part2, msg, needArray);
+ }
+ return NULL;
+ }
+ part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
+ part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
+ typePtr = part1Ptr->typePtr;
+ }
+ parsed = 1;
+ }
+ part1 = Tcl_GetStringFromObj(part1Ptr, &len1);
+
+ nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
+ if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
+ goto doParse;
+ }
+
+ if (typePtr == &tclLocalVarNameType) {
+ Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1;
+ int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2;
+ int useLocal;
+
+ useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame
+ && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)));
+ if (useLocal && (procPtr == varFramePtr->procPtr)) {
+ /*
+ * part1Ptr points to an indexed local variable of the
+ * correct procedure: use the cached value.
+ */
+
+ varPtr = &(varFramePtr->compiledLocals[localIndex]);
+ goto donePart1;
+ }
+ goto doneParsing;
+ } else if (typePtr == &tclNsVarNameType) {
+ Namespace *cachedNsPtr;
+ int useGlobal, useReference;
+
+ varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;
+ cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;
+ useGlobal = (cachedNsPtr == iPtr->globalNsPtr)
+ && ((flags & TCL_GLOBAL_ONLY)
+ || ((*part1 == ':') && (*(part1+1) == ':'))
+ || (varFramePtr == NULL)
+ || (!varFramePtr->isProcCallFrame
+ && (nsPtr == iPtr->globalNsPtr)));
+ useReference = useGlobal || ((cachedNsPtr == nsPtr)
+ && ((flags & TCL_NAMESPACE_ONLY)
+ || (varFramePtr && !varFramePtr->isProcCallFrame
+ && !(flags & TCL_GLOBAL_ONLY)
+ /* careful: an undefined ns variable could
+ * be hiding a valid global reference. */
+ && !(varPtr->flags & VAR_UNDEFINED))));
+ if (useReference && (varPtr->hPtr != NULL)) {
+ /*
+ * A straight global or namespace reference, use it. It isn't
+ * so simple to deal with 'implicit' namespace references, i.e.,
+ * those where the reference could be to either a namespace
+ * or a global variable. Those we lookup again.
+ *
+ * If (varPtr->hPtr == NULL), this might be a reference to a
+ * variable in a deleted namespace, kept alive by e.g. part1Ptr.
+ * We could conceivably be so unlucky that a new namespace was
+ * created at the same address as the deleted one, so to be
+ * safe we test for a valid hPtr.
+ */
+ goto donePart1;
+ }
+ goto doneParsing;
+ }
+
+ doParse:
+ if (!parsed && (*(part1 + len1 - 1) == ')')) {
+ /*
+ * part1Ptr is possibly an unparsed array element.
+ */
+ register int i;
+ char *newPart2;
+ len2 = -1;
+ for (i = 0; i < len1; i++) {
+ if (*(part1 + i) == '(') {
+ if (part2 != NULL) {
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ VarErrMsg(interp, part1, part2, msg, needArray);
+ }
+ }
+
+ /*
+ * part1Ptr points to an array element; first copy
+ * the element name to a new string part2.
+ */
+
+ part2 = part1 + i + 1;
+ len2 = len1 - i - 2;
+ len1 = i;
+
+ newPart2 = ckalloc((unsigned int) (len2+1));
+ memcpy(newPart2, part2, (unsigned int) len2);
+ *(newPart2+len2) = '\0';
+ part2 = newPart2;
+
+ /*
+ * Free the internal rep of the original part1Ptr, now
+ * renamed objPtr, and set it to tclParsedVarNameType.
+ */
+
+ objPtr = part1Ptr;
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ typePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->typePtr = &tclParsedVarNameType;
+
+ /*
+ * Define a new string object to hold the new part1Ptr, i.e.,
+ * the array name. Set the internal rep of objPtr, reset
+ * typePtr and part1 to contain the references to the
+ * array name.
+ */
+
+ part1Ptr = Tcl_NewStringObj(part1, len1);
+ Tcl_IncrRefCount(part1Ptr);
+
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
+ objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;
+
+ typePtr = part1Ptr->typePtr;
+ part1 = TclGetString(part1Ptr);
+ break;
+ }
+ }
+ }
+
+ doneParsing:
+ /*
+ * part1Ptr is not an array element; look it up, and convert
+ * it to one of the cached types if possible.
+ */
+
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ typePtr->freeIntRepProc(part1Ptr);
+ part1Ptr->typePtr = NULL;
+ }
+
+ varPtr = TclLookupSimpleVar(interp, part1, flags,
+ createPart1, &errMsg, &index);
+ if (varPtr == NULL) {
+ if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
+ VarErrMsg(interp, part1, part2, msg, errMsg);
+ }
+ return NULL;
+ }
+
+ /*
+ * Cache the newly found variable if possible.
+ */
+
+ if (index >= 0) {
+ /*
+ * An indexed local variable.
+ */
+
+ Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr;
+
+ part1Ptr->typePtr = &tclLocalVarNameType;
+ procPtr->refCount++;
+ part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
+ part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
+ } else if (index > -3) {
+ Namespace *nsPtr;
+
+ nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
+ varPtr->refCount++;
+ part1Ptr->typePtr = &tclNsVarNameType;
+ part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
+ part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
+ } else {
+ /*
+ * At least mark part1Ptr as already parsed.
+ */
+ part1Ptr->typePtr = &tclParsedVarNameType;
+ part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
+ part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
+
+ donePart1:
+#if 0
+ if (varPtr == NULL) {
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ part1 = TclGetString(part1Ptr);
+ VarErrMsg(interp, part1, part2, msg,
+ "Cached variable reference is NULL.");
+ }
+ return NULL;
+ }
+#endif
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+
+ if (part2 != NULL) {
+ /*
+ * Array element sought: look it up.
+ */
+
+ part1 = TclGetString(part1Ptr);
+ *arrayPtrPtr = varPtr;
+ varPtr = TclLookupArrayElement(interp, part1, part2,
+ flags, msg, createPart1, createPart2, varPtr);
+ }
+ return varPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLookupSimpleVar --
+ *
+ * This procedure is used by to locate a simple variable (i.e., not
+ * an array element) given its name.
+ *
+ * Results:
+ * The return value is a pointer to the variable structure indicated by
+ * varName, or NULL if the variable couldn't be found. If the variable
+ * can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED)
+ * variable structure is created, entered into a hash table, and returned.
+ *
+ * If the current CallFrame corresponds to a proc and the variable found is
+ * one of the compiledLocals, its index is placed in *indexPtr. Otherwise,
+ * *indexPtr will be set to (according to the needs of TclObjLookupVar):
+ * -1 a global reference
+ * -2 a reference to a namespace variable
+ * -3 a non-cachable reference, i.e., one of:
+ * . non-indexed local var
+ * . a reference of unknown origin;
+ * . resolution by a namespace or interp resolver
+ *
+ * If the variable isn't found and creation wasn't specified, or some
+ * other error occurs, NULL is returned and the corresponding error
+ * message is left in *errMsgPtr.
+ *
+ * Note: it's possible for the variable returned to be VAR_UNDEFINED
+ * even if create is 1 (this only causes the hash table entry to be
+ * created). For example, the variable might be a global that has been
+ * unset but is still referenced by a procedure, or a variable that has
+ * been unset but it only being kept in existence (if VAR_UNDEFINED) by
+ * a trace.
+ *
+ * Side effects:
+ * A new hashtable entry may be created if create is 1.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Var *
+TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
+ Tcl_Interp *interp; /* Interpreter to use for lookup. */
+ CONST char *varName; /* This is a simple variable name that could
+ * representa scalar or an array. */
+ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * and TCL_LEAVE_ERR_MSG bits matter. */
+ CONST int create; /* If 1, create hash table entry for varname,
+ * if it doesn't already exist. If 0, return
+ * error if it doesn't exist. */
+ CONST char **errMsgPtr;
+ int *indexPtr;
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ /* Points to the procedure call frame whose
+ * variables are currently in use. Same as
+ * the current procedure's frame, if any,
+ * unless an "uplevel" is executing. */
+ Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which
+ * to look up the variable. */
+ Tcl_Var var; /* Used to search for global names. */
+ Var *varPtr; /* Points to the Var structure returned for
+ * the variable. */
+ Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
+ ResolverScheme *resPtr;
+ Tcl_HashEntry *hPtr;
+ int new, i, result;
+
+ varPtr = NULL;
+ varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
+ *indexPtr = -3;
/*
* If this namespace has a variable resolver, then give it first
* value, it may signal to continue onward, or it may signal
* an error.
*/
- if ((flags & TCL_GLOBAL_ONLY) != 0 || iPtr->varFramePtr == NULL) {
+ if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
cxtNsPtr = iPtr->globalNsPtr;
} else {
cxtNsPtr = iPtr->varFramePtr->nsPtr;
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
- result = (*cxtNsPtr->varResProc)(interp, part1,
+ result = (*cxtNsPtr->varResProc)(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->varResProc) {
- result = (*resPtr->varResProc)(interp, part1,
+ result = (*resPtr->varResProc)(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
}
resPtr = resPtr->nextPtr;
if (result == TCL_OK) {
varPtr = (Var *) var;
- goto lookupVarPart2;
+ return varPtr;
} else if (result != TCL_CONTINUE) {
- return (Var *) NULL;
+ return NULL;
}
}
/*
- * Look up part1. Look it up as either a namespace variable or as a
+ * Look up varName. Look it up as either a namespace variable or as a
* local variable in a procedure call frame (varFramePtr).
- * Interpret part1 as a namespace variable if:
+ * Interpret varName as a namespace variable if:
* 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
* 2) there is no active frame (we're at the global :: scope),
* 3) the active frame was pushed to define the namespace context
* for a "namespace eval" or "namespace inscope" command,
* 4) the name has namespace qualifiers ("::"s).
- * Otherwise, if part1 is a local variable, search first in the
+ * Otherwise, if varName is a local variable, search first in the
* frame's array of compiler-allocated local variables, then in its
* hashtable for runtime-created local variables.
*
- * If createPart1 and the variable isn't found, create the variable and,
+ * If create and the variable isn't found, create the variable and,
* if necessary, create varFramePtr's local var hashtable.
*/
if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
|| (varFramePtr == NULL)
|| !varFramePtr->isProcCallFrame
- || (strstr(part1, "::") != NULL)) {
- char *tail;
+ || (strstr(varName, "::") != NULL)) {
+ CONST char *tail;
+ int lookGlobal;
+ lookGlobal = (flags & TCL_GLOBAL_ONLY)
+ || (cxtNsPtr == iPtr->globalNsPtr)
+ || ((*varName == ':') && (*(varName+1) == ':'));
+ if (lookGlobal) {
+ *indexPtr = -1;
+ flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
+ } else if (flags & TCL_NAMESPACE_ONLY) {
+ *indexPtr = -2;
+ }
+
/*
* Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
* or otherwise generate our own error!
*/
- var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL,
+ var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
flags & ~TCL_LEAVE_ERR_MSG);
if (var != (Tcl_Var) NULL) {
varPtr = (Var *) var;
}
if (varPtr == NULL) {
- if (createPart1) { /* var wasn't found so create it */
- TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL,
+ if (create) { /* var wasn't found so create it */
+ TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
-
if (varNsPtr == NULL) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, badNamespace);
- }
- goto done;
+ *errMsgPtr = badNamespace;
+ return NULL;
}
if (tail == NULL) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, missingName);
- }
- goto done;
+ *errMsgPtr = missingName;
+ return NULL;
}
hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
varPtr->nsPtr = varNsPtr;
- } else { /* var wasn't found and not to create it */
- if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, noSuchVar);
+ if ((lookGlobal) || (varNsPtr == NULL)) {
+ /*
+ * The variable was created starting from the global
+ * namespace: a global reference is returned even if
+ * it wasn't explicitly requested.
+ */
+ *indexPtr = -1;
+ } else {
+ *indexPtr = -2;
}
- goto done;
+ } else { /* var wasn't found and not to create it */
+ *errMsgPtr = noSuchVar;
+ return NULL;
}
}
} else { /* local var: look in frame varFramePtr */
int localCt = procPtr->numCompiledLocals;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
Var *localVarPtr = varFramePtr->compiledLocals;
- int part1Len = strlen(part1);
+ int varNameLen = strlen(varName);
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
register char *localName = localVarPtr->name;
- if ((part1[0] == localName[0])
- && (part1Len == localPtr->nameLength)
- && (strcmp(part1, localName) == 0)) {
- varPtr = localVarPtr;
- break;
+ if ((varName[0] == localName[0])
+ && (varNameLen == localPtr->nameLength)
+ && (strcmp(varName, localName) == 0)) {
+ *indexPtr = i;
+ return localVarPtr;
}
}
localVarPtr++;
localPtr = localPtr->nextPtr;
}
- if (varPtr == NULL) { /* look in the frame's var hash table */
- tablePtr = varFramePtr->varTablePtr;
- if (createPart1) {
- if (tablePtr == NULL) {
- tablePtr = (Tcl_HashTable *)
- ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
- varFramePtr->varTablePtr = tablePtr;
- }
- hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new);
- if (new) {
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = NULL; /* a local variable */
- } else {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- }
- } else {
- hPtr = NULL;
- if (tablePtr != NULL) {
- hPtr = Tcl_FindHashEntry(tablePtr, part1);
- }
- if (hPtr == NULL) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, noSuchVar);
- }
- goto done;
- }
+ tablePtr = varFramePtr->varTablePtr;
+ if (create) {
+ if (tablePtr == NULL) {
+ tablePtr = (Tcl_HashTable *)
+ ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
+ varFramePtr->varTablePtr = tablePtr;
+ }
+ hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
+ if (new) {
+ varPtr = NewVar();
+ Tcl_SetHashValue(hPtr, varPtr);
+ varPtr->hPtr = hPtr;
+ varPtr->nsPtr = NULL; /* a local variable */
+ } else {
varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
+ } else {
+ hPtr = NULL;
+ if (tablePtr != NULL) {
+ hPtr = Tcl_FindHashEntry(tablePtr, varName);
+ }
+ if (hPtr == NULL) {
+ *errMsgPtr = noSuchVar;
+ return NULL;
+ }
+ varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
}
+ return varPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLookupArrayElement --
+ *
+ * This procedure is used to locate a variable which is in an array's
+ * hashtable given a pointer to the array's Var structure and the
+ * element's name.
+ *
+ * Results:
+ * The return value is a pointer to the variable structure , or NULL if
+ * the variable couldn't be found.
+ *
+ * If arrayPtr points to a variable that isn't an array and createPart1
+ * is 1, the corresponding variable will be converted to an array.
+ * Otherwise, NULL is returned and an error message is left in
+ * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
+ *
+ * If the variable is not found and createPart2 is 1, the variable is
+ * created. Otherwise, NULL is returned and an error message is left in
+ * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
+ *
+ * Note: it's possible for the variable returned to be VAR_UNDEFINED
+ * even if createPart1 or createPart2 are 1 (these only cause the hash
+ * table entry or array to be created). For example, the variable might
+ * be a global that has been unset but is still referenced by a
+ * procedure, or a variable that has been unset but it only being kept
+ * in existence (if VAR_UNDEFINED) by a trace.
+ *
+ * Side effects:
+ * The variable at arrayPtr may be converted to be an array if
+ * createPart1 is 1. A new hashtable entry may be created if createPart2
+ * is 1.
+ *
+ *----------------------------------------------------------------------
+ */
- lookupVarPart2:
- if (openParen != NULL) {
- *openParen = '(';
- openParen = NULL;
- }
-
- /*
- * If varPtr is a link variable, we have a reference to some variable
- * that was created through an "upvar" or "global" command. Traverse
- * through any links until we find the referenced variable.
- */
-
- while (TclIsVarLink(varPtr)) {
- varPtr = varPtr->value.linkPtr;
- }
-
- /*
- * If we're not dealing with an array element, return varPtr.
- */
-
- if (elName == NULL) {
- goto done;
- }
+Var *
+TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)
+ Tcl_Interp *interp; /* Interpreter to use for lookup. */
+ CONST char *arrayName; /* This is the name of the array. */
+ CONST char *elName; /* Name of element within array. */
+ CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */
+ CONST char *msg; /* Verb to use in error messages, e.g.
+ * "read" or "set". Only needed if
+ * TCL_LEAVE_ERR_MSG is set in flags. */
+ CONST int createArray; /* If 1, transform arrayName to be an array
+ * if it isn't one yet and the transformation
+ * is possible. If 0, return error if it
+ * isn't already an array. */
+ CONST int createElem; /* If 1, create hash table entry for the
+ * element, if it doesn't already exist. If
+ * 0, return error if it doesn't exist. */
+ Var *arrayPtr; /* Pointer to the array's Var structure. */
+{
+ Tcl_HashEntry *hPtr;
+ int new;
+ Var *varPtr;
/*
* We're dealing with an array element. Make sure the variable is an
* array and look up the element (create the element if desired).
*/
- if (TclIsVarUndefined(varPtr) && !TclIsVarArrayElement(varPtr)) {
- if (!createPart1) {
+ if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
+ if (!createArray) {
if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, noSuchVar);
+ VarErrMsg(interp, arrayName, elName, msg, noSuchVar);
}
- varPtr = NULL;
- goto done;
+ return NULL;
}
/*
* Make sure we are not resurrecting a namespace variable from a
* deleted namespace!
*/
- if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
+ if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, danglingVar);
+ VarErrMsg(interp, arrayName, elName, msg, danglingVar);
}
- varPtr = NULL;
- goto done;
+ return NULL;
}
- TclSetVarArray(varPtr);
- TclClearVarUndefined(varPtr);
- varPtr->value.tablePtr =
+ TclSetVarArray(arrayPtr);
+ TclClearVarUndefined(arrayPtr);
+ arrayPtr->value.tablePtr =
(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
- } else if (!TclIsVarArray(varPtr)) {
+ Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
+ } else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, needArray);
+ VarErrMsg(interp, arrayName, elName, msg, needArray);
}
- varPtr = NULL;
- goto done;
- }
- *arrayPtrPtr = varPtr;
- if (closeParen != NULL) {
- *closeParen = 0;
+ return NULL;
}
- if (createPart2) {
- hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new);
- if (closeParen != NULL) {
- *closeParen = ')';
- }
+
+ if (createElem) {
+ hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
if (new) {
- if (varPtr->searchPtr != NULL) {
- DeleteSearches(varPtr);
+ if (arrayPtr->searchPtr != NULL) {
+ DeleteSearches(arrayPtr);
}
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
- varPtr->nsPtr = varNsPtr;
+ varPtr->nsPtr = arrayPtr->nsPtr;
TclSetVarArrayElement(varPtr);
}
} else {
- hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName);
- if (closeParen != NULL) {
- *closeParen = ')';
- }
+ hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName);
if (hPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, msg, noSuchElement);
+ VarErrMsg(interp, arrayName, elName, msg, noSuchElement);
}
- varPtr = NULL;
- goto done;
+ return NULL;
}
}
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
-
- done:
- if (openParen != NULL) {
- *openParen = '(';
- }
- return varPtr;
+ return (Var *) Tcl_GetHashValue(hPtr);
}
\f
/*
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
- char *varName; /* Name of a variable in interp. */
+ CONST char *varName; /* Name of a variable in interp. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
- char *part1; /* Name of an array (if part2 is non-NULL)
+ CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
- char *part2; /* If non-NULL, gives the name of an element
+ CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
}
return TclGetString(objPtr);
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetVar2Ex --
+ *
+ * Return the value of a Tcl variable as a Tcl object, given a
+ * two-part name consisting of array name and element within array.
+ *
+ * Results:
+ * The return value points to the current object value of the variable
+ * given by part1Ptr and part2Ptr. If the specified variable doesn't
+ * exist, or if there is a clash in array usage, then NULL is returned
+ * and a message will be left in the interpreter's result if the
+ * TCL_LEAVE_ERR_MSG flag is set.
+ *
+ * Side effects:
+ * The ref count for the returned object is _not_ incremented to
+ * reflect the returned reference; if you want to keep a reference to
+ * the object you must increment its ref count yourself.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_GetVar2Ex(interp, part1, part2, flags)
+ Tcl_Interp *interp; /* Command interpreter in which variable is
+ * to be looked up. */
+ CONST char *part1; /* Name of an array (if part2 is non-NULL)
+ * or the name of a variable. */
+ CONST char *part2; /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
+ * and TCL_LEAVE_ERR_MSG bits. */
+{
+ Var *varPtr, *arrayPtr;
+
+ /*
+ * We need a special flag check to see if we want to create part 1,
+ * because commands like lappend require read traces to trigger for
+ * previously non-existent values.
+ */
+ varPtr = TclLookupVar(interp, part1, part2, flags, "read",
+ /*createPart1*/ (flags & TCL_TRACE_READS),
+ /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return NULL;
+ }
+
+ return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
+}
+\f
/*
*----------------------------------------------------------------------
*
register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
- int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
- * TCL_LEAVE_ERR_MSG, and
- * TCL_PARSE_PART1 bits. */
+ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and
+ * TCL_LEAVE_ERR_MSG bits. */
{
+ Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = Tcl_GetString(part1Ptr);
- if (part2Ptr != NULL) {
- part2 = Tcl_GetString(part2Ptr);
- } else {
- part2 = NULL;
- }
+ part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
- return Tcl_GetVar2Ex(interp, part1, part2, flags);
+ /*
+ * We need a special flag check to see if we want to create part 1,
+ * because commands like lappend require read traces to trigger for
+ * previously non-existent values.
+ */
+ varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
+ /*createPart1*/ (flags & TCL_TRACE_READS),
+ /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return NULL;
+ }
+
+ return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}
\f
/*
*----------------------------------------------------------------------
*
- * Tcl_GetVar2Ex --
+ * TclPtrGetVar --
*
- * Return the value of a Tcl variable as a Tcl object, given a
- * two-part name consisting of array name and element within array.
+ * Return the value of a Tcl variable as a Tcl object, given the
+ * pointers to the variable's (and possibly containing array's)
+ * VAR structure.
*
* Results:
* The return value points to the current object value of the variable
- * given by part1Ptr and part2Ptr. If the specified variable doesn't
- * exist, or if there is a clash in array usage, then NULL is returned
- * and a message will be left in the interpreter's result if the
- * TCL_LEAVE_ERR_MSG flag is set.
+ * given by varPtr. If the specified variable doesn't exist, or if there
+ * is a clash in array usage, then NULL is returned and a message will be
+ * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
*/
Tcl_Obj *
-Tcl_GetVar2Ex(interp, part1, part2, flags)
+TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
- char *part1; /* Name of an array (if part2 is non-NULL)
+ register Var *varPtr; /* The variable to be read.*/
+ Var *arrayPtr; /* NULL for scalar variables, pointer to
+ * the containing array otherwise. */
+ CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
- char *part2; /* If non-NULL, gives the name of an element
+ CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
- int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
+ CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Interp *iPtr = (Interp *) interp;
- register Var *varPtr;
- Var *arrayPtr;
- char *msg;
-
- varPtr = TclLookupVar(interp, part1, part2, flags, "read",
- /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
- if (varPtr == NULL) {
- return NULL;
- }
+ CONST char *msg;
/*
* Invoke any traces that have been set for the variable.
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
- msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
- (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS);
- if (msg != NULL) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, "read", msg);
- }
+ if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
+ (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
+ | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
goto errorReturn;
}
}
/*
*----------------------------------------------------------------------
*
- * TclGetIndexedScalar --
+ * Tcl_SetObjCmd --
*
- * Return the Tcl object value of a local scalar variable in the active
- * procedure, given its index in the procedure's array of compiler
- * allocated local variables.
+ * This procedure is invoked to process the "set" Tcl command.
+ * See the user documentation for details on what it does.
*
* Results:
- * The return value points to the current object value of the variable
- * given by localIndex. If the specified variable doesn't exist, or
- * there is a clash in array usage, or an error occurs while executing
- * variable traces, then NULL is returned and a message will be left in
- * the interpreter's result if leaveErrorMsg is 1.
+ * A standard Tcl result value.
*
* Side effects:
- * The ref count for the returned object is _not_ incremented to
- * reflect the returned reference; if you want to keep a reference to
- * the object you must increment its ref count yourself.
+ * A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
-Tcl_Obj *
-TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
- Tcl_Interp *interp; /* Command interpreter in which variable is
- * to be looked up. */
- register int localIndex; /* Index of variable in procedure's array
- * of local variables. */
- int leaveErrorMsg; /* 1 if to leave an error message in
- * interpreter's result on an error.
- * Otherwise no error message is left. */
+ /* ARGSUSED */
+int
+Tcl_SetObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ register Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Interp *iPtr = (Interp *) interp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- /* Points to the procedure call frame whose
- * variables are currently in use. Same as
- * the current procedure's frame, if any,
- * unless an "uplevel" is executing. */
- Var *compiledLocals = varFramePtr->compiledLocals;
- register Var *varPtr; /* Points to the variable's in-frame Var
- * structure. */
- char *varName; /* Name of the local variable. */
- char *msg;
-
-#ifdef TCL_COMPILE_DEBUG
- int localCt = varFramePtr->procPtr->numCompiledLocals;
-
- if (compiledLocals == NULL) {
- fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n",
- localIndex, (unsigned int) varFramePtr);
- panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",
- (unsigned int) varFramePtr);
- }
- if ((localIndex < 0) || (localIndex >= localCt)) {
- fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n",
- localIndex, (unsigned int) varFramePtr, localCt);
- panic("TclGetIndexedScalar: bad local index %i in frame 0x%x",
- localIndex, (unsigned int) varFramePtr);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
- varPtr = &(compiledLocals[localIndex]);
- varName = varPtr->name;
-
- /*
- * If varPtr is a link variable, we have a reference to some variable
- * that was created through an "upvar" or "global" command, or we have a
- * reference to a variable in an enclosing namespace. Traverse through
- * any links until we find the referenced variable.
- */
-
- while (TclIsVarLink(varPtr)) {
- varPtr = varPtr->value.linkPtr;
- }
-
- /*
- * Invoke any traces that have been set for the variable.
- */
+ Tcl_Obj *varValueObj;
- if (varPtr->tracePtr != NULL) {
- msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL,
- TCL_TRACE_READS);
- if (msg != NULL) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, varName, NULL, "read", msg);
- }
- return NULL;
+ if (objc == 2) {
+ varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (varValueObj == NULL) {
+ return TCL_ERROR;
}
- }
-
- /*
- * Make sure we're dealing with a scalar variable and not an array, and
- * that the variable exists (isn't undefined).
- */
-
- if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) {
- if (leaveErrorMsg) {
- if (TclIsVarArray(varPtr)) {
- msg = isArray;
- } else {
- msg = noSuchVar;
- }
- VarErrMsg(interp, varName, NULL, "read", msg);
+ Tcl_SetObjResult(interp, varValueObj);
+ return TCL_OK;
+ } else if (objc == 3) {
+ varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
+ TCL_LEAVE_ERR_MSG);
+ if (varValueObj == NULL) {
+ return TCL_ERROR;
}
- return NULL;
+ Tcl_SetObjResult(interp, varValueObj);
+ return TCL_OK;
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
+ return TCL_ERROR;
}
- return varPtr->value.objPtr;
}
\f
/*
*----------------------------------------------------------------------
*
- * TclGetElementOfIndexedArray --
+ * Tcl_SetVar --
*
- * Return the Tcl object value for an element in a local array
- * variable. The element is named by the object elemPtr while the
- * array is specified by its index in the active procedure's array
- * of compiler allocated local variables.
+ * Change the value of a variable.
*
* Results:
- * The return value points to the current object value of the
- * element. If the specified array or element doesn't exist, or there
- * is a clash in array usage, or an error occurs while executing
- * variable traces, then NULL is returned and a message will be left in
- * the interpreter's result if leaveErrorMsg is 1.
+ * Returns a pointer to the malloc'ed string which is the character
+ * representation of the variable's new value. The caller must not
+ * modify this string. If the write operation was disallowed then NULL
+ * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
+ * explanatory message will be left in the interp's result. Note that the
+ * returned string may not be the same as newValue; this is because
+ * variable traces may modify the variable's value.
*
* Side effects:
- * The ref count for the returned object is _not_ incremented to
- * reflect the returned reference; if you want to keep a reference to
- * the object you must increment its ref count yourself.
+ * If varName is defined as a local or global variable in interp,
+ * its value is changed to newValue. If varName isn't currently
+ * defined, then a new global variable by that name is created.
*
*----------------------------------------------------------------------
*/
-Tcl_Obj *
-TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
- Tcl_Interp *interp; /* Command interpreter in which variable is
+CONST char *
+Tcl_SetVar(interp, varName, newValue, flags)
+ Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
- int localIndex; /* Index of array variable in procedure's
- * array of local variables. */
- Tcl_Obj *elemPtr; /* Points to an object holding the name of
- * an element to get in the array. */
- int leaveErrorMsg; /* 1 if to leave an error message in
- * the interpreter's result on an error.
- * Otherwise no error message is left. */
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- /* Points to the procedure call frame whose
- * variables are currently in use. Same as
- * the current procedure's frame, if any,
- * unless an "uplevel" is executing. */
- Var *compiledLocals = varFramePtr->compiledLocals;
- Var *arrayPtr; /* Points to the array's in-frame Var
- * structure. */
- char *arrayName; /* Name of the local array. */
- Tcl_HashEntry *hPtr;
- Var *varPtr = NULL; /* Points to the element's Var structure
- * that we return. Initialized to avoid
- * compiler warning. */
- char *elem, *msg;
- int new;
-
-#ifdef TCL_COMPILE_DEBUG
- Proc *procPtr = varFramePtr->procPtr;
- int localCt = procPtr->numCompiledLocals;
-
- if (compiledLocals == NULL) {
- fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n",
- localIndex, (unsigned int) varFramePtr);
- panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",
- (unsigned int) varFramePtr);
- }
- if ((localIndex < 0) || (localIndex >= localCt)) {
- fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n",
- localIndex, (unsigned int) varFramePtr, localCt);
- panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x",
- localIndex, (unsigned int) varFramePtr);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
- elem = TclGetString(elemPtr);
- arrayPtr = &(compiledLocals[localIndex]);
- arrayName = arrayPtr->name;
-
- /*
- * If arrayPtr is a link variable, we have a reference to some variable
- * that was created through an "upvar" or "global" command, or we have a
- * reference to a variable in an enclosing namespace. Traverse through
- * any links until we find the referenced variable.
- */
-
- while (TclIsVarLink(arrayPtr)) {
- arrayPtr = arrayPtr->value.linkPtr;
- }
-
- /*
- * Make sure we're dealing with an array and that the array variable
- * exists (isn't undefined).
- */
-
- if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, arrayName, elem, "read", noSuchVar);
- }
- goto errorReturn;
- }
-
- /*
- * Look up the element. Note that we must create the element (but leave
- * it marked undefined) if it does not already exist. This allows a
- * trace to create new array elements "on the fly" that did not exist
- * before. A trace is always passed a variable for the array element. If
- * the trace does not define the variable, it will be deleted below (at
- * errorReturn) and an error returned.
- */
-
- hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
- if (new) {
- if (arrayPtr->searchPtr != NULL) {
- DeleteSearches(arrayPtr);
- }
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = varFramePtr->nsPtr;
- TclSetVarArrayElement(varPtr);
- } else {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- }
-
- /*
- * Invoke any traces that have been set for the element variable.
- */
-
- if ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
- msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
- TCL_TRACE_READS);
- if (msg != NULL) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, arrayName, elem, "read", msg);
- }
- goto errorReturn;
- }
- }
-
- /*
- * Return the element if it's an existing scalar variable.
- */
-
- if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
- return varPtr->value.objPtr;
- }
-
- if (leaveErrorMsg) {
- if (TclIsVarArray(varPtr)) {
- msg = isArray;
- } else {
- msg = noSuchVar;
- }
- VarErrMsg(interp, arrayName, elem, "read", msg);
- }
-
- /*
- * An error. If the variable doesn't exist anymore and no-one's using
- * it, then free up the relevant structures and hash table entries.
- */
-
- errorReturn:
- if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) {
- CleanupVar(varPtr, NULL); /* the array is not in a hashtable */
- }
- return NULL;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetObjCmd --
- *
- * This procedure is invoked to process the "set" Tcl command.
- * See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result value.
- *
- * Side effects:
- * A variable's value may be changed.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-int
-Tcl_SetObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- register Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Tcl_Obj *varValueObj;
-
- if (objc == 2) {
- varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
- if (varValueObj == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, varValueObj);
- return TCL_OK;
- } else if (objc == 3) {
-
- varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
- TCL_LEAVE_ERR_MSG);
- if (varValueObj == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, varValueObj);
- return TCL_OK;
- } else {
- Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
- return TCL_ERROR;
- }
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetVar --
- *
- * Change the value of a variable.
- *
- * Results:
- * Returns a pointer to the malloc'ed string which is the character
- * representation of the variable's new value. The caller must not
- * modify this string. If the write operation was disallowed then NULL
- * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
- * explanatory message will be left in the interp's result. Note that the
- * returned string may not be the same as newValue; this is because
- * variable traces may modify the variable's value.
- *
- * Side effects:
- * If varName is defined as a local or global variable in interp,
- * its value is changed to newValue. If varName isn't currently
- * defined, then a new global variable by that name is created.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-Tcl_SetVar(interp, varName, newValue, flags)
- Tcl_Interp *interp; /* Command interpreter in which varName is
- * to be looked up. */
- char *varName; /* Name of a variable in interp. */
- char *newValue; /* New value for varName. */
- int flags; /* Various flags that tell how to set value:
- * any of TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
- * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
+ CONST char *varName; /* Name of a variable in interp. */
+ CONST char *newValue; /* New value for varName. */
+ int flags; /* Various flags that tell how to set value:
+ * any of TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
+ * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
}
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
- char *part1; /* If part2 is NULL, this is name of scalar
+ CONST char *part1; /* If part2 is NULL, this is name of scalar
* variable. Otherwise it is the name of
* an array. */
- char *part2; /* Name of an element within an array, or
+ CONST char *part2; /* Name of an element within an array, or
* NULL. */
- char *newValue; /* New value for variable. */
+ CONST char *newValue; /* New value for variable. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
/*
*----------------------------------------------------------------------
*
+ * Tcl_SetVar2Ex --
+ *
+ * Given a two-part variable name, which may refer either to a scalar
+ * variable or an element of an array, change the value of the variable
+ * to a new Tcl object value. If the named scalar or array or element
+ * doesn't exist then create one.
+ *
+ * Results:
+ * Returns a pointer to the Tcl_Obj holding the new value of the
+ * variable. If the write operation was disallowed because an array was
+ * expected but not found (or vice versa), then NULL is returned; if
+ * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
+ * be left in the interpreter's result. Note that the returned object
+ * may not be the same one referenced by newValuePtr; this is because
+ * variable traces may modify the variable's value.
+ *
+ * Side effects:
+ * The value of the given variable is set. If either the array or the
+ * entry didn't exist then a new variable is created.
+ *
+ * The reference count is decremented for any old value of the variable
+ * and incremented for its new value. If the new value for the variable
+ * is not the same one referenced by newValuePtr (perhaps as a result
+ * of a variable trace), then newValuePtr's ref count is left unchanged
+ * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if
+ * we are appending it as a string value: that is, if "flags" includes
+ * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
+ *
+ * The reference count for the returned object is _not_ incremented: if
+ * you want to keep a reference to the object you must increment its
+ * ref count yourself.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
+ Tcl_Interp *interp; /* Command interpreter in which variable is
+ * to be found. */
+ CONST char *part1; /* Name of an array (if part2 is non-NULL)
+ * or the name of a variable. */
+ CONST char *part2; /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ Tcl_Obj *newValuePtr; /* New value for variable. */
+ int flags; /* Various flags that tell how to set value:
+ * any of TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
+ * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
+{
+ Var *varPtr, *arrayPtr;
+
+ varPtr = TclLookupVar(interp, part1, part2, flags, "set",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return NULL;
+ }
+
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
+ newValuePtr, flags);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ObjSetVar2 --
*
- * This function is the same as Tcl_SetVar2Ex below, except the
+ * This function is the same as Tcl_SetVar2Ex above, except the
* variable names are passed in Tcl object instead of strings.
*
* Results:
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
-
*
*----------------------------------------------------------------------
*/
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
- * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or
- * TCL_PARSE_PART1. */
+ * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
{
+ Var *varPtr, *arrayPtr;
char *part1, *part2;
- part1 = Tcl_GetString(part1Ptr);
- if (part2Ptr != NULL) {
- part2 = Tcl_GetString(part2Ptr);
- } else {
- part2 = NULL;
+ part1 = TclGetString(part1Ptr);
+ part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
+
+ varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return NULL;
}
-
- return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags);
+
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
+ newValuePtr, flags);
}
\f
+
/*
*----------------------------------------------------------------------
*
- * Tcl_SetVar2Ex --
+ * TclPtrSetVar --
*
- * Given a two-part variable name, which may refer either to a scalar
- * variable or an element of an array, change the value of the variable
- * to a new Tcl object value. If the named scalar or array or element
- * doesn't exist then create one.
+ * This function is the same as Tcl_SetVar2Ex above, except that
+ * it requires pointers to the variable's Var structs in addition
+ * to the variable names.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
- *
- * The reference count is decremented for any old value of the variable
- * and incremented for its new value. If the new value for the variable
- * is not the same one referenced by newValuePtr (perhaps as a result
- * of a variable trace), then newValuePtr's ref count is left unchanged
- * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if
- * we are appending it as a string value: that is, if "flags" includes
- * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
- *
- * The reference count for the returned object is _not_ incremented: if
- * you want to keep a reference to the object you must increment its
- * ref count yourself.
+
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
-Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
+TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
- * to be found. */
- char *part1; /* Name of an array (if part2 is non-NULL)
+ * to be looked up. */
+ register Var *varPtr;
+ Var *arrayPtr;
+ CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
- char *part2; /* If non-NULL, gives the name of an element
+ CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr; /* New value for variable. */
- int flags; /* Various flags that tell how to set value:
- * any of TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
- * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
+ CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
+ * and TCL_LEAVE_ERR_MSG bits. */
{
Interp *iPtr = (Interp *) interp;
- register Var *varPtr;
- Var *arrayPtr;
Tcl_Obj *oldValuePtr;
Tcl_Obj *resultPtr = NULL;
- char *bytes;
- int length, result;
-
- varPtr = TclLookupVar(interp, part1, part2, flags, "set",
- /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
- if (varPtr == NULL) {
- return NULL;
- }
+ int result;
/*
* If the variable is in a hashtable and its hPtr field is NULL, then we
}
/*
- * At this point, if we were appending, we used to call read traces: we
- * treated append as a read-modify-write. However, it seemed unlikely to
- * us that a real program would be interested in such reads being done
- * during a set operation.
+ * Invoke any read traces that have been set for the variable if it
+ * is requested; this is only done in the core when lappending.
*/
+ if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
+ || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
+ if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
+ TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
+ return NULL;
+ }
+ }
+
/*
* Set the variable's new value. If appending, append the new value to
* the variable, either as a list element or as a string. Also, if
* We append newValuePtr's bytes but don't change its ref count.
*/
- bytes = Tcl_GetStringFromObj(newValuePtr, &length);
if (oldValuePtr == NULL) {
- varPtr->value.objPtr = Tcl_NewStringObj(bytes, length);
- Tcl_IncrRefCount(varPtr->value.objPtr);
+ varPtr->value.objPtr = newValuePtr;
+ Tcl_IncrRefCount(newValuePtr);
} else {
if (Tcl_IsShared(oldValuePtr)) { /* append to copy */
varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
}
}
- } else {
- if (flags & TCL_LIST_ELEMENT) { /* set var to list element */
- int neededBytes, listFlags;
+ } else if (newValuePtr != oldValuePtr) {
+ /*
+ * In this case we are replacing the value, so we don't need to
+ * do more than swap the objects.
+ */
- /*
- * We set the variable to the result of converting newValuePtr's
- * string rep to a list element. We do not change newValuePtr's
- * ref count.
- */
-
- if (oldValuePtr != NULL) {
- Tcl_DecrRefCount(oldValuePtr); /* discard old value */
- }
- bytes = Tcl_GetStringFromObj(newValuePtr, &length);
- neededBytes = Tcl_ScanElement(bytes, &listFlags);
- oldValuePtr = Tcl_NewObj();
- oldValuePtr->bytes = (char *)
- ckalloc((unsigned) (neededBytes + 1));
- oldValuePtr->length = Tcl_ConvertElement(bytes,
- oldValuePtr->bytes, listFlags);
- varPtr->value.objPtr = oldValuePtr;
- Tcl_IncrRefCount(varPtr->value.objPtr);
- } else if (newValuePtr != oldValuePtr) {
- varPtr->value.objPtr = newValuePtr;
- Tcl_IncrRefCount(newValuePtr); /* var is another ref */
- if (oldValuePtr != NULL) {
- TclDecrRefCount(oldValuePtr); /* discard old value */
- }
+ varPtr->value.objPtr = newValuePtr;
+ Tcl_IncrRefCount(newValuePtr); /* var is another ref */
+ if (oldValuePtr != NULL) {
+ TclDecrRefCount(oldValuePtr); /* discard old value */
}
}
TclSetVarScalar(varPtr);
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
- char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES);
- if (msg != NULL) {
- if (flags & TCL_LEAVE_ERR_MSG) {
- VarErrMsg(interp, part1, part2, "set", msg);
- }
+ if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
+ | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
goto cleanup;
}
}
/*
*----------------------------------------------------------------------
*
- * TclSetIndexedScalar --
- *
- * Change the Tcl object value of a local scalar variable in the active
- * procedure, given its compile-time allocated index in the procedure's
- * array of local variables.
- *
- * Results:
- * Returns a pointer to the Tcl_Obj holding the new value of the
- * variable given by localIndex. If the specified variable doesn't
- * exist, or there is a clash in array usage, or an error occurs while
- * executing variable traces, then NULL is returned and a message will
- * be left in the interpreter's result if leaveErrorMsg is 1. Note
- * that the returned object may not be the same one referenced by
- * newValuePtr; this is because variable traces may modify the
- * variable's value.
- *
- * Side effects:
- * The value of the given variable is set. The reference count is
- * decremented for any old value of the variable and incremented for
- * its new value. If as a result of a variable trace the new value for
- * the variable is not the same one referenced by newValuePtr, then
- * newValuePtr's ref count is left unchanged. The ref count for the
- * returned object is _not_ incremented to reflect the returned
- * reference; if you want to keep a reference to the object you must
- * increment its ref count yourself. This procedure does not create
- * new variables, but only sets those recognized at compile time.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
- Tcl_Interp *interp; /* Command interpreter in which variable is
- * to be found. */
- int localIndex; /* Index of variable in procedure's array
- * of local variables. */
- Tcl_Obj *newValuePtr; /* New value for variable. */
- int leaveErrorMsg; /* 1 if to leave an error message in
- * the interpreter's result on an error.
- * Otherwise no error message is left. */
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- /* Points to the procedure call frame whose
- * variables are currently in use. Same as
- * the current procedure's frame, if any,
- * unless an "uplevel" is executing. */
- Var *compiledLocals = varFramePtr->compiledLocals;
- register Var *varPtr; /* Points to the variable's in-frame Var
- * structure. */
- char *varName; /* Name of the local variable. */
- Tcl_Obj *oldValuePtr;
- Tcl_Obj *resultPtr = NULL;
-
-#ifdef TCL_COMPILE_DEBUG
- Proc *procPtr = varFramePtr->procPtr;
- int localCt = procPtr->numCompiledLocals;
-
- if (compiledLocals == NULL) {
- fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n",
- localIndex, (unsigned int) varFramePtr);
- panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",
- (unsigned int) varFramePtr);
- }
- if ((localIndex < 0) || (localIndex >= localCt)) {
- fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n",
- localIndex, (unsigned int) varFramePtr, localCt);
- panic("TclSetIndexedScalar: bad local index %i in frame 0x%x",
- localIndex, (unsigned int) varFramePtr);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
- varPtr = &(compiledLocals[localIndex]);
- varName = varPtr->name;
-
- /*
- * If varPtr is a link variable, we have a reference to some variable
- * that was created through an "upvar" or "global" command, or we have a
- * reference to a variable in an enclosing namespace. Traverse through
- * any links until we find the referenced variable.
- */
-
- while (TclIsVarLink(varPtr)) {
- varPtr = varPtr->value.linkPtr;
- }
-
- /*
- * If the variable is in a hashtable and its hPtr field is NULL, then we
- * may have an upvar to an array element where the array was deleted
- * or an upvar to a namespace variable whose namespace was deleted.
- * Generate an error (allowing the variable to be reset would screw up
- * our storage allocation and is meaningless anyway).
- */
-
- if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
- if (leaveErrorMsg) {
- if (TclIsVarArrayElement(varPtr)) {
- VarErrMsg(interp, varName, NULL, "set", danglingElement);
- } else {
- VarErrMsg(interp, varName, NULL, "set", danglingVar);
- }
- }
- return NULL;
- }
-
- /*
- * It's an error to try to set an array variable itself.
- */
-
- if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, varName, NULL, "set", isArray);
- }
- return NULL;
- }
-
- /*
- * Set the variable's new value and discard its old value. We don't
- * append with this "set" procedure so the old value isn't needed.
- */
-
- oldValuePtr = varPtr->value.objPtr;
- if (newValuePtr != oldValuePtr) { /* set new value */
- varPtr->value.objPtr = newValuePtr;
- Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */
- if (oldValuePtr != NULL) {
- TclDecrRefCount(oldValuePtr); /* discard old value */
- }
- }
- TclSetVarScalar(varPtr);
- TclClearVarUndefined(varPtr);
-
- /*
- * Invoke any write traces for the variable.
- */
-
- if (varPtr->tracePtr != NULL) {
- char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr,
- varName, (char *) NULL, TCL_TRACE_WRITES);
- if (msg != NULL) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, varName, NULL, "set", msg);
- }
- goto cleanup;
- }
- }
-
- /*
- * Return the variable's value unless the variable was changed in some
- * gross way by a trace (e.g. it was unset and then recreated as an
- * array). If it was changed is a gross way, just return an empty string
- * object.
- */
-
- if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
- return varPtr->value.objPtr;
- }
-
- resultPtr = Tcl_NewObj();
-
- /*
- * If the variable doesn't exist anymore and no-one's using it, then
- * free up the relevant structures and hash table entries.
- */
-
- cleanup:
- if (TclIsVarUndefined(varPtr)) {
- CleanupVar(varPtr, NULL);
- }
- return resultPtr;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclSetElementOfIndexedArray --
- *
- * Change the Tcl object value of an element in a local array
- * variable. The element is named by the object elemPtr while the array
- * is specified by its index in the active procedure's array of
- * compiler allocated local variables.
- *
- * Results:
- * Returns a pointer to the Tcl_Obj holding the new value of the
- * element. If the specified array or element doesn't exist, or there
- * is a clash in array usage, or an error occurs while executing
- * variable traces, then NULL is returned and a message will be left in
- * the interpreter's result if leaveErrorMsg is 1. Note that the
- * returned object may not be the same one referenced by newValuePtr;
- * this is because variable traces may modify the variable's value.
- *
- * Side effects:
- * The value of the given array element is set. The reference count is
- * decremented for any old value of the element and incremented for its
- * new value. If as a result of a variable trace the new value for the
- * element is not the same one referenced by newValuePtr, then
- * newValuePtr's ref count is left unchanged. The ref count for the
- * returned object is _not_ incremented to reflect the returned
- * reference; if you want to keep a reference to the object you must
- * increment its ref count yourself. This procedure will not create new
- * array variables, but only sets elements of those arrays recognized
- * at compile time. However, if the entry doesn't exist then a new
- * variable is created.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
- leaveErrorMsg)
- Tcl_Interp *interp; /* Command interpreter in which the array is
- * to be found. */
- int localIndex; /* Index of array variable in procedure's
- * array of local variables. */
- Tcl_Obj *elemPtr; /* Points to an object holding the name of
- * an element to set in the array. */
- Tcl_Obj *newValuePtr; /* New value for variable. */
- int leaveErrorMsg; /* 1 if to leave an error message in
- * the interpreter's result on an error.
- * Otherwise no error message is left. */
-{
- Interp *iPtr = (Interp *) interp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- /* Points to the procedure call frame whose
- * variables are currently in use. Same as
- * the current procedure's frame, if any,
- * unless an "uplevel" is executing. */
- Var *compiledLocals = varFramePtr->compiledLocals;
- Var *arrayPtr; /* Points to the array's in-frame Var
- * structure. */
- char *arrayName; /* Name of the local array. */
- char *elem;
- Tcl_HashEntry *hPtr;
- Var *varPtr = NULL; /* Points to the element's Var structure
- * that we return. */
- Tcl_Obj *resultPtr = NULL;
- Tcl_Obj *oldValuePtr;
- int new;
-
-#ifdef TCL_COMPILE_DEBUG
- Proc *procPtr = varFramePtr->procPtr;
- int localCt = procPtr->numCompiledLocals;
-
- if (compiledLocals == NULL) {
- fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n",
- localIndex, (unsigned int) varFramePtr);
- panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",
- (unsigned int) varFramePtr);
- }
- if ((localIndex < 0) || (localIndex >= localCt)) {
- fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n",
- localIndex, (unsigned int) varFramePtr, localCt);
- panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x",
- localIndex, (unsigned int) varFramePtr);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
- elem = TclGetString(elemPtr);
- arrayPtr = &(compiledLocals[localIndex]);
- arrayName = arrayPtr->name;
-
- /*
- * If arrayPtr is a link variable, we have a reference to some variable
- * that was created through an "upvar" or "global" command, or we have a
- * reference to a variable in an enclosing namespace. Traverse through
- * any links until we find the referenced variable.
- */
-
- while (TclIsVarLink(arrayPtr)) {
- arrayPtr = arrayPtr->value.linkPtr;
- }
-
- /*
- * If the variable is in a hashtable and its hPtr field is NULL, then we
- * may have an upvar to an array element where the array was deleted
- * or an upvar to a namespace variable whose namespace was deleted.
- * Generate an error (allowing the variable to be reset would screw up
- * our storage allocation and is meaningless anyway).
- */
-
- if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
- if (leaveErrorMsg) {
- if (TclIsVarArrayElement(arrayPtr)) {
- VarErrMsg(interp, arrayName, elem, "set", danglingElement);
- } else {
- VarErrMsg(interp, arrayName, elem, "set", danglingVar);
- }
- }
- goto errorReturn;
- }
-
- /*
- * Make sure we're dealing with an array.
- */
-
- if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
- TclSetVarArray(arrayPtr);
- arrayPtr->value.tablePtr =
- (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
- TclClearVarUndefined(arrayPtr);
- } else if (!TclIsVarArray(arrayPtr)) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, arrayName, elem, "set", needArray);
- }
- goto errorReturn;
- }
-
- /*
- * Look up the element.
- */
-
- hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
- if (new) {
- if (arrayPtr->searchPtr != NULL) {
- DeleteSearches(arrayPtr);
- }
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = varFramePtr->nsPtr;
- TclSetVarArrayElement(varPtr);
- }
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
-
- /*
- * It's an error to try to set an array variable itself.
- */
-
- if (TclIsVarArray(varPtr)) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, arrayName, elem, "set", isArray);
- }
- goto errorReturn;
- }
-
- /*
- * Set the variable's new value and discard the old one. We don't
- * append with this "set" procedure so the old value isn't needed.
- */
-
- oldValuePtr = varPtr->value.objPtr;
- if (newValuePtr != oldValuePtr) { /* set new value */
- varPtr->value.objPtr = newValuePtr;
- Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */
- if (oldValuePtr != NULL) {
- TclDecrRefCount(oldValuePtr); /* discard old value */
- }
- }
- TclSetVarScalar(varPtr);
- TclClearVarUndefined(varPtr);
-
- /*
- * Invoke any write traces for the element variable.
- */
-
- if ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
- char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
- TCL_TRACE_WRITES);
- if (msg != NULL) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, arrayName, elem, "set", msg);
- }
- goto errorReturn;
- }
- }
-
- /*
- * Return the element's value unless it was changed in some gross way by
- * a trace (e.g. it was unset and then recreated as an array). If it was
- * changed is a gross way, just return an empty string object.
- */
-
- if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
- return varPtr->value.objPtr;
- }
-
- resultPtr = Tcl_NewObj();
-
- /*
- * An error. If the variable doesn't exist anymore and no-one's using
- * it, then free up the relevant structures and hash table entries.
- */
-
- errorReturn:
- if (varPtr != NULL) {
- if (TclIsVarUndefined(varPtr)) {
- CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */
- }
- }
- return resultPtr;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
* TclIncrVar2 --
*
* Given a two-part variable name, which may refer either to a scalar
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
- register Tcl_Obj *varValuePtr;
- Tcl_Obj *resultPtr;
- int createdNewObj; /* Set 1 if var's value object is shared
- * so we must increment a copy (i.e. copy
- * on write). */
- long i;
- int result;
+ Var *varPtr, *arrayPtr;
+ char *part1, *part2;
- varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
- if (varValuePtr == NULL) {
+ part1 = TclGetString(part1Ptr);
+ part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));
+
+ varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
+ 0, 1, &arrayPtr);
+ if (varPtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
return NULL;
}
-
- /*
- * Increment the variable's value. If the object is unshared we can
- * modify it directly, otherwise we must create a new copy to modify:
- * this is "copy on write". Then free the variable's old string
- * representation, if any, since it will no longer be valid.
- */
-
- createdNewObj = 0;
- if (Tcl_IsShared(varValuePtr)) {
- varValuePtr = Tcl_DuplicateObj(varValuePtr);
- createdNewObj = 1;
- }
- result = Tcl_GetLongFromObj(interp, varValuePtr, &i);
- if (result != TCL_OK) {
- if (createdNewObj) {
- Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
- }
- return NULL;
- }
- Tcl_SetLongObj(varValuePtr, (i + incrAmount));
-
- /*
- * Store the variable's new value and run any write traces.
- */
-
- resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags);
- if (resultPtr == NULL) {
- return NULL;
- }
- return resultPtr;
+ return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2,
+ incrAmount, flags);
}
\f
/*
*----------------------------------------------------------------------
*
- * TclIncrIndexedScalar --
+ * TclPtrIncrVar --
*
- * Increments the Tcl object value of a local scalar variable in the
- * active procedure, given its compile-time allocated index in the
- * procedure's array of local variables.
+ * Given the pointers to a variable and possible containing array,
+ * increment the Tcl object value of the variable by a specified
+ * amount.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
- * variable given by localIndex. If the specified variable doesn't
- * exist, or there is a clash in array usage, or an error occurs while
- * executing variable traces, then NULL is returned and a message will
- * be left in the interpreter's result.
+ * variable. If the specified variable doesn't exist, or there is a
+ * clash in array usage, or an error occurs while executing variable
+ * traces, then NULL is returned and a message will be left in
+ * the interpreter's result.
*
* Side effects:
* The value of the given variable is incremented by the specified
- * amount. The ref count for the returned object is _not_ incremented
- * to reflect the returned reference; if you want to keep a reference
- * to the object you must increment its ref count yourself.
+ * amount. If either the array or the entry didn't exist then a new
+ * variable is created. The ref count for the returned object is _not_
+ * incremented to reflect the returned reference; if you want to keep a
+ * reference to the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
-TclIncrIndexedScalar(interp, localIndex, incrAmount)
+TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
- int localIndex; /* Index of variable in procedure's array
- * of local variables. */
- long incrAmount; /* Amount to be added to variable. */
+ Var *varPtr;
+ Var *arrayPtr;
+ CONST char *part1; /* Points to an object holding the name of
+ * an array (if part2 is non-NULL) or the
+ * name of a variable. */
+ CONST char *part2; /* If non-null, points to an object holding
+ * the name of an element in the array
+ * part1Ptr. */
+ CONST long incrAmount; /* Amount to be added to variable. */
+ CONST int flags; /* Various flags that tell how to incr value:
+ * any of TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
+ * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
register Tcl_Obj *varValuePtr;
- Tcl_Obj *resultPtr;
int createdNewObj; /* Set 1 if var's value object is shared
* so we must increment a copy (i.e. copy
* on write). */
long i;
- int result;
- varValuePtr = TclGetIndexedScalar(interp, localIndex,
- /*leaveErrorMsg*/ 1);
+ varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
+
if (varValuePtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
}
/*
- * Reach into the object's representation to extract and increment the
- * variable's value. If the object is unshared we can modify it
- * directly, otherwise we must create a new copy to modify: this is
- * "copy on write". Then free the variable's old string representation,
- * if any, since it will no longer be valid.
+ * Increment the variable's value. If the object is unshared we can
+ * modify it directly, otherwise we must create a new copy to modify:
+ * this is "copy on write". Then free the variable's old string
+ * representation, if any, since it will no longer be valid.
*/
createdNewObj = 0;
if (Tcl_IsShared(varValuePtr)) {
- createdNewObj = 1;
varValuePtr = Tcl_DuplicateObj(varValuePtr);
+ createdNewObj = 1;
}
- result = Tcl_GetLongFromObj(interp, varValuePtr, &i);
- if (result != TCL_OK) {
+#ifdef TCL_WIDE_INT_IS_LONG
+ if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) {
if (createdNewObj) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
}
return NULL;
}
Tcl_SetLongObj(varValuePtr, (i + incrAmount));
-
- /*
- * Store the variable's new value and run any write traces.
- */
-
- resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr,
- /*leaveErrorMsg*/ 1);
- if (resultPtr == NULL) {
- return NULL;
- }
- return resultPtr;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclIncrElementOfIndexedArray --
- *
- * Increments the Tcl object value of an element in a local array
- * variable. The element is named by the object elemPtr while the array
- * is specified by its index in the active procedure's array of
- * compiler allocated local variables.
- *
- * Results:
- * Returns a pointer to the Tcl_Obj holding the new value of the
- * element. If the specified array or element doesn't exist, or there
- * is a clash in array usage, or an error occurs while executing
- * variable traces, then NULL is returned and a message will be left in
- * the interpreter's result.
- *
- * Side effects:
- * The value of the given array element is incremented by the specified
- * amount. The ref count for the returned object is _not_ incremented
- * to reflect the returned reference; if you want to keep a reference
- * to the object you must increment its ref count yourself. If the
- * entry doesn't exist then a new variable is created.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
- Tcl_Interp *interp; /* Command interpreter in which the array is
- * to be found. */
- int localIndex; /* Index of array variable in procedure's
- * array of local variables. */
- Tcl_Obj *elemPtr; /* Points to an object holding the name of
- * an element to increment in the array. */
- long incrAmount; /* Amount to be added to variable. */
-{
- register Tcl_Obj *varValuePtr;
- Tcl_Obj *resultPtr;
- int createdNewObj; /* Set 1 if var's value object is shared
- * so we must increment a copy (i.e. copy
- * on write). */
- long i;
- int result;
-
- varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr,
- /*leaveErrorMsg*/ 1);
- if (varValuePtr == NULL) {
- Tcl_AddObjErrorInfo(interp,
- "\n (reading value of variable to increment)", -1);
- return NULL;
- }
-
- /*
- * Reach into the object's representation to extract and increment the
- * variable's value. If the object is unshared we can modify it
- * directly, otherwise we must create a new copy to modify: this is
- * "copy on write". Then free the variable's old string representation,
- * if any, since it will no longer be valid.
- */
-
- createdNewObj = 0;
- if (Tcl_IsShared(varValuePtr)) {
- createdNewObj = 1;
- varValuePtr = Tcl_DuplicateObj(varValuePtr);
- }
- result = Tcl_GetLongFromObj(interp, varValuePtr, &i);
- if (result != TCL_OK) {
- if (createdNewObj) {
- Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
+#else
+ if (varValuePtr->typePtr == &tclWideIntType) {
+ Tcl_WideInt wide = varValuePtr->internalRep.wideValue;
+ Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
+ } else if (varValuePtr->typePtr == &tclIntType) {
+ i = varValuePtr->internalRep.longValue;
+ Tcl_SetIntObj(varValuePtr, i + incrAmount);
+ } else {
+ /*
+ * Not an integer or wide internal-rep...
+ */
+ Tcl_WideInt wide;
+ if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) {
+ if (createdNewObj) {
+ Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
+ }
+ return NULL;
+ }
+ if (wide <= Tcl_LongAsWide(LONG_MAX)
+ && wide >= Tcl_LongAsWide(LONG_MIN)) {
+ Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
+ } else {
+ Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
}
- return NULL;
}
- Tcl_SetLongObj(varValuePtr, (i + incrAmount));
-
+#endif
+
/*
* Store the variable's new value and run any write traces.
*/
- resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr,
- varValuePtr,
- /*leaveErrorMsg*/ 1);
- if (resultPtr == NULL) {
- return NULL;
- }
- return resultPtr;
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
+ varValuePtr, flags);
}
\f
/*
Tcl_UnsetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
- char *varName; /* Name of a variable in interp. May be
+ CONST char *varName; /* Name of a variable in interp. May be
* either a scalar name or an array name
* or an element in an array. */
int flags; /* OR-ed combination of any of
Tcl_UnsetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
- char *part1; /* Name of variable or array. */
- char *part2; /* Name of element within array or NULL. */
+ CONST char *part1; /* Name of variable or array. */
+ CONST char *part2; /* Name of element within array or NULL. */
+ int flags; /* OR-ed combination of any of
+ * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * TCL_LEAVE_ERR_MSG. */
+{
+ int result;
+ Tcl_Obj *part1Ptr;
+
+ part1Ptr = Tcl_NewStringObj(part1, -1);
+ Tcl_IncrRefCount(part1Ptr);
+ result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
+ TclDecrRefCount(part1Ptr);
+
+ return result;
+}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjUnsetVar2 --
+ *
+ * Delete a variable, given a 2-object name.
+ *
+ * Results:
+ * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
+ * if the variable can't be unset. In the event of an error,
+ * if the TCL_LEAVE_ERR_MSG flag is set then an error message
+ * is left in the interp's result.
+ *
+ * Side effects:
+ * If part1ptr and part2Ptr indicate a local or global variable in interp,
+ * it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then
+ * the whole array is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjUnsetVar2(interp, part1Ptr, part2, flags)
+ Tcl_Interp *interp; /* Command interpreter in which varName is
+ * to be looked up. */
+ Tcl_Obj *part1Ptr; /* Name of variable or array. */
+ CONST char *part2; /* Name of element within array or NULL. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
int result;
+ char *part1;
- varPtr = TclLookupVar(interp, part1, part2, flags, "unset",
+ part1 = TclGetString(part1Ptr);
+ varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
+
result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
* Call trace procedures for the variable being deleted. Then delete
* its traces. Be sure to abort any other traces for the variable
* that are still pending. Special tricks:
- * 1. We need to increment varPtr's refCount around this: CallTraces
+ * 1. We need to increment varPtr's refCount around this: CallVarTraces
* will use dummyVar so it won't increment varPtr's refCount itself.
* 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
* call unset traces even if other traces are pending.
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
varPtr->refCount++;
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
- (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
+ CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
+ | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
while (dummyVar.tracePtr != NULL) {
VarTrace *tracePtr = dummyVar.tracePtr;
dummyVar.tracePtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
+ Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
- for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
+ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
*/
varPtr->refCount++;
DeleteArray(iPtr, part1, dummyVarPtr,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
+ | TCL_TRACE_UNSETS);
/* Decr ref count */
varPtr->refCount--;
}
Tcl_TraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
- char *varName; /* Name of variable; may end with "(index)"
+ CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
- char *part1; /* Name of scalar variable or array. */
- char *part2; /* Name of element within array; NULL means
+ CONST char *part1; /* Name of scalar variable or array. */
+ CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits, including any
{
Var *varPtr, *arrayPtr;
register VarTrace *tracePtr;
-
- varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG),
+ int flagMask;
+
+ /*
+ * We strip 'flags' down to just the parts which are relevant to
+ * TclLookupVar, to avoid conflicts between trace flags and
+ * internal namespace flags such as 'FIND_ONLY_NS'. This can
+ * now occur since we have trace flags with values 0x1000 and higher.
+ */
+ flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
+ varPtr = TclLookupVar(interp, part1, part2,
+ (flags & flagMask) | TCL_LEAVE_ERR_MSG,
"trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
/*
+ * Check for a nonsense flag combination. Note that this is a
+ * panic() because there should be no code path that ever sets
+ * both flags.
+ */
+ if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) {
+ panic("bad result flag combination");
+ }
+
+ /*
* Set up trace information.
*/
+ flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+ TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ flagMask |= TCL_TRACE_OLD_STYLE;
+#endif
tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
- tracePtr->traceProc = proc;
- tracePtr->clientData = clientData;
- tracePtr->flags =
- flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
- TCL_TRACE_ARRAY);
- tracePtr->nextPtr = varPtr->tracePtr;
- varPtr->tracePtr = tracePtr;
+ tracePtr->traceProc = proc;
+ tracePtr->clientData = clientData;
+ tracePtr->flags = flags & flagMask;
+ tracePtr->nextPtr = varPtr->tracePtr;
+ varPtr->tracePtr = tracePtr;
return TCL_OK;
}
\f
void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
- char *varName; /* Name of variable; may end with "(index)"
+ CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits describing
* current trace, including any of
void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
- char *part1; /* Name of variable or array. */
- char *part2; /* Name of element within array; NULL means
+ CONST char *part1; /* Name of variable or array. */
+ CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits describing
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
ActiveVarTrace *activePtr;
-
- varPtr = TclLookupVar(interp, part1, part2,
- flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
+ int flagMask;
+
+ /*
+ * Set up a mask to mask out the parts of the flags that we are not
+ * interested in now.
+ */
+ flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
+ varPtr = TclLookupVar(interp, part1, part2, flags & flagMask,
/*msg*/ (char *) NULL,
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return;
}
- flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
- TCL_TRACE_ARRAY);
+
+ /*
+ * Set up a mask to mask out the parts of the flags that we are not
+ * interested in now.
+ */
+ flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+ TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+ flagMask |= TCL_TRACE_OLD_STYLE;
+#endif
+ flags &= flagMask;
for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
/*
* The code below makes it possible to delete traces while traces
* are active: it makes sure that the deleted trace won't be
- * processed by CallTraces.
+ * processed by CallVarTraces.
*/
- for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
+ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
activePtr->nextTracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
- ckfree((char *) tracePtr);
+ Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
/*
* If this is the last trace on the variable, and the variable is
ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
- char *varName; /* Name of variable; may end with "(index)"
+ CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY (can be 0). */
ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
- char *part1; /* Name of variable or array. */
- char *part2; /* Name of element within array; NULL means
+ CONST char *part1; /* Name of variable or array. */
+ CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- register int i;
+ register int i, flags = TCL_LEAVE_ERR_MSG;
register char *name;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
+ if (objc < 1) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-nocomplain? ?--? ?varName varName ...?");
return TCL_ERROR;
+ } else if (objc == 1) {
+ /*
+ * Do nothing if no arguments supplied, so as to match
+ * command documentation.
+ */
+ return TCL_OK;
}
-
- for (i = 1; i < objc; i++) {
- name = TclGetString(objv[i]);
- if (Tcl_UnsetVar2(interp, name, (char *) NULL,
- TCL_LEAVE_ERR_MSG) != TCL_OK) {
+
+ /*
+ * Simple, restrictive argument parsing. The only options are --
+ * and -nocomplain (which must come first and be given exactly to
+ * be an option).
+ */
+ i = 1;
+ name = TclGetString(objv[i]);
+ if (name[0] == '-') {
+ if (strcmp("-nocomplain", name) == 0) {
+ i++;
+ if (i == objc) {
+ return TCL_OK;
+ }
+ flags = 0;
+ name = TclGetString(objv[i]);
+ }
+ if (strcmp("--", name) == 0) {
+ i++;
+ }
+ }
+
+ for (; i < objc; i++) {
+ if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK)
+ && (flags == TCL_LEAVE_ERR_MSG)) {
return TCL_ERROR;
}
}
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ Var *varPtr, *arrayPtr;
+ char *part1;
+
register Tcl_Obj *varValuePtr = NULL;
/* Initialized to avoid compiler
* warning. */
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
+
if (objc == 2) {
varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
} else {
- for (i = 2; i < objc; i++) {
- varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
+ varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
+ "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ part1 = TclGetString(objv[1]);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+ for (i = 2; i < objc; i++) {
+ /*
+ * Note that we do not need to increase the refCount of
+ * the Var pointers: should a trace delete the variable,
+ * the return value of TclPtrSetVar will be NULL, and we
+ * will not access the variable again.
+ */
+
+ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
+ objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
if (varValuePtr == NULL) {
return TCL_ERROR;
}
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
int numElems, numRequired, createdNewObj, createVar, i, j;
+ Var *varPtr, *arrayPtr;
+ char *part1;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
if (objc == 2) {
- newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- (TCL_LEAVE_ERR_MSG));
+ newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);
if (newValuePtr == NULL) {
/*
* The variable doesn't exist yet. Just create it with an empty
* initial value.
*/
- Tcl_Obj *nullObjPtr = Tcl_NewObj();
- newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
- nullObjPtr, TCL_LEAVE_ERR_MSG);
+ varValuePtr = Tcl_NewObj();
+ newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
+ TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
- Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */
+ Tcl_DecrRefCount(varValuePtr); /* free unneeded object */
return TCL_ERROR;
}
}
createdNewObj = 0;
createVar = 1;
- varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
+
+ /*
+ * Use the TCL_TRACE_READS flag to ensure that if we have an
+ * array with no elements set yet, but with a read trace on it,
+ * we will create the variable and get read traces triggered.
+ * Note that you have to protect the variable pointers around
+ * the TclPtrGetVar call to insure that they remain valid
+ * even if the variable was undefined and unused.
+ */
+
+ varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
+ "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varPtr->refCount++;
+ if (arrayPtr != NULL) {
+ arrayPtr->refCount++;
+ }
+ part1 = TclGetString(objv[1]);
+ varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
+ (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG));
+ varPtr->refCount--;
+ if (arrayPtr != NULL) {
+ arrayPtr->refCount--;
+ }
+
if (varValuePtr == NULL) {
/*
* We couldn't read the old value: either the var doesn't yet
- * exist or it's an array element. If it's new, we will try to
+ * exist or it's an array element. If it's new, we will try to
* create it with Tcl_ObjSetVar2 below.
*/
- char *p, *varName;
- int nameBytes, i;
-
- varName = Tcl_GetStringFromObj(objv[1], &nameBytes);
- for (i = 0, p = varName; i < nameBytes; i++, p++) {
- if (*p == '(') {
- p = (varName + nameBytes-1);
- if (*p == ')') { /* last char is ')' => array ref */
- createVar = 0;
- }
- break;
- }
- }
+ createVar = (TclIsVarUndefined(varPtr));
varValuePtr = Tcl_NewObj();
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
return result;
}
}
- listRepPtr = (List *) varValuePtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
* was new and we didn't create the variable.
*/
- newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
- TCL_LEAVE_ERR_MSG);
+ newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
+ varValuePtr, TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
if (createdNewObj && !createVar) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET,
ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
- ARRAY_STARTSEARCH, ARRAY_UNSET};
- static char *arrayOptions[] = {
+ ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET};
+ static CONST char *arrayOptions[] = {
"anymore", "donesearch", "exists", "get", "names", "nextelement",
- "set", "size", "startsearch", "unset", (char *) NULL
+ "set", "size", "startsearch", "statistics", "unset", (char *) NULL
};
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+ Tcl_Obj *resultPtr, *varNamePtr;
int notArray;
- char *varName, *msg;
+ char *varName;
int index, result;
}
/*
- * Locate the array variable (and it better be an array).
+ * Locate the array variable
*/
- varName = TclGetString(objv[2]);
- varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
+ varNamePtr = objv[2];
+ varName = TclGetString(varNamePtr);
+ varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
- notArray = 0;
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
- notArray = 1;
- }
-
/*
* Special array trace used to keep the env array in sync for
* array names, array get, etc.
*/
- if (varPtr != NULL && varPtr->tracePtr != NULL) {
- msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL,
+ if (varPtr != NULL && varPtr->tracePtr != NULL
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL,
(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY));
- if (msg != NULL) {
- VarErrMsg(interp, varName, NULL, "trace array", msg);
+ TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
return TCL_ERROR;
}
}
+ /*
+ * Verify that it is indeed an array variable. This test comes after
+ * the traces - the variable may actually become an array as an effect
+ * of said traces.
+ */
+
+ notArray = 0;
+ if ((varPtr == NULL) || !TclIsVarArray(varPtr)
+ || TclIsVarUndefined(varPtr)) {
+ notArray = 1;
+ }
+
+ /*
+ * We have to wait to get the resultPtr until here because
+ * CallVarTraces can affect the result.
+ */
+
+ resultPtr = Tcl_GetObjResult(interp);
+
switch (index) {
case ARRAY_ANYMORE: {
ArraySearch *searchPtr;
- char *searchId;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv,
if (notArray) {
goto error;
}
- searchId = Tcl_GetString(objv[3]);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
}
case ARRAY_DONESEARCH: {
ArraySearch *searchPtr, *prevPtr;
- char *searchId;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv,
if (notArray) {
goto error;
}
- searchId = Tcl_GetString(objv[3]);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
Var *varPtr2;
char *pattern = NULL;
char *name;
- Tcl_Obj *namePtr, *valuePtr;
+ Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr;
+ int i, count;
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
if (objc == 4) {
pattern = TclGetString(objv[3]);
}
+
+ /*
+ * Store the array names in a new object.
+ */
+
+ nameLstPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(nameLstPtr);
+
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
}
namePtr = Tcl_NewStringObj(name, -1);
- result = Tcl_ListObjAppendElement(interp, resultPtr,
+ result = Tcl_ListObjAppendElement(interp, nameLstPtr,
namePtr);
if (result != TCL_OK) {
Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
+ Tcl_DecrRefCount(nameLstPtr);
return result;
}
+ }
+
+ /*
+ * Make sure the Var structure of the array is not removed by
+ * a trace while we're working.
+ */
+ varPtr->refCount++;
+
+ /*
+ * Get the array values corresponding to each element name
+ */
+
+ tmpResPtr = Tcl_NewObj();
+ result = Tcl_ListObjGetElements(interp, nameLstPtr,
+ &count, &namePtrPtr);
+ if (result != TCL_OK) {
+ goto errorInArrayGet;
+ }
+
+ for (i = 0; i < count; i++) {
+ namePtr = *namePtrPtr++;
valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
- return result;
+ /*
+ * Some trace played a trick on us; we need to diagnose to
+ * adapt our behaviour: was the array element unset, or did
+ * the modification modify the complete array?
+ */
+
+ if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ /*
+ * The array itself looks OK, the variable was
+ * undefined: forget it.
+ */
+
+ continue;
+ } else {
+ result = TCL_ERROR;
+ goto errorInArrayGet;
+ }
}
- result = Tcl_ListObjAppendElement(interp, resultPtr,
- valuePtr);
+ result = Tcl_ListObjAppendElement(interp, tmpResPtr, namePtr);
if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
- return result;
+ goto errorInArrayGet;
+ }
+ result = Tcl_ListObjAppendElement(interp, tmpResPtr, valuePtr);
+ if (result != TCL_OK) {
+ goto errorInArrayGet;
}
}
+ varPtr->refCount--;
+ Tcl_SetObjResult(interp, tmpResPtr);
+ Tcl_DecrRefCount(nameLstPtr);
break;
+
+ errorInArrayGet:
+ varPtr->refCount--;
+ Tcl_DecrRefCount(nameLstPtr);
+ Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */
+ return result;
}
case ARRAY_NAMES: {
Tcl_HashSearch search;
char *pattern = NULL;
char *name;
Tcl_Obj *namePtr;
+ int mode, matched = 0;
+ static CONST char *options[] = {
+ "-exact", "-glob", "-regexp", (char *) NULL
+ };
+ enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
+
+ mode = OPT_GLOB;
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
+ if ((objc < 3) || (objc > 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "arrayName ?mode? ?pattern?");
return TCL_ERROR;
}
if (notArray) {
}
if (objc == 4) {
pattern = Tcl_GetString(objv[3]);
- }
+ } else if (objc == 5) {
+ pattern = Tcl_GetString(objv[4]);
+ if (Tcl_GetIndexFromObj(interp, objv[3], options, "option",
+ 0, &mode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
continue;
}
name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
- if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
- continue; /* element name doesn't match pattern */
+ if (objc > 3) {
+ switch ((enum options) mode) {
+ case OPT_EXACT:
+ matched = (strcmp(name, pattern) == 0);
+ break;
+ case OPT_GLOB:
+ matched = Tcl_StringMatch(name, pattern);
+ break;
+ case OPT_REGEXP:
+ matched = Tcl_RegExpMatch(interp, name,
+ pattern);
+ if (matched < 0) {
+ return TCL_ERROR;
+ }
+ break;
+ }
+ if (matched == 0) {
+ continue;
+ }
}
namePtr = Tcl_NewStringObj(name, -1);
}
case ARRAY_NEXTELEMENT: {
ArraySearch *searchPtr;
- char *searchId;
Tcl_HashEntry *hPtr;
if (objc != 4) {
if (notArray) {
goto error;
}
- searchId = Tcl_GetString(objv[3]);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
if (searchPtr == NULL) {
return TCL_ERROR;
}
varPtr->searchPtr = searchPtr;
break;
}
- case ARRAY_UNSET: {
+
+ case ARRAY_STATISTICS: {
+ CONST char *stats;
+
+ if (notArray) {
+ goto error;
+ }
+
+ stats = Tcl_HashStats(varPtr->value.tablePtr);
+ if (stats != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), stats, -1);
+ ckfree((void *)stats);
+ } else {
+ Tcl_SetResult(interp, "error reading array statistics",
+ TCL_STATIC);
+ return TCL_ERROR;
+ }
+ break;
+ }
+
+ case ARRAY_UNSET: {
Tcl_HashSearch search;
Var *varPtr2;
char *pattern = NULL;
/*
* When no pattern is given, just unset the whole array
*/
- if (Tcl_UnsetVar2(interp, varName, (char *) NULL, 0)
+ if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0)
!= TCL_OK) {
return TCL_ERROR;
}
}
name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
if (Tcl_StringMatch(name, pattern) &&
- (Tcl_UnsetVar2(interp, varName, name, 0)
+ (TclObjUnsetVar2(interp, varNamePtr, name, 0)
!= TCL_OK)) {
return TCL_ERROR;
}
{
Var *varPtr, *arrayPtr;
Tcl_Obj **elemPtrs;
- int result, elemLen, i;
+ int result, elemLen, i, nameLen;
char *varName, *p;
- varName = TclGetString(arrayNameObj);
- for (p = varName; *p ; p++) {
- if (*p == '(') {
- do {
- p++;
- } while (*p != '\0');
- p--;
- if (*p == ')') {
+ varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
+ p = varName + nameLen - 1;
+ if (*p == ')') {
+ while (--p >= varName) {
+ if (*p == '(') {
VarErrMsg(interp, varName, NULL, "set", needArray);
return TCL_ERROR;
}
- break;
}
}
- varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ varPtr = TclObjLookupVar(interp, arrayNameObj, NULL,
+ /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
+ /*createPart2*/ 0, &arrayPtr);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
if (arrayElemObj != NULL) {
result = Tcl_ListObjGetElements(interp, arrayElemObj,
return TCL_ERROR;
}
if (elemLen > 0) {
+ /*
+ * We needn't worry about traces invalidating arrayPtr:
+ * should that be the case, TclPtrSetVar will return NULL
+ * so that we break out of the loop and return an error.
+ */
+
for (i = 0; i < elemLen; i += 2) {
- if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i],
- elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
+ char *part2 = TclGetString(elemPtrs[i]);
+ Var *elemVarPtr = TclLookupArrayElement(interp, varName,
+ part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
+ if ((elemVarPtr == NULL) ||
+ (TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
+ part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
result = TCL_ERROR;
break;
}
VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
return TCL_ERROR;
}
- } else {
- /*
- * Create variable for new array.
- */
-
- varPtr = TclLookupVar(interp, varName, (char *) NULL,
- TCL_LEAVE_ERR_MSG, "set",
- /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Still couldn't do it - this can occur if a non-existent
- * namespace was specified
- */
- if (varPtr == NULL) {
- return TCL_ERROR;
- }
}
TclSetVarArray(varPtr);
TclClearVarUndefined(varPtr);
/*
*----------------------------------------------------------------------
*
- * MakeUpvar --
+ * ObjMakeUpvar --
*
* This procedure does all of the work of the "global" and "upvar"
* commands.
*/
static int
-MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags)
- Interp *iPtr; /* Interpreter containing variables. Used
- * for error messages, too. */
+ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index)
+ Tcl_Interp *interp; /* Interpreter containing variables. Used
+ * for error messages, too. */
CallFrame *framePtr; /* Call frame containing "other" variable.
* NULL means use global :: context. */
- char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */
- int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
+ Tcl_Obj *otherP1Ptr;
+ CONST char *otherP2; /* Two-part name of variable in framePtr. */
+ CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of "other" variable. */
- char *myName; /* Name of variable which will refer to
+ CONST char *myName; /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
- int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
+ CONST int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
+ int index; /* If the variable to be linked is an indexed
+ * scalar, this is its index. Otherwise, -1. */
{
- Tcl_HashEntry *hPtr;
+ Interp *iPtr = (Interp *) interp;
Var *otherPtr, *varPtr, *arrayPtr;
CallFrame *varFramePtr;
- CallFrame *savedFramePtr = NULL; /* Init. to avoid compiler warning. */
- Tcl_HashTable *tablePtr;
- Namespace *nsPtr, *altNsPtr, *dummyNsPtr;
- char *tail;
- int new;
+ CONST char *errMsg;
/*
* Find "other" in "framePtr". If not looking up other in just the
* current namespace, temporarily replace the current var frame
- * pointer in the interpreter in order to use TclLookupVar.
+ * pointer in the interpreter in order to use TclObjLookupVar.
*/
+ varFramePtr = iPtr->varFramePtr;
if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
- savedFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = framePtr;
}
- otherPtr = TclLookupVar((Tcl_Interp *) iPtr, otherP1, otherP2,
+ otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2,
(otherFlags | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
- iPtr->varFramePtr = savedFramePtr;
+ iPtr->varFramePtr = varFramePtr;
}
if (otherPtr == NULL) {
return TCL_ERROR;
}
- /*
- * Now create a hashtable entry for "myName". Create it as either a
- * namespace variable or as a local variable in a procedure call
- * frame. Interpret myName as a namespace variable if:
- * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
- * 2) there is no active frame (we're at the global :: scope),
- * 3) the active frame was pushed to define the namespace context
- * for a "namespace eval" or "namespace inscope" command,
- * 4) the name has namespace qualifiers ("::"s).
- * If creating myName in the active procedure, look first in the
- * frame's array of compiler-allocated local variables, then in its
- * hashtable for runtime-created local variables. Create that
- * procedure's local variable hashtable if necessary.
- */
-
- varFramePtr = iPtr->varFramePtr;
- if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
- || (varFramePtr == NULL)
- || !varFramePtr->isProcCallFrame
- || (strstr(myName, "::") != NULL)) {
- TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName,
- (Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail);
-
- if (nsPtr == NULL) {
- nsPtr = altNsPtr;
- }
- if (nsPtr == NULL) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
- myName, "\": unknown namespace", (char *) NULL);
- return TCL_ERROR;
- }
-
+ if (index >= 0) {
+ if (!varFramePtr->isProcCallFrame) {
+ panic("ObjMakeUpVar called with an index outside from a proc.\n");
+ }
+ varPtr = &(varFramePtr->compiledLocals[index]);
+ } else {
/*
* Check that we are not trying to create a namespace var linked to
* a local variable in a procedure. If we allowed this, the local
* variable in the shorter-lived procedure frame could go away
* leaving the namespace var's reference invalid.
*/
-
- if ((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
- myName, "\": upvar won't create namespace variable that refers to procedure variable",
- (char *) NULL);
- return TCL_ERROR;
- }
- hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new);
- if (new) {
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = nsPtr;
- } else {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- }
- } else { /* look in the call frame */
- Proc *procPtr = varFramePtr->procPtr;
- int localCt = procPtr->numCompiledLocals;
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
- Var *localVarPtr = varFramePtr->compiledLocals;
- int nameLen = strlen(myName);
- int i;
-
- varPtr = NULL;
- for (i = 0; i < localCt; i++) {
- if (!TclIsVarTemporary(localPtr)) {
- char *localName = localVarPtr->name;
- if ((myName[0] == localName[0])
- && (nameLen == localPtr->nameLength)
- && (strcmp(myName, localName) == 0)) {
- varPtr = localVarPtr;
- new = 0;
- break;
- }
- }
- localVarPtr++;
- localPtr = localPtr->nextPtr;
+ if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
+ && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
+ || (varFramePtr == NULL)
+ || !varFramePtr->isProcCallFrame
+ || (strstr(myName, "::") != NULL))) {
+ Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
+ myName, "\": upvar won't create namespace variable that ",
+ "refers to procedure variable", (char *) NULL);
+ return TCL_ERROR;
}
- if (varPtr == NULL) { /* look in frame's local var hashtable */
- tablePtr = varFramePtr->varTablePtr;
- if (tablePtr == NULL) {
- tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
- varFramePtr->varTablePtr = tablePtr;
- }
- hPtr = Tcl_CreateHashEntry(tablePtr, myName, &new);
- if (new) {
- varPtr = NewVar();
- Tcl_SetHashValue(hPtr, varPtr);
- varPtr->hPtr = hPtr;
- varPtr->nsPtr = varFramePtr->nsPtr;
- } else {
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
- }
+
+ /*
+ * Lookup and eventually create the new variable.
+ */
+
+ varPtr = TclLookupSimpleVar(interp, myName, myFlags, /*create*/ 1,
+ &errMsg, &index);
+ if (varPtr == NULL) {
+ VarErrMsg(interp, myName, NULL, "create", errMsg);
+ return TCL_ERROR;
}
}
- if (!new) {
+ if (varPtr == otherPtr) {
+ Tcl_SetResult((Tcl_Interp *) iPtr,
+ "can't upvar from variable to itself", TCL_STATIC);
+ return TCL_ERROR;
+ }
+
+ if (varPtr->tracePtr != NULL) {
+ Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
+ "\" has traces: can't use for upvar", (char *) NULL);
+ return TCL_ERROR;
+ } else if (!TclIsVarUndefined(varPtr)) {
/*
- * The variable already exists. Make sure this variable "varPtr"
+ * The variable already existed. Make sure this variable "varPtr"
* isn't the same as "otherPtr" (avoid circular links). Also, if
* it's not an upvar then it's an error. If it is an upvar, then
* just disconnect it from the thing it currently refers to.
*/
- if (varPtr == otherPtr) {
- Tcl_SetResult((Tcl_Interp *) iPtr,
- "can't upvar from variable to itself", TCL_STATIC);
- return TCL_ERROR;
- }
if (TclIsVarLink(varPtr)) {
Var *linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
if (TclIsVarUndefined(linkPtr)) {
CleanupVar(linkPtr, (Var *) NULL);
}
- } else if (!TclIsVarUndefined(varPtr)) {
+ } else {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" already exists", (char *) NULL);
return TCL_ERROR;
- } else if (varPtr->tracePtr != NULL) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
- "\" has traces: can't use for upvar", (char *) NULL);
- return TCL_ERROR;
}
}
TclSetVarLink(varPtr);
Tcl_UpVar(interp, frameName, varName, localName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
- char *frameName; /* Name of the frame containing the source
+ CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
- char *varName; /* Name of a variable in interp to link to.
+ CONST char *varName; /* Name of a variable in interp to link to.
* May be either a scalar name or an
* element in an array. */
- char *localName; /* Name of link variable. */
+ CONST char *localName; /* Name of link variable. */
int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of localName. */
{
- int result;
- CallFrame *framePtr;
- register char *p;
-
- result = TclGetFrame(interp, frameName, &framePtr);
- if (result == -1) {
- return TCL_ERROR;
- }
-
- /*
- * Figure out whether varName is an array reference, then call
- * MakeUpvar to do all the real work.
- */
-
- for (p = varName; *p != '\0'; p++) {
- if (*p == '(') {
- char *openParen = p;
- do {
- p++;
- } while (*p != '\0');
- p--;
- if (*p != ')') {
- goto scalar;
- }
- *openParen = '\0';
- *p = '\0';
- result = MakeUpvar((Interp *) interp, framePtr, varName,
- openParen+1, 0, localName, flags);
- *openParen = '(';
- *p = ')';
- return result;
- }
- }
-
- scalar:
- return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL,
- 0, localName, flags);
+ return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
}
\f
/*
Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
Tcl_Interp *interp; /* Interpreter containing variables. Used
* for error messages too. */
- char *frameName; /* Name of the frame containing the source
+ CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
- char *part1, *part2; /* Two parts of source variable name to
+ CONST char *part1;
+ CONST char *part2; /* Two parts of source variable name to
* link to. */
- char *localName; /* Name of link variable. */
+ CONST char *localName; /* Name of link variable. */
int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of localName. */
{
int result;
CallFrame *framePtr;
+ Tcl_Obj *part1Ptr;
- result = TclGetFrame(interp, frameName, &framePtr);
- if (result == -1) {
+ if (TclGetFrame(interp, frameName, &framePtr) == -1) {
return TCL_ERROR;
}
- return MakeUpvar((Interp *) interp, framePtr, part1, part2, 0,
- localName, flags);
+
+ part1Ptr = Tcl_NewStringObj(part1, -1);
+ Tcl_IncrRefCount(part1Ptr);
+ result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
+ localName, flags, -1);
+ TclDecrRefCount(part1Ptr);
+
+ return result;
}
\f
/*
while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
tail--;
}
- if (*tail == ':') {
+ if ((*tail == ':') && (tail > varName)) {
tail++;
}
* Link to the variable "varName" in the global :: namespace.
*/
- result = MakeUpvar(iPtr, (CallFrame *) NULL,
- varName, (char *) NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
- /*myName*/ tail, /*myFlags*/ 0);
+ result = ObjMakeUpvar(interp, (CallFrame *) NULL,
+ objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
+ /*myName*/ tail, /*myFlags*/ 0, -1);
if (result != TCL_OK) {
return result;
}
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr;
int i, result;
+ Tcl_Obj *varNamePtr;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
+ return TCL_ERROR;
+ }
for (i = 1; i < objc; i = i+2) {
/*
* it if necessary.
*/
- varName = TclGetString(objv[i]);
- varPtr = TclLookupVar(interp, varName, (char *) NULL,
+ varNamePtr = objv[i];
+ varName = TclGetString(varNamePtr);
+ varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
*/
if (i+1 < objc) { /* a value was specified */
- varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1],
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
+ varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
+ objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
if (varValuePtr == NULL) {
return TCL_ERROR;
}
* current namespace.
*/
- result = MakeUpvar(iPtr, (CallFrame *) NULL,
- /*otherP1*/ varName, /*otherP2*/ (char *) NULL,
+ result = ObjMakeUpvar(interp, (CallFrame *) NULL,
+ /*otherP1*/ varNamePtr, /*otherP2*/ NULL,
/*otherFlags*/ TCL_NAMESPACE_ONLY,
- /*myName*/ tail, /*myFlags*/ 0);
+ /*myName*/ tail, /*myFlags*/ 0, -1);
if (result != TCL_OK) {
return result;
}
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- register Interp *iPtr = (Interp *) interp;
CallFrame *framePtr;
- char *frameSpec, *otherVarName, *myVarName;
- register char *p;
+ char *frameSpec, *localName;
int result;
if (objc < 3) {
*/
for ( ; objc > 0; objc -= 2, objv += 2) {
- myVarName = TclGetString(objv[1]);
- otherVarName = TclGetString(objv[0]);
- for (p = otherVarName; *p != 0; p++) {
- if (*p == '(') {
- char *openParen = p;
-
- do {
- p++;
- } while (*p != '\0');
- p--;
- if (*p != ')') {
- goto scalar;
- }
- *openParen = '\0';
- *p = '\0';
- result = MakeUpvar(iPtr, framePtr,
- otherVarName, openParen+1, /*otherFlags*/ 0,
- myVarName, /*flags*/ 0);
- *openParen = '(';
- *p = ')';
- goto checkResult;
- }
- }
- scalar:
- result = MakeUpvar(iPtr, framePtr, otherVarName, (char *) NULL, 0,
- myVarName, /*flags*/ 0);
-
- checkResult:
+ localName = TclGetString(objv[1]);
+ result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],
+ NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);
if (result != TCL_OK) {
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * CallTraces --
+ * DisposeTraceResult--
+ *
+ * This procedure is called to dispose of the result returned from
+ * a trace procedure. The disposal method appropriate to the type
+ * of result is determined by flags.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The memory allocated for the trace result may be freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+DisposeTraceResult(flags, result)
+ int flags; /* Indicates type of result to determine
+ * proper disposal method */
+ char *result; /* The result returned from a trace
+ * procedure to be disposed */
+{
+ if (flags & TCL_TRACE_RESULT_DYNAMIC) {
+ ckfree(result);
+ } else if (flags & TCL_TRACE_RESULT_OBJECT) {
+ Tcl_DecrRefCount((Tcl_Obj *) result);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * CallVarTraces --
*
* This procedure is invoked to find and invoke relevant
* trace procedures associated with a particular operation on
* variable and on its containing array (where relevant).
*
* Results:
- * The return value is NULL if no trace procedures were invoked, or
- * if all the invoked trace procedures returned successfully.
- * The return value is non-NULL if a trace procedure returned an
- * error (in this case no more trace procedures were invoked after
- * the error was returned). In this case the return value is a
- * pointer to a static string describing the error.
+ * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR
+ * if invocation of a trace procedure indicated an error. When
+ * TCL_ERROR is returned and leaveErrMsg is true, then the
+ * ::errorInfo variable of iPtr has information about the error
+ * appended to it.
*
* Side effects:
* Almost anything can happen, depending on trace; this procedure
*----------------------------------------------------------------------
*/
-static char *
-CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
+int
+CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
Interp *iPtr; /* Interpreter containing variable. */
register Var *arrayPtr; /* Pointer to array variable that contains
* the variable, or NULL if the variable
* isn't an element of an array. */
Var *varPtr; /* Variable whose traces are to be
* invoked. */
- char *part1, *part2; /* Variable's two-part name. */
+ CONST char *part1;
+ CONST char *part2; /* Variable's two-part name. */
int flags; /* Flags passed to trace procedures:
* indicates what's happening to variable,
* plus other stuff like TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, and
* TCL_INTERP_DESTROYED. */
+ CONST int leaveErrMsg; /* If true, and one of the traces indicates an
+ * error, then leave an error message and stack
+ * trace information in *iPTr. */
{
register VarTrace *tracePtr;
ActiveVarTrace active;
- char *result, *openParen, *p;
+ char *result;
+ CONST char *openParen, *p;
Tcl_DString nameCopy;
int copiedName;
+ int code = TCL_OK;
+ int disposeFlags = 0;
/*
* If there are already similar trace procedures active for the
*/
if (varPtr->flags & VAR_TRACE_ACTIVE) {
- return NULL;
+ return code;
}
varPtr->flags |= VAR_TRACE_ACTIVE;
varPtr->refCount++;
+ if (arrayPtr != NULL) {
+ arrayPtr->refCount++;
+ }
/*
* If the variable name hasn't been parsed into array name and
} while (*p != '\0');
p--;
if (*p == ')') {
+ int offset = (openParen - part1);
+ char *newPart1;
Tcl_DStringInit(&nameCopy);
Tcl_DStringAppend(&nameCopy, part1, (p-part1));
- part2 = Tcl_DStringValue(&nameCopy)
- + (openParen + 1 - part1);
- part2[-1] = 0;
- part1 = Tcl_DStringValue(&nameCopy);
+ newPart1 = Tcl_DStringValue(&nameCopy);
+ newPart1[offset] = 0;
+ part1 = newPart1;
+ part2 = newPart1 + offset + 1;
copiedName = 1;
}
break;
*/
result = NULL;
- active.nextPtr = iPtr->activeTracePtr;
- iPtr->activeTracePtr = &active;
- if (arrayPtr != NULL) {
- arrayPtr->refCount++;
+ active.nextPtr = iPtr->activeVarTracePtr;
+ iPtr->activeVarTracePtr = &active;
+ Tcl_Preserve((ClientData) iPtr);
+ if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) {
active.varPtr = arrayPtr;
for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
if (!(tracePtr->flags & flags)) {
continue;
}
+ Tcl_Preserve((ClientData) tracePtr);
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
- result = NULL;
+ /* Ignore errors in unset traces */
+ DisposeTraceResult(tracePtr->flags, result);
} else {
- goto done;
+ disposeFlags = tracePtr->flags;
+ code = TCL_ERROR;
}
}
+ Tcl_Release((ClientData) tracePtr);
+ if (code == TCL_ERROR) {
+ goto done;
+ }
}
}
if (!(tracePtr->flags & flags)) {
continue;
}
+ Tcl_Preserve((ClientData) tracePtr);
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
- result = NULL;
+ /* Ignore errors in unset traces */
+ DisposeTraceResult(tracePtr->flags, result);
} else {
- goto done;
+ disposeFlags = tracePtr->flags;
+ code = TCL_ERROR;
}
}
+ Tcl_Release((ClientData) tracePtr);
+ if (code == TCL_ERROR) {
+ goto done;
+ }
}
/*
*/
done:
+ if (code == TCL_ERROR) {
+ if (leaveErrMsg) {
+ CONST char *type = "";
+ switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
+ case TCL_TRACE_READS: {
+ type = "read";
+ break;
+ }
+ case TCL_TRACE_WRITES: {
+ type = "set";
+ break;
+ }
+ case TCL_TRACE_ARRAY: {
+ type = "trace array";
+ break;
+ }
+ }
+ if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
+ VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
+ Tcl_GetString((Tcl_Obj *) result));
+ } else {
+ VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
+ }
+ }
+ DisposeTraceResult(disposeFlags,result);
+ }
+
if (arrayPtr != NULL) {
arrayPtr->refCount--;
}
}
varPtr->flags &= ~VAR_TRACE_ACTIVE;
varPtr->refCount--;
- iPtr->activeTracePtr = active.nextPtr;
- return result;
+ iPtr->activeVarTracePtr = active.nextPtr;
+ Tcl_Release((ClientData) iPtr);
+ return code;
}
\f
/*
/*
*----------------------------------------------------------------------
*
+ * SetArraySearchObj --
+ *
+ * This function converts the given tcl object into one that
+ * has the "array search" internal type.
+ *
+ * Results:
+ * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed
+ * (when an error message will be placed in the interpreter's
+ * result.)
+ *
+ * Side effects:
+ * Updates the internal type and representation of the object to
+ * make this an array-search object. See the tclArraySearchType
+ * declaration above for details of the internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetArraySearchObj(interp, objPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj *objPtr;
+{
+ char *string;
+ char *end;
+ int id;
+ size_t offset;
+
+ /*
+ * Get the string representation. Make it up-to-date if necessary.
+ */
+
+ string = Tcl_GetString(objPtr);
+
+ /*
+ * Parse the id into the three parts separated by dashes.
+ */
+ if ((string[0] != 's') || (string[1] != '-')) {
+ syntax:
+ Tcl_AppendResult(interp, "illegal search identifier \"", string,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ id = strtoul(string+2, &end, 10);
+ if ((end == (string+2)) || (*end != '-')) {
+ goto syntax;
+ }
+ /*
+ * Can't perform value check in this context, so place reference
+ * to place in string to use for the check in the object instead.
+ */
+ end++;
+ offset = end - string;
+
+ if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->typePtr = &tclArraySearchType;
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id);
+ objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* ParseSearchId --
*
- * This procedure translates from a string to a pointer to an
+ * This procedure translates from a tcl object to a pointer to an
* active array search (if there is one that matches the string).
*
* Results:
* the interp's result contains an error message.
*
* Side effects:
- * None.
+ * The tcl object might have its internal type and representation
+ * modified.
*
*----------------------------------------------------------------------
*/
static ArraySearch *
-ParseSearchId(interp, varPtr, varName, string)
+ParseSearchId(interp, varPtr, varName, handleObj)
Tcl_Interp *interp; /* Interpreter containing variable. */
- Var *varPtr; /* Array variable search is for. */
- char *varName; /* Name of array variable that search is
+ CONST Var *varPtr; /* Array variable search is for. */
+ CONST char *varName; /* Name of array variable that search is
* supposed to be for. */
- char *string; /* String containing id of search. Must have
+ Tcl_Obj *handleObj; /* Object containing id of search. Must have
* form "search-num-var" where "num" is a
* decimal number and "var" is a variable
* name. */
{
- char *end;
+ register char *string;
+ register size_t offset;
int id;
ArraySearch *searchPtr;
/*
- * Parse the id into the three parts separated by dashes.
+ * Parse the id.
*/
-
- if ((string[0] != 's') || (string[1] != '-')) {
- syntax:
- Tcl_AppendResult(interp, "illegal search identifier \"", string,
- "\"", (char *) NULL);
+ if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
return NULL;
}
- id = strtoul(string+2, &end, 10);
- if ((end == (string+2)) || (*end != '-')) {
- goto syntax;
- }
- if (strcmp(end+1, varName) != 0) {
+ /*
+ * Cast is safe, since always came from an int in the first place.
+ */
+ id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) -
+ ((char*)NULL));
+ string = Tcl_GetString(handleObj);
+ offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) -
+ ((char*)NULL));
+ /*
+ * This test cannot be placed inside the Tcl_Obj machinery, since
+ * it is dependent on the variable context.
+ */
+ if (strcmp(string+offset, varName) != 0) {
Tcl_AppendResult(interp, "search identifier \"", string,
"\" isn't for variable \"", varName, "\"", (char *) NULL);
return NULL;
/*
* Search through the list of active searches on the interpreter
* to see if the desired one exists.
+ *
+ * Note that we cannot store the searchPtr directly in the Tcl_Obj
+ * as that would run into trouble when DeleteSearches() was called
+ * so we must scan this list every time.
*/
for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
flags = TCL_TRACE_UNSETS;
if (tablePtr == &iPtr->globalNsPtr->varTable) {
- flags |= (TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY);
+ flags |= TCL_GLOBAL_ONLY;
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
+ if (Tcl_InterpDeleted(interp)) {
+ flags |= TCL_INTERP_DESTROYED;
+ }
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
* free up the variable's space (no need to free the hash entry
* here, unless we're dealing with a global variable: the
* hash entries will be deleted automatically when the whole
- * table is deleted). Note that we give CallTraces the variable's
+ * table is deleted). Note that we give CallVarTraces the variable's
* fully-qualified name so that any called trace procedures can
* refer to these variables being deleted.
*/
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr); /* until done with traces */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
- (void) CallTraces(iPtr, (Var *) NULL, varPtr,
- Tcl_GetString(objPtr), (char *) NULL, flags);
+ CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr),
+ NULL, flags, /* leaveErrMsg */ 0);
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
+ Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
- for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
+ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
*/
if (varPtr->tracePtr != NULL) {
- (void) CallTraces(iPtr, (Var *) NULL, varPtr,
- varPtr->name, (char *) NULL, flags);
+ CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL,
+ flags, /* leaveErrMsg */ 0);
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
+ Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
- for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
+ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
static void
DeleteArray(iPtr, arrayName, varPtr, flags)
Interp *iPtr; /* Interpreter containing array. */
- char *arrayName; /* Name of array (used for trace
+ CONST char *arrayName; /* Name of array (used for trace
* callbacks). */
Var *varPtr; /* Pointer to variable structure. */
- int flags; /* Flags to pass to CallTraces:
+ int flags; /* Flags to pass to CallVarTraces:
* TCL_TRACE_UNSETS and sometimes
* TCL_INTERP_DESTROYED,
* TCL_NAMESPACE_ONLY, or
elPtr->hPtr = NULL;
if (elPtr->tracePtr != NULL) {
elPtr->flags &= ~VAR_TRACE_ACTIVE;
- (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName,
- Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
+ CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
+ Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
+ /* leaveErrMsg */ 0);
while (elPtr->tracePtr != NULL) {
VarTrace *tracePtr = elPtr->tracePtr;
elPtr->tracePtr = tracePtr->nextPtr;
- ckfree((char *) tracePtr);
+ Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC);
}
- for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
+ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == elPtr) {
activePtr->nextTracePtr = NULL;
}
TclSetVarUndefined(elPtr);
TclSetVarScalar(elPtr);
+
+ /*
+ * Even though array elements are not supposed to be namespace
+ * variables, some combinations of [upvar] and [variable] may
+ * create such beasts - see [Bug 604239]. This is necessary to
+ * avoid leaking the corresponding Var struct, and is otherwise
+ * harmless.
+ */
+
+ if (elPtr->flags & VAR_NAMESPACE_VAR) {
+ elPtr->flags &= ~VAR_NAMESPACE_VAR;
+ elPtr->refCount--;
+ }
if (elPtr->refCount == 0) {
ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
}
static void
VarErrMsg(interp, part1, part2, operation, reason)
Tcl_Interp *interp; /* Interpreter in which to record message. */
- char *part1, *part2; /* Variable's two-part name. */
- char *operation; /* String describing operation that failed,
+ CONST char *part1;
+ CONST char *part2; /* Variable's two-part name. */
+ CONST char *operation; /* String describing operation that failed,
* e.g. "read", "set", or "unset". */
- char *reason; /* String describing why operation failed. */
+ CONST char *reason; /* String describing why operation failed. */
{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
}
Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}
-
\f
/*
*----------------------------------------------------------------------
Var *
TclVarTraceExists(interp, varName)
Tcl_Interp *interp; /* The interpreter */
- char *varName; /* The variable name */
+ CONST char *varName; /* The variable name */
{
Var *varPtr;
Var *arrayPtr;
- char *msg;
/*
* The choice of "create" flag values is delicate here, and
*/
varPtr = TclLookupVar(interp, varName, (char *) NULL,
- 0, "access",
- /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
+ 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
+
if (varPtr == NULL) {
return NULL;
}
- if ((varPtr != NULL) &&
- ((varPtr->tracePtr != NULL)
- || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
- msg = CallTraces((Interp *)interp, arrayPtr, varPtr, varName,
- (char *) NULL, TCL_TRACE_READS);
- if (msg != NULL) {
- /*
- * If the variable doesn't exist anymore and no-one's using
- * it, then free up the relevant structures and hash table entries.
- */
- if (TclIsVarUndefined(varPtr)) {
- CleanupVar(varPtr, arrayPtr);
+ if ((varPtr->tracePtr != NULL)
+ || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
+ CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
+ TCL_TRACE_READS, /* leaveErrMsg */ 0);
+ }
+
+ /*
+ * If the variable doesn't exist anymore and no-one's using
+ * it, then free up the relevant structures and hash table entries.
+ */
+
+ if (TclIsVarUndefined(varPtr)) {
+ CleanupVar(varPtr, arrayPtr);
+ return NULL;
+ }
+
+ return varPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Internal functions for variable name object types --
+ *
+ *----------------------------------------------------------------------
+ */
+
+/*
+ * localVarName -
+ *
+ * INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1 = pointer to the corresponding Proc
+ * twoPtrValue.ptr2 = index into locals table
+*/
+
+static void
+FreeLocalVarName(objPtr)
+ Tcl_Obj *objPtr;
+{
+ register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
+ procPtr->refCount--;
+ if (procPtr->refCount <= 0) {
+ TclProcCleanupProc(procPtr);
+ }
+}
+
+static void
+DupLocalVarName(srcPtr, dupPtr)
+ Tcl_Obj *srcPtr;
+ Tcl_Obj *dupPtr;
+{
+ register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
+
+ dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
+ dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2;
+ procPtr->refCount++;
+ dupPtr->typePtr = &tclLocalVarNameType;
+}
+
+static void
+UpdateLocalVarName(objPtr)
+ Tcl_Obj *objPtr;
+{
+ Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
+ unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ unsigned int nameLen;
+
+ if (localPtr == NULL) {
+ goto emptyName;
+ }
+ while (index--) {
+ localPtr = localPtr->nextPtr;
+ if (localPtr == NULL) {
+ goto emptyName;
+ }
+ }
+
+ nameLen = (unsigned int) localPtr->nameLength;
+ objPtr->bytes = ckalloc(nameLen + 1);
+ memcpy(objPtr->bytes, localPtr->name, nameLen + 1);
+ objPtr->length = nameLen;
+ return;
+
+ emptyName:
+ objPtr->bytes = ckalloc(1);
+ *(objPtr->bytes) = '\0';
+ objPtr->length = 0;
+}
+
+/*
+ * nsVarName -
+ *
+ * INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1: pointer to the namespace containing the
+ * reference.
+ * twoPtrValue.ptr2: pointer to the corresponding Var
+*/
+
+static void
+FreeNsVarName(objPtr)
+ Tcl_Obj *objPtr;
+{
+ register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2;
+
+ varPtr->refCount--;
+ if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) {
+ if (TclIsVarLink(varPtr)) {
+ Var *linkPtr = varPtr->value.linkPtr;
+ linkPtr->refCount--;
+ if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) {
+ CleanupVar(linkPtr, (Var *) NULL);
}
- return NULL;
}
+ CleanupVar(varPtr, NULL);
}
- return varPtr;
+}
+
+static void
+DupNsVarName(srcPtr, dupPtr)
+ Tcl_Obj *srcPtr;
+ Tcl_Obj *dupPtr;
+{
+ Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1;
+ register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2;
+
+ dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
+ dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
+ varPtr->refCount++;
+ dupPtr->typePtr = &tclNsVarNameType;
+}
+
+/*
+ * parsedVarName -
+ *
+ * INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj
+ * (NULL if scalar)
+ * twoPtrValue.ptr2 = pointer to the element name string
+ * (owned by this Tcl_Obj), or NULL if
+ * it is a scalar variable
+ */
+
+static void
+FreeParsedVarName(objPtr)
+ Tcl_Obj *objPtr;
+{
+ register Tcl_Obj *arrayPtr =
+ (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
+ register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2;
+
+ if (arrayPtr != NULL) {
+ TclDecrRefCount(arrayPtr);
+ ckfree(elem);
+ }
+}
+
+static void
+DupParsedVarName(srcPtr, dupPtr)
+ Tcl_Obj *srcPtr;
+ Tcl_Obj *dupPtr;
+{
+ register Tcl_Obj *arrayPtr =
+ (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1;
+ register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2;
+ char *elemCopy;
+ unsigned int elemLen;
+
+ if (arrayPtr != NULL) {
+ Tcl_IncrRefCount(arrayPtr);
+ elemLen = strlen(elem);
+ elemCopy = ckalloc(elemLen+1);
+ memcpy(elemCopy, elem, elemLen);
+ *(elemCopy + elemLen) = '\0';
+ elem = elemCopy;
+ }
+
+ dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr;
+ dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem;
+ dupPtr->typePtr = &tclParsedVarNameType;
+}
+
+static void
+UpdateParsedVarName(objPtr)
+ Tcl_Obj *objPtr;
+{
+ Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
+ char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2;
+ char *part1, *p;
+ int len1, len2, totalLen;
+
+ if (arrayPtr == NULL) {
+ /*
+ * This is a parsed scalar name: what is it
+ * doing here?
+ */
+ panic("ERROR: scalar parsedVarName without a string rep.\n");
+ }
+ part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
+ len2 = strlen(part2);
+
+ totalLen = len1 + len2 + 2;
+ p = ckalloc((unsigned int) totalLen + 1);
+ objPtr->bytes = p;
+ objPtr->length = totalLen;
+
+ memcpy(p, part1, (unsigned int) len1);
+ p += len1;
+ *p++ = '(';
+ memcpy(p, part2, (unsigned int) len2);
+ p += len2;
+ *p++ = ')';
+ *p = '\0';
}
# initScript Initialization script to source (e.g., tk.tcl)
# enVarName environment variable to honor (e.g., TK_LIBRARY)
# varName Global variable to set when done (e.g., tk_library)
-# CYGNUS LOCAL: We have funny things like gdb having different library
-# names before & after install (and neither of them is gdb
-# or gdb$version...
-# srcLibName The name of the library directory in the build tree (assumed to be
-# under the basename directory.
-# instLibName The name of the installed library directory
-# pkgName The package name (for cases like Itcl where you have
-# several subpackages under one package...
-# debug_startup Run the startup proc through debugger_eval?
-
-proc tcl_findLibrary {basename version patch initScript
- enVarName varName {srcLibName {}} {instLibName {}}
- {pkgName {}} {debug_startup 0}} {
+
+proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
global env errorInfo
set dirs {}
set errors {}
+
# The C application may have hardwired a path, which we honor
- if {[info exist the_library] && [string compare $the_library {}]} {
+ set variableSet [info exists the_library]
+ if {$variableSet && [string compare $the_library {}]} {
lappend dirs $the_library
} else {
}
# 2. Relative to the Tcl library
-
- if {$srcLibName == ""} {
- set srcLibName library
- }
- if {$instLibName == ""} {
- set instLibName $basename$version
- }
lappend dirs [file join [file dirname [info library]] \
$basename$version]
+ # 3. Various locations relative to the executable
+ # ../lib/foo1.0 (From bin directory in install hierarchy)
+ # ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
+ # ../library (From unix directory in build hierarchy)
+ # ../../library (From unix/arch directory in build hierarchy)
+ # ../../foo1.0.1/library
+ # (From unix directory in parallel build hierarchy)
+ # ../../../foo1.0.1/library
+ # (From unix/arch directory in parallel build hierarchy)
+
set parentDir [file dirname [file dirname [info nameofexecutable]]]
set grandParentDir [file dirname $parentDir]
lappend dirs [file join $parentDir lib $basename$version]
lappend dirs [file join $grandParentDir lib $basename$version]
lappend dirs [file join $parentDir library]
lappend dirs [file join $grandParentDir library]
- if {![regexp {.*[ab][0-9]*} $patch ver]} {
- set ver $version
- }
- lappend dirs [file join $grandParentDir $basename$ver library]
- lappend dirs [file join [file dirname $grandParentDir] $basename$ver library]
+ lappend dirs [file join $grandParentDir $basename$patch library]
+ lappend dirs [file join [file dirname $grandParentDir] \
+ $basename$patch library]
+
+ # 4. On MacOSX, check the directories in the tcl_pkgPath
+ if {[string equal $::tcl_platform(platform) "unix"] && \
+ [string equal $::tcl_platform(os) "Darwin"]} {
+ foreach d $::tcl_pkgPath {
+ lappend dirs [file join $d $basename$version]
+ lappend dirs [file join $d $basename$version Resources Scripts]
+ }
+ }
}
-
foreach i $dirs {
set the_library $i
set file [file join $i $initScript]
# we have a source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
- if {$debug_startup} {
-
- if {![catch {uplevel \#0 debugger_eval [list [list source $file]]} msg]} {
- return
- } else {
- append errors "$file: $msg\n$errorInfo\n"
- }
- } else {
- if {![catch {uplevel \#0 [list source $file]} msg]} {
- return
- } else {
- append errors "$file: $msg\n$errorInfo\n"
- }
- }
- }
+ if {![catch {uplevel #0 [list source $file]} msg]} {
+ return
+ } else {
+ append errors "$file: $msg\n$errorInfo\n"
+ }
+ }
+ }
+ if {!$variableSet} {
+ unset the_library
}
set msg "Can't find a usable $initScript in the following directories: \n"
append msg " $dirs\n\n"
error $msg
}
+
# ----------------------------------------------------------------------
# auto_mkindex
# ----------------------------------------------------------------------
+++ /dev/null
-package ifneeded dde 1.0 "load [list [file join $dir tcldde81.dll]] dde"\r
+++ /dev/null
-if {[info exists tcl_platform(debug)]} {
- package ifneeded dde 1.1 [list load [file join $dir tcldde83d.dll] dde]
-} else {
- package ifneeded dde 1.1 [list load [file join $dir tcldde83.dll] dde]
-}
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-00800081201A0083201E2026202020210088203001602039015A0164017D0179
+20AC0081201A0083201E2026202020210088203001602039015A0164017D0179
009020182019201C201D202220132014009821220161203A015B0165017E017A
-00A002C702D8014100A4010400A600A700A800A9015E00AB000000AD00AE017B
+00A002C702D8014100A4010400A600A700A800A9015E00AB00AC00AD00AE017B
00B000B102DB014200B400B500B600B700B80105015F00BB013D02DD013E017C
015400C100C2010200C40139010600C7010C00C9011800CB011A00CD00CE010E
01100143014700D300D4015000D600D70158016E00DA017000DC00DD016200DF
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-04020403201A0453201E2026202020210088203004092039040A040C040B040F
+04020403201A0453201E20262020202120AC203004092039040A040C040B040F
045220182019201C201D202220132014009821220459203A045A045C045B045F
00A0040E045E040800A4049000A600A7040100A9040400AB00AC00AD00AE0407
00B000B104060456049100B500B600B704512116045400BB0458040504550457
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-00800081201A0192201E20262020202102C62030016020390152008D008E008F
-009020182019201C201D20222013201402DC21220161203A0153009D009E0178
+20AC0081201A0192201E20262020202102C62030016020390152008D017D008F
+009020182019201C201D20222013201402DC21220161203A0153009D017E0178
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-00800081201A0192201E20262020202100882030008A2039008C008D008E008F
+20AC0081201A0192201E20262020202100882030008A2039008C008D008E008F
009020182019201C201D20222013201400982122009A203A009C009D009E009F
00A00385038600A300A400A500A600A700A800A9000000AB00AC00AD00AE2015
00B000B100B200B3038400B500B600B703880389038A00BB038C00BD038E038F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-00800081201A0192201E20262020202102C62030016020390152008D008E008F
+20AC0081201A0192201E20262020202102C62030016020390152008D008E008F
009020182019201C201D20222013201402DC21220161203A0153009D009E0178
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-00800081201A0192201E20262020202102C62030008A2039008C008D008E008F
+20AC0081201A0192201E20262020202102C62030008A2039008C008D008E008F
009020182019201C201D20222013201402DC2122009A203A009C009D009E009F
-00A0000000A200A320AA00A500A600A700A800A9000000AB00AC00AD00AE00AF
-00B000B100B200B300B400B500B600B7000000B9000000BB00BC00BD00BE0000
-05B005B105B205B305B405B505B605B705B805B905BA05BB05BC05BD05BE05BF
-05C005C105C205C305F005F105F2000000000000000000000000000000000000
+00A000A100A200A320AA00A500A600A700A800A900D700AB00AC00AD00AE00AF
+00B000B100B200B300B400B500B600B700B800B900F700BB00BC00BD00BE00BF
+05B005B105B205B305B405B505B605B705B805B9000005BB05BC05BD05BE05BF
+05C005C105C205C305F005F105F205F305F40000000000000000000000000000
05D005D105D205D305D405D505D605D705D805D905DA05DB05DC05DD05DE05DF
05E005E105E205E305E405E505E605E705E805E905EA00000000200E200F0000
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080067E201A0192201E20262020202102C62030008A2039015206860698008F
-06AF20182019201C201D20222013201400982122009A203A0153200C200D009F
-00A0060C00A200A300A400A500A600A700A800A9000000AB00AC00AD00AE00AF
+20AC067E201A0192201E20262020202102C62030067920390152068606980688
+06AF20182019201C201D20222013201406A921220691203A0153200C200D06BA
+00A0060C00A200A300A400A500A600A700A800A906BE00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B9061B00BB00BC00BD00BE061F
-0000062106220623062406250626062706280629062A062B062C062D062E062F
+06C1062106220623062406250626062706280629062A062B062C062D062E062F
063006310632063306340635063600D7063706380639063A0640064106420643
00E0064400E2064506460647064800E700E800E900EA00EB0649064A00EE00EF
-064B064C064D064E00F4064F065000F7065100F9065200FB00FC200E200F0000
+064B064C064D064E00F4064F065000F7065100F9065200FB00FC200E200F06D2
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-00800081201A0083201E20262020202100882030008A2039008C00A802C700B8
+20AC0081201A0083201E20262020202100882030008A2039008C00A802C700B8
009020182019201C201D20222013201400982122009A203A009C00AF02DB009F
00A0000000A200A300A4000000A600A700D800A9015600AB00AC00AD00AE00C6
00B000B100B200B300B400B500B600B700F800B9015700BB00BC00BD00BE00E6
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-00800081201A0192201E20262020202102C62030008A20390152008D008E008F
+20AC0081201A0192201E20262020202102C62030008A20390152008D008E008F
009020182019201C201D20222013201402DC2122009A203A0153009D009E0178
00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF
-00C000C100C2010200C400C500C600C700C800C900CA00CB034000CD00CE00CF
+00C000C100C2010200C400C500C600C700C800C900CA00CB030000CD00CE00CF
011000D1030900D300D401A000D600D700D800D900DA00DB00DC01AF030300DF
-00E000E100E2010300E400E500E600E700E800E900EA00EB034100ED00EE00EF
+00E000E100E2010300E400E500E600E700E800E900EA00EB030100ED00EE00EF
011100F1032300F300F401A100F600F700F800F900FA00FB00FC01B020AB00FF
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080008100820083008420260086008700880089008A008B008C008D008E008F
+20AC008100820083008420260086008700880089008A008B008C008D008E008F
009020182019201C201D20222013201400980099009A009B009C009D009E009F
00A00E010E020E030E040E050E060E070E080E090E0A0E0B0E0C0E0D0E0E0E0F
0E100E110E120E130E140E150E160E170E180E190E1A0E1B0E1C0E1D0E1E0E1F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
-0080000000000000000000000000000000000000000000000000000000000000
+20AC000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
02D0222E2211220F00A42109203025C125C025B725B626642660266126652667
2663229925C825A325D025D1259225A425A525A825A725A625A92668260F260E
261C261E00B62020202121952197219921962198266D2669266A266C327F321C
-211633C7212233C233D821210000000000000000000000000000000000000000
+211633C7212233C233D8212120AC00AE00000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
A3
0000000000000000000000000000000000000000000000000000000000000000
311F312031213122312331243125312631273128312902D902C902CA02C702CB
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
-0000000000000000000000000000000000000000000000000000000000000000
+000020AC00000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000000000
A4
0000000000000000000000000000000000000000000000000000000000000000
final {}
iso8859-1 \x1b(B
jis0201 \x1b(J
-jis0208 \x1b$@
jis0208 \x1b$B
+jis0208 \x1b$@
jis0212 \x1b$(D
gb2312 \x1b$A
ksc5601 \x1b$(C
iso8859-1 \x1b(B
jis0201 \x1b(J
gb1988 \x1b(T
-jis0208 \x1b$@
jis0208 \x1b$B
+jis0208 \x1b$@
jis0212 \x1b$(D
gb2312 \x1b$A
ksc5601 \x1b$(C
jis0208 \x1b&@\x1b$B
-
-
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
-0660066106620663066406650666066706680669003A003B003C003D003E003F
+0030003100320033003400350036003700380039003A003B003C003D003E003F
0040004100420043004400450046004700480049004A004B004C004D004E004F
0050005100520053005400550056005700580059005A005B005C005D005E005F
0060006100620063006400650066006700680069006A006B006C006D006E006F
0070007100720073007400750076007700780079007A007B007C007D007E007F
0080008100820083008400850086008700880089008A008B008C008D008E008F
0090009100920093009400950096009700980099009A009B009C009D009E009F
-00A002BD02BC00A30000000000A600A700A800A9000000AB00AC00AD00002015
+00A02018201900A30000000000A600A700A800A9000000AB00AC00AD00002015
00B000B100B200B303840385038600B703880389038A00BB038C00BD038E038F
0390039103920393039403950396039703980399039A039B039C039D039E039F
03A003A1000003A303A403A503A603A703A803A903AA03AB03AC03AD03AE03AF
0070007100720073007400750076007700780079007A007B007C007D007E007F
0080008100820083008400850086008700880089008A008B008C008D008E008F
0090009100920093009400950096009700980099009A009B009C009D009E009F
-00A0000000A200A300A400A500A600A700A800A900D700AB00AC00AD00AE203E
+00A0000000A200A300A400A500A600A700A800A900D700AB00AC00AD00AE00AF
00B000B100B200B300B400B500B600B700B800B900F700BB00BC00BD00BE0000
0000000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000002017
05D005D105D205D305D405D505D605D705D805D905DA05DB05DC05DD05DE05DF
-05E005E105E205E305E405E505E605E705E805E905EA00000000000000000000
+05E005E105E205E305E405E505E605E705E805E905EA00000000200E200F0000
-# Encoding file: koi8-u, single-byte
-S
-003F 0 1
-00
+# Encoding file: koi8-u, single-byte
+S
+003F 0 1
+00
0000000100020003000400050006000700080009000A000B000C000D000E000F
0010001100120013001400150016001700180019001A001B001C001D001E001F
0020002100220023002400250026002700280029002A002B002C002D002E002F
00C400C500C700C900D100D600DC00E100E000E200E400E300E500E700E900E8
00EA00EB00ED00EC00EE00EF00F100F300F200F400F600F500FA00F900FB00FC
202000B000A200A300A7202200B600DF00AE0160212200B400A82260017D00D8
-221E00B122642265220600B522022211220F0161222B00AA00BA2126017E00F8
+221E00B122642265220600B522022211220F0161222B00AA00BA03A9017E00F8
00BF00A100AC221A01922248010600AB010C202600A000C000C300D501520153
-01102014201C201D2018201900F725CAF8FF00A9204400A42039203A00C600BB
+01102014201C201D2018201900F725CAF8FF00A9204420AC2039203A00C600BB
201300B7201A201E203000C2010700C1010D00C800CD00CE00CF00CC00D300D4
011100D200DA00DB00D9013102C602DC00AF03C000CB02DA00B800CA00E602C7
0070007100720073007400750076007700780079007A007B007C007D007E007F
0410041104120413041404150416041704180419041A041B041C041D041E041F
0420042104220423042404250426042704280429042A042B042C042D042E042F
-202000B000A200A300A7202200B6040600AE00A9212204020452226004030453
-221E00B122642265045600B522020408040404540407045704090459040A045A
+202000B0049000A300A7202200B6040600AE00A9212204020452226004030453
+221E00B122642265045600B504910408040404540407045704090459040A045A
0458040500AC221A01922248220600AB00BB202600A0040B045B040C045C0455
20132014201C201D2018201900F7201E040E045E040F045F211604010451044F
0430043104320433043404350436043704380439043A043B043C043D043E043F
-0440044104420443044404450446044704480449044A044B044C044D044E00A4
+0440044104420443044404450446044704480449044A044B044C044D044E20AC
0070007100720073007400750076007700780079007A007B007C007D007E007F
00C400B900B200C900B300D600DC038500E000E200E4038400A800E700E900E8
00EA00EB00A3212200EE00EF202200BD203000F400F600A600AD00F900FB00FC
-2020039303940398039B039E03A000DF00AE00A903A303AA00A7226000B00387
+2020039303940398039B039E03A000DF00AE00A903A303AA00A7226000B000B7
039100B12264226500A503920395039603970399039A039C03A603AB03A803A9
03AC039D00AC039F03A1224803A400AB00BB202600A003A503A7038603880153
20132015201C201D2018201900F70389038A038C038E03AD03AE03AF03CC038F
00C400C500C700C900D100D600DC00E100E000E200E400E300E500E700E900E8
00EA00EB00ED00EC00EE00EF00F100F300F200F400F600F500FA00F900FB00FC
00DD00B000A200A300A7202200B600DF00AE00A9212200B400A8226000C600D8
-221E00B12264226500A500B522022211220F03C0222B00AA00BA212600E600F8
+221E00B12264226500A500B522022211220F03C0222B00AA00BA03A900E600F8
00BF00A100AC221A01922248220600AB00BB202600A000C000C300D501520153
-20132014201C201D2018201900F725CA00FF0178204400A400D000F000DE00FE
+20132014201C201D2018201900F725CA00FF0178204420AC00D000F000DE00FE
00FD00B7201A201E203000C200CA00C100CB00C800CD00CE00CF00CC00D300D4
F8FF00D200DA00DB00D9013102C602DC00AF02D802D902DA00B802DD02DB02C7
00C400C500C700C900D100D600DC00E100E000E200E400E300E500E700E900E8
00EA00EB00ED00EC00EE00EF00F100F300F200F400F600F500FA00F900FB00FC
202000B000A200A300A7202200B600DF00AE00A9212200B400A8226000C600D8
-221E00B12264226500A500B522022211220F03C0222B00AA00BA212600E600F8
+221E00B12264226500A500B522022211220F03C0222B00AA00BA03A900E600F8
00BF00A100AC221A01922248220600AB00BB202600A000C000C300D501520153
-20132014201C201D2018201900F725CA00FF0178204400A42039203AFB01FB02
+20132014201C201D2018201900F725CA00FF0178204420AC2039203AFB01FB02
202100B7201A201E203000C200CA00C100CB00C800CD00CE00CF00CC00D300D4
F8FF00D200DA00DB00D9013102C602DC00AF02D802D902DA00B802DD02DB02C7
00C400C500C700C900D100D600DC00E100E000E200E400E300E500E700E900E8
00EA00EB00ED00EC00EE00EF00F100F300F200F400F600F500FA00F900FB00FC
202000B000A200A300A7202200B600DF00AE00A9212200B400A8226000C600D8
-221E00B12264226500A500B522022211220F03C0222B00AA00BA212600E600F8
+221E00B12264226500A500B522022211220F03C0222B00AA00BA03A900E600F8
00BF00A100AC221A01922248220600AB00BB202600A000C000C300D501520153
20132014201C201D2018201900F725CA00FF0178011E011F01300131015E015F
202100B7201A201E203000C200CA00C100CB00C800CD00CE00CF00CC00D300D4
proc tcl::HistAdd {command {exec {}}} {
variable history
+
+ # Do not add empty commands to the history
+ if {[string trim $command] == ""} {
+ return ""
+ }
+
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
set i [HistIndex $event]
set history($i) $cmd
}
-
set state(status) error
}
}
- if {[info exist state(-command)]} {
+ if {[info exists state(-command)]} {
# Command callback may already have unset our state
unset state(-command)
}
proc http::cleanup {token} {
variable $token
upvar 0 $token state
- if {[info exist state]} {
+ if {[info exists state]} {
unset state
}
}
+++ /dev/null
-# 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.
-#
-# See the file "license.terms" for information on usage and
-# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id$
-
-package provide http 2.0 ;# This uses Tcl namespaces
-
-namespace eval http {
- variable http
-
- array set http {
- -accept */*
- -proxyhost {}
- -proxyport {}
- -useragent {Tcl http client package 2.0}
- -proxyfilter http::ProxyRequired
- }
-
- variable formMap
- set alphanumeric a-zA-Z0-9
-
- for {set i 1} {$i <= 256} {incr i} {
- set c [format %c $i]
- if {![string match \[$alphanumeric\] $c]} {
- set formMap($c) %[format %.2x $i]
- }
- }
- # These are handled specially
- array set formMap {
- " " + \n %0d%0a
- }
-
- namespace export geturl config reset wait formatQuery
- # Useful, but not exported: data size status code
-}
-
-# http::config --
-#
-# See documentaion for details.
-#
-# Arguments:
-# args Options parsed by the procedure.
-# Results:
-# TODO
-
-proc http::config {args} {
- variable 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 http::Finish { token {errormsg ""} } {
- variable $token
- 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)
- }
-}
-
-# http::reset --
-#
-# See documentaion for details.
-#
-# Arguments:
-# token Connection token.
-# why Status info.
-# Results:
-# TODO
-
-proc http::reset { token {why reset} } {
- variable $token
- upvar 0 $token state
- set state(status) $why
- catch {fileevent $state(sock) readable {}}
- Finish $token
- if {[info exists state(error)]} {
- set errorlist $state(error)
- unset state(error)
- eval error $errorlist
- }
-}
-
-# http::geturl --
-#
-# Establishes a connection to a remote url via http.
-#
-# Arguments:
-# url The http URL to goget.
-# args Option value pairs. Valid options include:
-# -blocksize, -validate, -headers, -timeout
-# Results:
-# Returns a token for this connection.
-
-
-proc http::geturl { url args } {
- variable http
- if {![info exists http(uid)]} {
- set http(uid) 0
- }
- set token [namespace current]::[incr http(uid)]
- variable $token
- upvar 0 $token state
- 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 $srvurl] == 0} {
- set srvurl /
- }
- 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 http::Event $token]
- if {! [info exists state(-command)]} {
- wait $token
- }
- return $token
-}
-
-# Data access functions:
-# Data - the URL data
-# Status - the transaction status: ok, reset, eof, timeout
-# Code - the HTTP transaction code, e.g., 200
-# Size - the size of the URL data
-
-proc http::data {token} {
- variable $token
- upvar 0 $token state
- return $state(body)
-}
-proc http::status {token} {
- variable $token
- upvar 0 $token state
- return $state(status)
-}
-proc http::code {token} {
- variable $token
- upvar 0 $token state
- return $state(http)
-}
-proc http::size {token} {
- variable $token
- upvar 0 $token state
- return $state(currentsize)
-}
-
- proc http::Event {token} {
- variable $token
- upvar 0 $token state
- set s $state(sock)
-
- if {[::eof $s]} {
- Eof $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)]} {
- fconfigure $state(-channel) -translation binary
- }
- }
- if {[info exists state(-channel)] &&
- ![info exists state(-handler)]} {
- # Initiate a sequence of background fcopies
- fileevent $s readable {}
- CopyStart $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]} {
- Finish $token $err
- } else {
- if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
- }
- }
- }
-}
- proc http::CopyStart {s token} {
- variable $token
- upvar 0 $token state
- if {[catch {
- fcopy $s $state(-channel) -size $state(-blocksize) -command \
- [list http::CopyDone $token]
- } err]} {
- Finish $token $err
- }
-}
- proc http::CopyDone {token count {error {}}} {
- variable $token
- 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 {([string length $error] != 0)} {
- Finish $token $error
- } elseif {[::eof $s]} {
- Eof $token
- } else {
- CopyStart $s $token
- }
-}
- proc http::Eof {token} {
- variable $token
- upvar 0 $token state
- if {$state(state) == "header"} {
- # Premature eof
- set state(status) eof
- } else {
- set state(status) ok
- }
- set state(state) eof
- Finish $token
-}
-
-# http::wait --
-#
-# See documentaion for details.
-#
-# Arguments:
-# token Connection token.
-# Results:
-# The status after the wait.
-
-proc http::wait {token} {
- variable $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)
-}
-
-# http::formatQuery --
-#
-# See documentaion for details.
-# 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.
-#
-# Arguments:
-# args A list of name-value pairs.
-# Results:
-# TODO
-
-proc http::formatQuery {args} {
- set result ""
- set sep ""
- foreach i $args {
- append result $sep [mapReply $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 http::mapReply {string} {
- variable formMap
- set alphanumeric a-zA-Z0-9
- regsub -all \[^$alphanumeric\] $string {$formMap(&)} string
- regsub -all \n $string {\\n} string
- regsub -all \t $string {\\t} string
- regsub -all {[][{})\\]\)} $string {\\&} string
- return [subst $string]
-}
-
-# Default proxy filter.
- proc http::ProxyRequired {host} {
- variable 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 {}
- }
-}
+++ /dev/null
-# 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 http 2.0 [list tclPkgSetup $dir http 2.0 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait}}}]
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
-package require -exact Tcl 8.3
+package require -exact Tcl 8.4
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
# The parent directory of tcl_library. Adding the parent
# means that packages in peer directories will be found automatically.
#
-# Also add the directory where the executable is located, plus ../lib
-# relative to that path.
+# Also add the directory ../lib relative to the directory where the
+# executable is located. This is meant to find binary packages for the
+# same architecture as the current executable.
#
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Macintosh it is "Tool Command Language" in the Extensions folder
if {![info exists auto_path]} {
- if {[info exist env(TCLLIBPATH)]} {
+ if {[info exists env(TCLLIBPATH)]} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
-if {[string compare [info library] {}]} {
- foreach __dir [list [info library] [file dirname [info library]]] {
- if {[lsearch -exact $auto_path $__dir] < 0} {
- lappend auto_path $__dir
+namespace eval tcl {
+ variable Dir
+ if {[string compare [info library] {}]} {
+ foreach Dir [list [info library] [file dirname [info library]]] {
+ if {[lsearch -exact $::auto_path $Dir] < 0} {
+ lappend ::auto_path $Dir
+ }
}
}
-}
-set __dir [file join [file dirname [file dirname \
- [info nameofexecutable]]] lib]
-if {[lsearch -exact $auto_path $__dir] < 0} {
- lappend auto_path $__dir
-}
-if {[info exist tcl_pkgPath]} {
- foreach __dir $tcl_pkgPath {
- if {[lsearch -exact $auto_path $__dir] < 0} {
- lappend auto_path $__dir
+ set Dir [file join [file dirname [file dirname \
+ [info nameofexecutable]]] lib]
+ if {[lsearch -exact $::auto_path $Dir] < 0} {
+ lappend ::auto_path $Dir
+ }
+ if {[info exists ::tcl_pkgPath]} {
+ foreach Dir $::tcl_pkgPath {
+ if {[lsearch -exact $::auto_path $Dir] < 0} {
+ lappend ::auto_path $Dir
+ }
}
}
}
-if {[info exists __dir]} {
- unset __dir
-}
# Windows specific end of initialization
if {(![interp issafe]) && [string equal $tcl_platform(platform) "windows"]} {
namespace eval tcl {
- proc envTraceProc {lo n1 n2 op} {
+ 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 {[string compare $u $p]} {
- switch -- $u {
- COMSPEC -
- PATH {
- if {![info exists env($u)]} {
- set env($u) $env($p)
+ proc InitWinEnv {} {
+ global env tcl_platform
+ foreach p [array names env] {
+ set u [string toupper $p]
+ if {[string compare $u $p]} {
+ switch -- $u {
+ COMSPEC -
+ PATH {
+ if {![info exists env($u)]} {
+ set env($u) $env($p)
+ }
+ trace variable env($p) w \
+ [namespace code [list EnvTraceProc $p]]
+ trace variable env($u) w \
+ [namespace code [list EnvTraceProc $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 {[string equal $tcl_platform(os) "Windows NT"]} {
+ set env(COMSPEC) cmd.exe
+ } else {
+ set env(COMSPEC) command.com
}
}
}
- }
- if {[info exists p]} {
- unset p
- }
- if {[info exists u]} {
- unset u
- }
- if {![info exists env(COMSPEC)]} {
- if {[string equal $tcl_platform(os) "Windows NT"]} {
- set env(COMSPEC) cmd.exe
- } else {
- set env(COMSPEC) command.com
- }
+ InitWinEnv
}
}
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
- if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
+ if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
set arglist [lrange $args 1 end]
- set ret [catch {uplevel $cmd $arglist} result]
+ set ret [catch {uplevel 1 ::$cmd $arglist} result]
if {$ret == 0} {
return $result
} else {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
- set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
+ set ret [catch {auto_load $name [uplevel 1 {::namespace current}]} msg]
unset unknown_pending($name);
if {$ret != 0} {
append errorInfo "\n (autoloading \"$name\")"
set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
- # Strip the last five lines off the error stack (they're
- # from the "uplevel" command).
+ # Compute stack trace contribution from the [uplevel].
+ # Note the dependence on how Tcl_AddErrorInfo, etc.
+ # construct the stack trace.
#
-
- set new [split $errorInfo \n]
- set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
+ set cinfo $args
+ if {[string length $cinfo] > 150} {
+ set cinfo "[string range $cinfo 0 149]..."
+ }
+ append cinfo "\"\n (\"uplevel\" body line 1)"
+ append cinfo "\n invoked from within"
+ append cinfo "\n\"uplevel 1 \$args\""
+ #
+ # Try each possible form of the stack trace
+ # and trim the extra contribution from the matching case
+ #
+ set expect "$msg\n while executing\n\"$cinfo"
+ if {$errorInfo eq $expect} {
+ #
+ # The stack has only the eval from the expanded command
+ # Do not generate any stack trace here.
+ #
+ return -code error -errorcode $errorCode $msg
+ }
+ #
+ # Stack trace is nested, trim off just the contribution
+ # from the extra "eval" of $args due to the "catch" above.
+ #
+ set expect "\n invoked from within\n\"$cinfo"
+ set exlen [string length $expect]
+ set eilen [string length $errorInfo]
+ set i [expr {$eilen - $exlen - 1}]
+ set einfo [string range $errorInfo 0 $i]
+ #
+ # For now verify that $errorInfo consists of what we are about
+ # to return plus what we expected to trim off.
+ #
+ if {$errorInfo ne "$einfo$expect"} {
+ error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
+ [list CORE UNKNOWN BADTRACE $expect $errorInfo]
+ }
return -code error -errorcode $errorCode \
- -errorinfo $new $msg
+ -errorinfo $einfo $msg
} else {
return -code $code $msg
}
if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
}
- return [uplevel exec $redir $new [lrange $args 1 end]]
+ return [uplevel 1 exec $redir $new [lrange $args 1 end]]
}
}
set errorCode $savedErrorCode
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
- return [uplevel $newcmd]
+ return [uplevel 1 $newcmd]
}
set ret [catch {set cmds [info commands $name*]} msg]
"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
}
if {[llength $cmds] == 1} {
- return [uplevel [lreplace $args 0 0 $cmds]]
+ return [uplevel 1 [lreplace $args 0 0 $cmds]]
}
if {[llength $cmds]} {
if {[string equal $name ""]} {
global auto_index auto_oldpath auto_path
if {[string length $namespace] == 0} {
- set namespace [uplevel {namespace current}]
+ set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
# workaround non canonical auto_index entries that might be around
return
}
- set ns [uplevel namespace current]
+ set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
- foreach name [array names auto_index] {
- if {[string match $pattern $name] && \
- [string equal "" [info commands $name]]} {
+ foreach name [array names auto_index $pattern] {
+ if {[string equal "" [info commands $name]]
+ && [string equal [namespace qualifiers $pattern] \
+ [namespace qualifiers $name]]} {
uplevel #0 $auto_index($name)
}
}
# NT includes the 'start' built-in
lappend shellBuiltins "start"
}
+ if {[info exists env(PATHEXT)]} {
+ # Add an initial ; to have the {} extension check first.
+ set execExtensions [split ";$env(PATHEXT)" ";"]
+ } else {
+ set execExtensions [list {} .com .exe .bat]
+ }
if {[lsearch -exact $shellBuiltins $name] != -1} {
- return [set auto_execs($name) [list $env(COMSPEC) /c $name]]
+ # When this is command.com for some reason on Win2K, Tcl won't
+ # exec it unless the case is right, which this corrects. COMSPEC
+ # may not point to a real file, so do the check.
+ set cmd $env(COMSPEC)
+ if {[file exists $cmd]} {
+ set cmd [file attributes $cmd -shortname]
+ }
+ return [set auto_execs($name) [list $cmd /c $name]]
}
if {[llength [file split $name]] != 1} {
- foreach ext {{} .com .exe .bat} {
+ foreach ext $execExtensions {
set file ${name}${ext}
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
# Skip already checked directories
if {[info exists checked($dir)] || [string equal {} $dir]} { continue }
set checked($dir) {}
- foreach ext {{} .com .exe .bat} {
+ foreach ext $execExtensions {
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
+# ::tcl::CopyDirectory --
+#
+# This procedure is called by Tcl's core when attempts to call the
+# filesystem's copydirectory function fail. The semantics of the call
+# are that 'dest' does not yet exist, i.e. dest should become the exact
+# image of src. If dest does exist, we throw an error.
+#
+# Note that making changes to this procedure can change the results
+# of running Tcl's tests.
+#
+# Arguments:
+# action - "renaming" or "copying"
+# src - source directory
+# dest - destination directory
+proc tcl::CopyDirectory {action src dest} {
+ set nsrc [file normalize $src]
+ set ndest [file normalize $dest]
+ if {[string equal $action "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} {
+ return -code error "error $action \"$src\" to\
+ \"$dest\": trying to rename a volume or move a directory\
+ into itself"
+ }
+ }
+ if {[file exists $dest]} {
+ if {$nsrc == $ndest} {
+ return -code error "error $action \"$src\" to\
+ \"$dest\": trying to rename a volume or move a directory\
+ into itself"
+ }
+ if {[string equal $action "copying"]} {
+ return -code error "error $action \"$src\" to\
+ \"$dest\": file already exists"
+ } else {
+ # Depending on the platform, and on the current
+ # working directory, the directories '.', '..'
+ # can be returned in various combinations. Anyway,
+ # if any other file is returned, we must signal an error.
+ set existing [glob -nocomplain -directory $dest * .*]
+ eval [list lappend existing] \
+ [glob -nocomplain -directory $dest -type hidden * .*]
+ foreach s $existing {
+ if {([file tail $s] != ".") && ([file tail $s] != "..")} {
+ return -code error "error $action \"$src\" to\
+ \"$dest\": file already exists"
+ }
+ }
+ }
+ } else {
+ if {[string first $nsrc $ndest] != -1} {
+ set srclen [expr {[llength [file split $nsrc]] -1}]
+ set ndest [lindex [file split $ndest] $srclen]
+ if {$ndest == [file tail $nsrc]} {
+ return -code error "error $action \"$src\" to\
+ \"$dest\": trying to rename a volume or move a directory\
+ into itself"
+ }
+ }
+ file mkdir $dest
+ }
+ # Have to be careful to capture both visible and hidden files.
+ # We will also be more generous to the file system and not
+ # assume the hidden and non-hidden lists are non-overlapping.
+ #
+ # On Unix 'hidden' files begin with '.'. On other platforms
+ # or filesystems hidden files may have other interpretations.
+ set filelist [concat [glob -nocomplain -directory $src *] \
+ [glob -nocomplain -directory $src -types hidden *]]
+
+ foreach s [lsort -unique $filelist] {
+ if {([file tail $s] != ".") && ([file tail $s] != "..")} {
+ file copy $s [file join $dest [file tail $s]]
+ }
+ }
+ return
+}
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 { CONST char * symbol;} \n
append C {
{
int i;
This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation and other parties. The following terms apply to all files
+associated with the software unless explicitly disclaimed in
+individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
+++ /dev/null
-# msgcat.tcl --
-#
-# This file defines various procedures which implement a
-# message catalog facility for Tcl programs. It should be
-# loaded with the command "package require msgcat".
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# Copyright (c) 1998 by Mark Harrison.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id$
-
-package provide msgcat 1.1
-
-namespace eval msgcat {
- namespace export mc mcset mclocale mcpreferences mcunknown
-
- # Records the current locale as passed to mclocale
- variable locale ""
-
- # Records the list of locales to search
- variable loclist {}
-
- # Records the mapping between source strings and translated strings. The
- # array key is of the form "<locale>,<namespace>,<src>" and the value is
- # the translated string.
- array set msgs {}
-}
-
-# msgcat::mc --
-#
-# Find the translation for the given string based on the current
-# locale setting. Check the local namespace first, then look in each
-# parent namespace until the source is found. If additional args are
-# specified, use the format command to work them into the traslated
-# string.
-#
-# Arguments:
-# src The string to translate.
-# args Args to pass to the format command
-#
-# Results:
-# Returns the translatd string. Propagates errors thrown by the
-# format command.
-
-proc msgcat::mc {src args} {
- # Check for the src in each namespace starting from the local and
- # ending in the global.
-
- set ns [uplevel {namespace current}]
-
- while {$ns != ""} {
- foreach loc $::msgcat::loclist {
- if {[info exists ::msgcat::msgs($loc,$ns,$src)]} {
- if {[llength $args] == 0} {
- return $::msgcat::msgs($loc,$ns,$src)
- } else {
- return [eval \
- [list format $::msgcat::msgs($loc,$ns,$src)] \
- $args]
- }
- }
- }
- set ns [namespace parent $ns]
- }
- # we have not found the translation
- return [uplevel 1 [list [namespace origin mcunknown] \
- $::msgcat::locale $src] $args]
-}
-
-# msgcat::mclocale --
-#
-# Query or set the current locale.
-#
-# Arguments:
-# newLocale (Optional) The new locale string. Locale strings
-# should be composed of one or more sublocale parts
-# separated by underscores (e.g. en_US).
-#
-# Results:
-# Returns the current locale.
-
-proc msgcat::mclocale {args} {
- set len [llength $args]
-
- if {$len > 1} {
- error {wrong # args: should be "mclocale ?newLocale?"}
- }
-
- set args [string tolower $args]
- if {$len == 1} {
- set ::msgcat::locale $args
- set ::msgcat::loclist {}
- set word ""
- foreach part [split $args _] {
- set word [string trimleft "${word}_${part}" _]
- set ::msgcat::loclist [linsert $::msgcat::loclist 0 $word]
- }
- }
- return $::msgcat::locale
-}
-
-# msgcat::mcpreferences --
-#
-# Fetch the list of locales used to look up strings, ordered from
-# most preferred to least preferred.
-#
-# Arguments:
-# None.
-#
-# Results:
-# Returns an ordered list of the locales preferred by the user.
-
-proc msgcat::mcpreferences {} {
- return $::msgcat::loclist
-}
-
-# msgcat::mcload --
-#
-# Attempt to load message catalogs for each locale in the
-# preference list from the specified directory.
-#
-# Arguments:
-# langdir The directory to search.
-#
-# Results:
-# Returns the number of message catalogs that were loaded.
-
-proc msgcat::mcload {langdir} {
- set x 0
- foreach p [::msgcat::mcpreferences] {
- set langfile [file join $langdir $p.msg]
- if {[file exists $langfile]} {
- incr x
- uplevel [list source $langfile]
- }
- }
- return $x
-}
-
-# msgcat::mcset --
-#
-# Set the translation for a given string in a specified locale.
-#
-# Arguments:
-# locale The locale to use.
-# src The source string.
-# dest (Optional) The translated string. If omitted,
-# the source string is used.
-#
-# Results:
-# Returns the new locale.
-
-proc msgcat::mcset {locale src {dest ""}} {
- if {[string equal $dest ""]} {
- set dest $src
- }
-
- set ns [uplevel {namespace current}]
-
- set ::msgcat::msgs([string tolower $locale],$ns,$src) $dest
- return $dest
-}
-
-# msgcat::mcunknown --
-#
-# This routine is called by msgcat::mc if a translation cannot
-# be found for a string. This routine is intended to be replaced
-# by an application specific routine for error reporting
-# purposes. The default behavior is to return the source string.
-# If additional args are specified, the format command will be used
-# to work them into the traslated string.
-#
-# Arguments:
-# locale The current locale.
-# src The string to be translated.
-# args Args to pass to the format command
-#
-# Results:
-# Returns the translated value.
-
-proc msgcat::mcunknown {locale src args} {
- if {[llength $args]} {
- return [eval [list format $src] $args]
- } else {
- return $src
- }
-}
-
-# Initialize the default locale
-
-namespace eval msgcat {
- # set default locale, try to get from environment
- if {[info exists ::env(LANG)]} {
- mclocale $::env(LANG)
- } else {
- mclocale "C"
- }
-}
-
+++ /dev/null
-package ifneeded msgcat 1.1 [list source [file join $dir msgcat.tcl]]
+++ /dev/null
-# optparse.tcl --
-#
-# (Private) option parsing package
-#
-# This might be documented and exported in 8.1
-# and some function hopefully moved to the C core for
-# efficiency, if there is enough demand. (mail! ;-)
-#
-# Author: Laurent Demailly - Laurent.Demailly@sun.com - dl@mail.box.eu.org
-#
-# Credits:
-# this is a complete 'over kill' rewrite by me, from a version
-# written initially with Brent Welch, itself initially
-# based on work with Steve Uhler. Thanks them !
-#
-# RCS: @(#) $Id$
-
-package provide opt 0.3
-
-namespace eval ::tcl {
-
- # Exported APIs
- namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
- OptProc OptProcArgGiven OptParse \
- Lassign Lvarpop Lvarset Lvarincr Lfirst \
- SetMax SetMin
-
-
-################# Example of use / 'user documentation' ###################
-
- proc OptCreateTestProc {} {
-
- # Defines ::tcl::OptParseTest as a test proc with parsed arguments
- # (can't be defined before the code below is loaded (before "OptProc"))
-
- # Every OptProc give usage information on "procname -help".
- # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
- # then other arguments.
- #
- # example of 'valid' call:
- # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
- # -nostatics false ch1
- OptProc OptParseTest {
- {subcommand -choice {save print} "sub command"}
- {arg1 3 "some number"}
- {-aflag}
- {-intflag 7}
- {-weirdflag "help string"}
- {-noStatics "Not ok to load static packages"}
- {-nestedloading1 true "OK to load into nested slaves"}
- {-nestedloading2 -boolean true "OK to load into nested slaves"}
- {-libsOK -choice {Tk SybTcl}
- "List of packages that can be loaded"}
- {-precision -int 12 "Number of digits of precision"}
- {-intval 7 "An integer"}
- {-scale -float 1.0 "Scale factor"}
- {-zoom 1.0 "Zoom factor"}
- {-arbitrary foobar "Arbitrary string"}
- {-random -string 12 "Random string"}
- {-listval -list {} "List value"}
- {-blahflag -blah abc "Funny type"}
- {arg2 -boolean "a boolean"}
- {arg3 -choice "ch1 ch2"}
- {?optarg? -list {} "optional argument"}
- } {
- foreach v [info locals] {
- puts stderr [format "%14s : %s" $v [set $v]]
- }
- }
- }
-
-################### No User serviceable part below ! ###############
-# You should really not look any further :
-# The following is private unexported undocumented unblessed... code
-# time to hit "q" ;-) !
-\f
-# Hmmm... ok, you really want to know ?
-\f
-# You've been warned... Here it is...
-
- # Array storing the parsed descriptions
- variable OptDesc;
- array set OptDesc {};
- # Next potentially free key id (numeric)
- variable OptDescN 0;
-
-# Inside algorithm/mechanism description:
-# (not for the faint hearted ;-)
-#
-# The argument description is parsed into a "program tree"
-# It is called a "program" because it is the program used by
-# the state machine interpreter that use that program to
-# actually parse the arguments at run time.
-#
-# The general structure of a "program" is
-# notation (pseudo bnf like)
-# name :== definition defines "name" as being "definition"
-# { x y z } means list of x, y, and z
-# x* means x repeated 0 or more time
-# x+ means "x x*"
-# x? means optionally x
-# x | y means x or y
-# "cccc" means the literal string
-#
-# program :== { programCounter programStep* }
-#
-# programStep :== program | singleStep
-#
-# programCounter :== {"P" integer+ }
-#
-# singleStep :== { instruction parameters* }
-#
-# instruction :== single element list
-#
-# (the difference between singleStep and program is that \
-# llength [Lfirst $program] >= 2
-# while
-# llength [Lfirst $singleStep] == 1
-# )
-#
-# And for this application:
-#
-# singleStep :== { instruction varname {hasBeenSet currentValue} type
-# typeArgs help }
-# instruction :== "flags" | "value"
-# type :== knowType | anyword
-# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
-# | "choice"
-#
-# for type "choice" typeArgs is a list of possible choices, the first one
-# is the default value. for all other types the typeArgs is the default value
-#
-# a "boolflag" is the type for a flag whose presence or absence, without
-# additional arguments means respectively true or false (default flag type).
-#
-# programCounter is the index in the list of the currently processed
-# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
-# If it is a list it points toward each currently selected programStep.
-# (like for "flags", as they are optional, form a set and programStep).
-
-# Performance/Implementation issues
-# ---------------------------------
-# We use tcl lists instead of arrays because with tcl8.0
-# they should start to be much faster.
-# But this code use a lot of helper procs (like Lvarset)
-# which are quite slow and would be helpfully optimized
-# for instance by being written in C. Also our struture
-# is complex and there is maybe some places where the
-# string rep might be calculated at great exense. to be checked.
-
-#
-# Parse a given description and saves it here under the given key
-# generate a unused keyid if not given
-#
-proc ::tcl::OptKeyRegister {desc {key ""}} {
- variable OptDesc;
- variable OptDescN;
- if {[string compare $key ""] == 0} {
- # in case a key given to us as a parameter was a number
- while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
- set key $OptDescN;
- incr OptDescN;
- }
- # program counter
- set program [list [list "P" 1]];
-
- # are we processing flags (which makes a single program step)
- set inflags 0;
-
- set state {};
-
- # flag used to detect that we just have a single (flags set) subprogram.
- set empty 1;
-
- foreach item $desc {
- if {$state == "args"} {
- # more items after 'args'...
- return -code error "'args' special argument must be the last one";
- }
- set res [OptNormalizeOne $item];
- set state [Lfirst $res];
- if {$inflags} {
- if {$state == "flags"} {
- # add to 'subprogram'
- lappend flagsprg $res;
- } else {
- # put in the flags
- # structure for flag programs items is a list of
- # {subprgcounter {prg flag 1} {prg flag 2} {...}}
- lappend program $flagsprg;
- # put the other regular stuff
- lappend program $res;
- set inflags 0;
- set empty 0;
- }
- } else {
- if {$state == "flags"} {
- set inflags 1;
- # sub program counter + first sub program
- set flagsprg [list [list "P" 1] $res];
- } else {
- lappend program $res;
- set empty 0;
- }
- }
- }
- if {$inflags} {
- if {$empty} {
- # We just have the subprogram, optimize and remove
- # unneeded level:
- set program $flagsprg;
- } else {
- lappend program $flagsprg;
- }
- }
-
- set OptDesc($key) $program;
-
- return $key;
-}
-
-#
-# Free the storage for that given key
-#
-proc ::tcl::OptKeyDelete {key} {
- variable OptDesc;
- unset OptDesc($key);
-}
-
- # Get the parsed description stored under the given key.
- proc OptKeyGetDesc {descKey} {
- variable OptDesc;
- if {![info exists OptDesc($descKey)]} {
- return -code error "Unknown option description key \"$descKey\"";
- }
- set OptDesc($descKey);
- }
-
-# Parse entry point for ppl who don't want to register with a key,
-# for instance because the description changes dynamically.
-# (otherwise one should really use OptKeyRegister once + OptKeyParse
-# as it is way faster or simply OptProc which does it all)
-# Assign a temporary key, call OptKeyParse and then free the storage
-proc ::tcl::OptParse {desc arglist} {
- set tempkey [OptKeyRegister $desc];
- set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res];
- OptKeyDelete $tempkey;
- return -code $ret $res;
-}
-
-# Helper function, replacement for proc that both
-# register the description under a key which is the name of the proc
-# (and thus unique to that code)
-# and add a first line to the code to call the OptKeyParse proc
-# Stores the list of variables that have been actually given by the user
-# (the other will be sets to their default value)
-# into local variable named "Args".
-proc ::tcl::OptProc {name desc body} {
- set namespace [uplevel namespace current];
- if { ([string match $name "::*"])
- || ([string compare $namespace "::"]==0)} {
- # absolute name or global namespace, name is the key
- set key $name;
- } else {
- # we are relative to some non top level namespace:
- set key "${namespace}::${name}";
- }
- OptKeyRegister $desc $key;
- uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
- return $key;
-}
-# Check that a argument has been given
-# assumes that "OptProc" has been used as it will check in "Args" list
-proc ::tcl::OptProcArgGiven {argname} {
- upvar Args alist;
- expr {[lsearch $alist $argname] >=0}
-}
-
- #######
- # Programs/Descriptions manipulation
-
- # Return the instruction word/list of a given step/(sub)program
- proc OptInstr {lst} {
- Lfirst $lst;
- }
- # Is a (sub) program or a plain instruction ?
- proc OptIsPrg {lst} {
- expr {[llength [OptInstr $lst]]>=2}
- }
- # Is this instruction a program counter or a real instr
- proc OptIsCounter {item} {
- expr {[Lfirst $item]=="P"}
- }
- # Current program counter (2nd word of first word)
- proc OptGetPrgCounter {lst} {
- Lget $lst {0 1}
- }
- # Current program counter (2nd word of first word)
- proc OptSetPrgCounter {lstName newValue} {
- upvar $lstName lst;
- set lst [lreplace $lst 0 0 [concat "P" $newValue]];
- }
- # returns a list of currently selected items.
- proc OptSelection {lst} {
- set res {};
- foreach idx [lrange [Lfirst $lst] 1 end] {
- lappend res [Lget $lst $idx];
- }
- return $res;
- }
-
- # Advance to next description
- proc OptNextDesc {descName} {
- uplevel [list Lvarincr $descName {0 1}];
- }
-
- # Get the current description, eventually descend
- proc OptCurDesc {descriptions} {
- lindex $descriptions [OptGetPrgCounter $descriptions];
- }
- # get the current description, eventually descend
- # through sub programs as needed.
- proc OptCurDescFinal {descriptions} {
- set item [OptCurDesc $descriptions];
- # Descend untill we get the actual item and not a sub program
- while {[OptIsPrg $item]} {
- set item [OptCurDesc $item];
- }
- return $item;
- }
- # Current final instruction adress
- proc OptCurAddr {descriptions {start {}}} {
- set adress [OptGetPrgCounter $descriptions];
- lappend start $adress;
- set item [lindex $descriptions $adress];
- if {[OptIsPrg $item]} {
- return [OptCurAddr $item $start];
- } else {
- return $start;
- }
- }
- # Set the value field of the current instruction
- proc OptCurSetValue {descriptionsName value} {
- upvar $descriptionsName descriptions
- # get the current item full adress
- set adress [OptCurAddr $descriptions];
- # use the 3th field of the item (see OptValue / OptNewInst)
- lappend adress 2
- Lvarset descriptions $adress [list 1 $value];
- # ^hasBeenSet flag
- }
-
- # empty state means done/paste the end of the program
- proc OptState {item} {
- Lfirst $item
- }
-
- # current state
- proc OptCurState {descriptions} {
- OptState [OptCurDesc $descriptions];
- }
-
- #######
- # Arguments manipulation
-
- # Returns the argument that has to be processed now
- proc OptCurrentArg {lst} {
- Lfirst $lst;
- }
- # Advance to next argument
- proc OptNextArg {argsName} {
- uplevel [list Lvarpop $argsName];
- }
- #######
-
-
-
-
-
- # Loop over all descriptions, calling OptDoOne which will
- # eventually eat all the arguments.
- proc OptDoAll {descriptionsName argumentsName} {
- upvar $descriptionsName descriptions
- upvar $argumentsName arguments;
-# puts "entered DoAll";
- # Nb: the places where "state" can be set are tricky to figure
- # because DoOne sets the state to flagsValue and return -continue
- # when needed...
- set state [OptCurState $descriptions];
- # We'll exit the loop in "OptDoOne" or when state is empty.
- while 1 {
- set curitem [OptCurDesc $descriptions];
- # Do subprograms if needed, call ourselves on the sub branch
- while {[OptIsPrg $curitem]} {
- OptDoAll curitem arguments
-# puts "done DoAll sub";
- # Insert back the results in current tree;
- Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
- $curitem;
- OptNextDesc descriptions;
- set curitem [OptCurDesc $descriptions];
- set state [OptCurState $descriptions];
- }
-# puts "state = \"$state\" - arguments=($arguments)";
- if {[Lempty $state]} {
- # Nothing left to do, we are done in this branch:
- break;
- }
- # The following statement can make us terminate/continue
- # as it use return -code {break, continue, return and error}
- # codes
- OptDoOne descriptions state arguments;
- # If we are here, no special return code where issued,
- # we'll step to next instruction :
-# puts "new state = \"$state\"";
- OptNextDesc descriptions;
- set state [OptCurState $descriptions];
- }
- }
-
- # Process one step for the state machine,
- # eventually consuming the current argument.
- proc OptDoOne {descriptionsName stateName argumentsName} {
- upvar $argumentsName arguments;
- upvar $descriptionsName descriptions;
- upvar $stateName state;
-
- # the special state/instruction "args" eats all
- # the remaining args (if any)
- if {($state == "args")} {
- if {![Lempty $arguments]} {
- # If there is no additional arguments, leave the default value
- # in.
- OptCurSetValue descriptions $arguments;
- set arguments {};
- }
-# puts "breaking out ('args' state: consuming every reminding args)"
- return -code break;
- }
-
- if {[Lempty $arguments]} {
- if {$state == "flags"} {
- # no argument and no flags : we're done
-# puts "returning to previous (sub)prg (no more args)";
- return -code return;
- } elseif {$state == "optValue"} {
- set state next; # not used, for debug only
- # go to next state
- return ;
- } else {
- return -code error [OptMissingValue $descriptions];
- }
- } else {
- set arg [OptCurrentArg $arguments];
- }
-
- switch $state {
- flags {
- # A non-dash argument terminates the options, as does --
-
- # Still a flag ?
- if {![OptIsFlag $arg]} {
- # don't consume the argument, return to previous prg
- return -code return;
- }
- # consume the flag
- OptNextArg arguments;
- if {[string compare "--" $arg] == 0} {
- # return from 'flags' state
- return -code return;
- }
-
- set hits [OptHits descriptions $arg];
- if {$hits > 1} {
- return -code error [OptAmbigous $descriptions $arg]
- } elseif {$hits == 0} {
- return -code error [OptFlagUsage $descriptions $arg]
- }
- set item [OptCurDesc $descriptions];
- if {[OptNeedValue $item]} {
- # we need a value, next state is
- set state flagValue;
- } else {
- OptCurSetValue descriptions 1;
- }
- # continue
- return -code continue;
- }
- flagValue -
- value {
- set item [OptCurDesc $descriptions];
- # Test the values against their required type
- if {[catch {OptCheckType $arg\
- [OptType $item] [OptTypeArgs $item]} val]} {
- return -code error [OptBadValue $item $arg $val]
- }
- # consume the value
- OptNextArg arguments;
- # set the value
- OptCurSetValue descriptions $val;
- # go to next state
- if {$state == "flagValue"} {
- set state flags
- return -code continue;
- } else {
- set state next; # not used, for debug only
- return ; # will go on next step
- }
- }
- optValue {
- set item [OptCurDesc $descriptions];
- # Test the values against their required type
- if {![catch {OptCheckType $arg\
- [OptType $item] [OptTypeArgs $item]} val]} {
- # right type, so :
- # consume the value
- OptNextArg arguments;
- # set the value
- OptCurSetValue descriptions $val;
- }
- # go to next state
- set state next; # not used, for debug only
- return ; # will go on next step
- }
- }
- # If we reach this point: an unknown
- # state as been entered !
- return -code error "Bug! unknown state in DoOne \"$state\"\
- (prg counter [OptGetPrgCounter $descriptions]:\
- [OptCurDesc $descriptions])";
- }
-
-# Parse the options given the key to previously registered description
-# and arguments list
-proc ::tcl::OptKeyParse {descKey arglist} {
-
- set desc [OptKeyGetDesc $descKey];
-
- # make sure -help always give usage
- if {[string compare "-help" [string tolower $arglist]] == 0} {
- return -code error [OptError "Usage information:" $desc 1];
- }
-
- OptDoAll desc arglist;
-
- if {![Lempty $arglist]} {
- return -code error [OptTooManyArgs $desc $arglist];
- }
-
- # Analyse the result
- # Walk through the tree:
- OptTreeVars $desc "#[expr {[info level]-1}]" ;
-}
-
- # determine string length for nice tabulated output
- proc OptTreeVars {desc level {vnamesLst {}}} {
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- set vnamesLst [OptTreeVars $item $level $vnamesLst];
- } else {
- set vname [OptVarName $item];
- upvar $level $vname var
- if {[OptHasBeenSet $item]} {
-# puts "adding $vname"
- # lets use the input name for the returned list
- # it is more usefull, for instance you can check that
- # no flags at all was given with expr
- # {![string match "*-*" $Args]}
- lappend vnamesLst [OptName $item];
- set var [OptValue $item];
- } else {
- set var [OptDefaultValue $item];
- }
- }
- }
- return $vnamesLst
- }
-
-
-# Check the type of a value
-# and emit an error if arg is not of the correct type
-# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
-proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
-# puts "checking '$arg' against '$type' ($typeArgs)";
-
- # only types "any", "choice", and numbers can have leading "-"
-
- switch -exact -- $type {
- int {
- if {![regexp {^(-+)?[0-9]+$} $arg]} {
- error "not an integer"
- }
- return $arg;
- }
- float {
- return [expr {double($arg)}]
- }
- script -
- list {
- # if llength fail : malformed list
- if {[llength $arg]==0} {
- if {[OptIsFlag $arg]} {
- error "no values with leading -"
- }
- }
- return $arg;
- }
- boolean {
- if {![regexp -nocase {^(true|false|0|1)$} $arg]} {
- error "non canonic boolean"
- }
- # convert true/false because expr/if is broken with "!,...
- if {$arg} {
- return 1
- } else {
- return 0
- }
- }
- choice {
- if {[lsearch -exact $typeArgs $arg] < 0} {
- error "invalid choice"
- }
- return $arg;
- }
- any {
- return $arg;
- }
- string -
- default {
- if {[OptIsFlag $arg]} {
- error "no values with leading -"
- }
- return $arg
- }
- }
- return neverReached;
-}
-
- # internal utilities
-
- # returns the number of flags matching the given arg
- # sets the (local) prg counter to the list of matches
- proc OptHits {descName arg} {
- upvar $descName desc;
- set hits 0
- set hitems {}
- set i 1;
-
- set larg [string tolower $arg];
- set len [string length $larg];
- set last [expr {$len-1}];
-
- foreach item [lrange $desc 1 end] {
- set flag [OptName $item]
- # lets try to match case insensitively
- # (string length ought to be cheap)
- set lflag [string tolower $flag];
- if {$len == [string length $lflag]} {
- if {[string compare $larg $lflag]==0} {
- # Exact match case
- OptSetPrgCounter desc $i;
- return 1;
- }
- } else {
- if {[string compare $larg [string range $lflag 0 $last]]==0} {
- lappend hitems $i;
- incr hits;
- }
- }
- incr i;
- }
- if {$hits} {
- OptSetPrgCounter desc $hitems;
- }
- return $hits
- }
-
- # Extract fields from the list structure:
-
- proc OptName {item} {
- lindex $item 1;
- }
- #
- proc OptHasBeenSet {item} {
- Lget $item {2 0};
- }
- #
- proc OptValue {item} {
- Lget $item {2 1};
- }
-
- proc OptIsFlag {name} {
- string match "-*" $name;
- }
- proc OptIsOpt {name} {
- string match {\?*} $name;
- }
- proc OptVarName {item} {
- set name [OptName $item];
- if {[OptIsFlag $name]} {
- return [string range $name 1 end];
- } elseif {[OptIsOpt $name]} {
- return [string trim $name "?"];
- } else {
- return $name;
- }
- }
- proc OptType {item} {
- lindex $item 3
- }
- proc OptTypeArgs {item} {
- lindex $item 4
- }
- proc OptHelp {item} {
- lindex $item 5
- }
- proc OptNeedValue {item} {
- string compare [OptType $item] boolflag
- }
- proc OptDefaultValue {item} {
- set val [OptTypeArgs $item]
- switch -exact -- [OptType $item] {
- choice {return [lindex $val 0]}
- boolean -
- boolflag {
- # convert back false/true to 0/1 because expr !$bool
- # is broken..
- if {$val} {
- return 1
- } else {
- return 0
- }
- }
- }
- return $val
- }
-
- # Description format error helper
- proc OptOptUsage {item {what ""}} {
- return -code error "invalid description format$what: $item\n\
- should be a list of {varname|-flagname ?-type? ?defaultvalue?\
- ?helpstring?}";
- }
-
-
- # Generate a canonical form single instruction
- proc OptNewInst {state varname type typeArgs help} {
- list $state $varname [list 0 {}] $type $typeArgs $help;
- # ^ ^
- # | |
- # hasBeenSet=+ +=currentValue
- }
-
- # Translate one item to canonical form
- proc OptNormalizeOne {item} {
- set lg [Lassign $item varname arg1 arg2 arg3];
-# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
- set isflag [OptIsFlag $varname];
- set isopt [OptIsOpt $varname];
- if {$isflag} {
- set state "flags";
- } elseif {$isopt} {
- set state "optValue";
- } elseif {[string compare $varname "args"]} {
- set state "value";
- } else {
- set state "args";
- }
-
- # apply 'smart' 'fuzzy' logic to try to make
- # description writer's life easy, and our's difficult :
- # let's guess the missing arguments :-)
-
- switch $lg {
- 1 {
- if {$isflag} {
- return [OptNewInst $state $varname boolflag false ""];
- } else {
- return [OptNewInst $state $varname any "" ""];
- }
- }
- 2 {
- # varname default
- # varname help
- set type [OptGuessType $arg1]
- if {[string compare $type "string"] == 0} {
- if {$isflag} {
- set type boolflag
- set def false
- } else {
- set type any
- set def ""
- }
- set help $arg1
- } else {
- set help ""
- set def $arg1
- }
- return [OptNewInst $state $varname $type $def $help];
- }
- 3 {
- # varname type value
- # varname value comment
-
- if {[regexp {^-(.+)$} $arg1 x type]} {
- # flags/optValue as they are optional, need a "value",
- # on the contrary, for a variable (non optional),
- # default value is pointless, 'cept for choices :
- if {$isflag || $isopt || ($type == "choice")} {
- return [OptNewInst $state $varname $type $arg2 ""];
- } else {
- return [OptNewInst $state $varname $type "" $arg2];
- }
- } else {
- return [OptNewInst $state $varname\
- [OptGuessType $arg1] $arg1 $arg2]
- }
- }
- 4 {
- if {[regexp {^-(.+)$} $arg1 x type]} {
- return [OptNewInst $state $varname $type $arg2 $arg3];
- } else {
- return -code error [OptOptUsage $item];
- }
- }
- default {
- return -code error [OptOptUsage $item];
- }
- }
- }
-
- # Auto magic lasy type determination
- proc OptGuessType {arg} {
- if {[regexp -nocase {^(true|false)$} $arg]} {
- return boolean
- }
- if {[regexp {^(-+)?[0-9]+$} $arg]} {
- return int
- }
- if {![catch {expr {double($arg)}}]} {
- return float
- }
- return string
- }
-
- # Error messages front ends
-
- proc OptAmbigous {desc arg} {
- OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
- }
- proc OptFlagUsage {desc arg} {
- OptError "bad flag \"$arg\", must be one of" $desc;
- }
- proc OptTooManyArgs {desc arguments} {
- OptError "too many arguments (unexpected argument(s): $arguments),\
- usage:"\
- $desc 1
- }
- proc OptParamType {item} {
- if {[OptIsFlag $item]} {
- return "flag";
- } else {
- return "parameter";
- }
- }
- proc OptBadValue {item arg {err {}}} {
-# puts "bad val err = \"$err\"";
- OptError "bad value \"$arg\" for [OptParamType $item]"\
- [list $item]
- }
- proc OptMissingValue {descriptions} {
-# set item [OptCurDescFinal $descriptions];
- set item [OptCurDesc $descriptions];
- OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
- (use -help for full usage) :"\
- [list $item]
- }
-
-proc ::tcl::OptKeyError {prefix descKey {header 0}} {
- OptError $prefix [OptKeyGetDesc $descKey] $header;
-}
-
- # determine string length for nice tabulated output
- proc OptLengths {desc nlName tlName dlName} {
- upvar $nlName nl;
- upvar $tlName tl;
- upvar $dlName dl;
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- OptLengths $item nl tl dl
- } else {
- SetMax nl [string length [OptName $item]]
- SetMax tl [string length [OptType $item]]
- set dv [OptTypeArgs $item];
- if {[OptState $item] != "header"} {
- set dv "($dv)";
- }
- set l [string length $dv];
- # limit the space allocated to potentially big "choices"
- if {([OptType $item] != "choice") || ($l<=12)} {
- SetMax dl $l
- } else {
- if {![info exists dl]} {
- set dl 0
- }
- }
- }
- }
- }
- # output the tree
- proc OptTree {desc nl tl dl} {
- set res "";
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- append res [OptTree $item $nl $tl $dl];
- } else {
- set dv [OptTypeArgs $item];
- if {[OptState $item] != "header"} {
- set dv "($dv)";
- }
- append res [format "\n %-*s %-*s %-*s %s" \
- $nl [OptName $item] $tl [OptType $item] \
- $dl $dv [OptHelp $item]]
- }
- }
- return $res;
- }
-
-# Give nice usage string
-proc ::tcl::OptError {prefix desc {header 0}} {
- # determine length
- if {$header} {
- # add faked instruction
- set h [list [OptNewInst header Var/FlagName Type Value Help]];
- lappend h [OptNewInst header ------------ ---- ----- ----];
- lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
- set desc [concat $h $desc]
- }
- OptLengths $desc nl tl dl
- # actually output
- return "$prefix[OptTree $desc $nl $tl $dl]"
-}
-
-
-################ General Utility functions #######################
-
-#
-# List utility functions
-# Naming convention:
-# "Lvarxxx" take the list VARiable name as argument
-# "Lxxxx" take the list value as argument
-# (which is not costly with Tcl8 objects system
-# as it's still a reference and not a copy of the values)
-#
-
-# Is that list empty ?
-proc ::tcl::Lempty {list} {
- expr {[llength $list]==0}
-}
-
-# Gets the value of one leaf of a lists tree
-proc ::tcl::Lget {list indexLst} {
- if {[llength $indexLst] <= 1} {
- return [lindex $list $indexLst];
- }
- Lget [lindex $list [Lfirst $indexLst]] [Lrest $indexLst];
-}
-# Sets the value of one leaf of a lists tree
-# (we use the version that does not create the elements because
-# it would be even slower... needs to be written in C !)
-# (nb: there is a non trivial recursive problem with indexes 0,
-# which appear because there is no difference between a list
-# of 1 element and 1 element alone : [list "a"] == "a" while
-# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
-# and [listp "a b"] maybe 0. listp does not exist either...)
-proc ::tcl::Lvarset {listName indexLst newValue} {
- upvar $listName list;
- if {[llength $indexLst] <= 1} {
- Lvarset1nc list $indexLst $newValue;
- } else {
- set idx [Lfirst $indexLst];
- set targetList [lindex $list $idx];
- # reduce refcount on targetList (not really usefull now,
- # could be with optimizing compiler)
-# Lvarset1 list $idx {};
- # recursively replace in targetList
- Lvarset targetList [Lrest $indexLst] $newValue;
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
- }
-}
-# Set one cell to a value, eventually create all the needed elements
-# (on level-1 of lists)
-variable emptyList {}
-proc ::tcl::Lvarset1 {listName index newValue} {
- upvar $listName list;
- if {$index < 0} {return -code error "invalid negative index"}
- set lg [llength $list];
- if {$index >= $lg} {
- variable emptyList;
- for {set i $lg} {$i<$index} {incr i} {
- lappend list $emptyList;
- }
- lappend list $newValue;
- } else {
- set list [lreplace $list $index $index $newValue];
- }
-}
-# same as Lvarset1 but no bound checking / creation
-proc ::tcl::Lvarset1nc {listName index newValue} {
- upvar $listName list;
- set list [lreplace $list $index $index $newValue];
-}
-# Increments the value of one leaf of a lists tree
-# (which must exists)
-proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
- upvar $listName list;
- if {[llength $indexLst] <= 1} {
- Lvarincr1 list $indexLst $howMuch;
- } else {
- set idx [Lfirst $indexLst];
- set targetList [lindex $list $idx];
- # reduce refcount on targetList
- Lvarset1nc list $idx {};
- # recursively replace in targetList
- Lvarincr targetList [Lrest $indexLst] $howMuch;
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
- }
-}
-# Increments the value of one cell of a list
-proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
- upvar $listName list;
- set newValue [expr {[lindex $list $index]+$howMuch}];
- set list [lreplace $list $index $index $newValue];
- return $newValue;
-}
-# Returns the first element of a list
-proc ::tcl::Lfirst {list} {
- lindex $list 0
-}
-# Returns the rest of the list minus first element
-proc ::tcl::Lrest {list} {
- lrange $list 1 end
-}
-# Removes the first element of a list
-proc ::tcl::Lvarpop {listName} {
- upvar $listName list;
- set list [lrange $list 1 end];
-}
-# Same but returns the removed element
-proc ::tcl::Lvarpop2 {listName} {
- upvar $listName list;
- set el [Lfirst $list];
- set list [lrange $list 1 end];
- return $el;
-}
-# Assign list elements to variables and return the length of the list
-proc ::tcl::Lassign {list args} {
- # faster than direct blown foreach (which does not byte compile)
- set i 0;
- set lg [llength $list];
- foreach vname $args {
- if {$i>=$lg} break
- uplevel [list set $vname [lindex $list $i]];
- incr i;
- }
- return $lg;
-}
-
-# Misc utilities
-
-# Set the varname to value if value is greater than varname's current value
-# or if varname is undefined
-proc ::tcl::SetMax {varname value} {
- upvar 1 $varname var
- if {![info exists var] || $value > $var} {
- set var $value
- }
-}
-
-# Set the varname to value if value is smaller than varname's current value
-# or if varname is undefined
-proc ::tcl::SetMin {varname value} {
- upvar 1 $varname var
- if {![info exists var] || $value < $var} {
- set var $value
- }
-}
-
-
- # everything loaded fine, lets create the test proc:
- OptCreateTestProc
- # Don't need the create temp proc anymore:
- rename OptCreateTestProc {}
-}
+++ /dev/null
-# Tcl package index file, version 1.0
-# This file is NOT generated by the "pkg_mkIndex" command
-# because if someone just did "package require opt", let's just load
-# the package now, so they can readily use it
-# and even "namespace import tcl::*" ...
-# (tclPkgSetup just makes things slow and do not work so well with namespaces)
-package ifneeded opt 0.3 [list source [file join $dir optparse.tcl]]
+++ /dev/null
-# optparse.tcl --
-#
-# (private) Option parsing package
-# Primarily used internally by the safe:: code.
-#
-# WARNING: This code will go away in a future release
-# of Tcl. It is NOT supported and you should not rely
-# on it. If your code does rely on this package you
-# may directly incorporate this code into your application.
-#
-# RCS: @(#) $Id$
-
-package provide opt 0.4.1
-
-namespace eval ::tcl {
-
- # Exported APIs
- namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
- OptProc OptProcArgGiven OptParse \
- Lempty Lget \
- Lassign Lvarpop Lvarpop1 Lvarset Lvarincr \
- SetMax SetMin
-
-
-################# Example of use / 'user documentation' ###################
-
- proc OptCreateTestProc {} {
-
- # Defines ::tcl::OptParseTest as a test proc with parsed arguments
- # (can't be defined before the code below is loaded (before "OptProc"))
-
- # Every OptProc give usage information on "procname -help".
- # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
- # then other arguments.
- #
- # example of 'valid' call:
- # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
- # -nostatics false ch1
- OptProc OptParseTest {
- {subcommand -choice {save print} "sub command"}
- {arg1 3 "some number"}
- {-aflag}
- {-intflag 7}
- {-weirdflag "help string"}
- {-noStatics "Not ok to load static packages"}
- {-nestedloading1 true "OK to load into nested slaves"}
- {-nestedloading2 -boolean true "OK to load into nested slaves"}
- {-libsOK -choice {Tk SybTcl}
- "List of packages that can be loaded"}
- {-precision -int 12 "Number of digits of precision"}
- {-intval 7 "An integer"}
- {-scale -float 1.0 "Scale factor"}
- {-zoom 1.0 "Zoom factor"}
- {-arbitrary foobar "Arbitrary string"}
- {-random -string 12 "Random string"}
- {-listval -list {} "List value"}
- {-blahflag -blah abc "Funny type"}
- {arg2 -boolean "a boolean"}
- {arg3 -choice "ch1 ch2"}
- {?optarg? -list {} "optional argument"}
- } {
- foreach v [info locals] {
- puts stderr [format "%14s : %s" $v [set $v]]
- }
- }
- }
-
-################### No User serviceable part below ! ###############
-# You should really not look any further :
-# The following is private unexported undocumented unblessed... code
-# time to hit "q" ;-) !
-\f
-# Hmmm... ok, you really want to know ?
-\f
-# You've been warned... Here it is...
-
- # Array storing the parsed descriptions
- variable OptDesc;
- array set OptDesc {};
- # Next potentially free key id (numeric)
- variable OptDescN 0;
-
-# Inside algorithm/mechanism description:
-# (not for the faint hearted ;-)
-#
-# The argument description is parsed into a "program tree"
-# It is called a "program" because it is the program used by
-# the state machine interpreter that use that program to
-# actually parse the arguments at run time.
-#
-# The general structure of a "program" is
-# notation (pseudo bnf like)
-# name :== definition defines "name" as being "definition"
-# { x y z } means list of x, y, and z
-# x* means x repeated 0 or more time
-# x+ means "x x*"
-# x? means optionally x
-# x | y means x or y
-# "cccc" means the literal string
-#
-# program :== { programCounter programStep* }
-#
-# programStep :== program | singleStep
-#
-# programCounter :== {"P" integer+ }
-#
-# singleStep :== { instruction parameters* }
-#
-# instruction :== single element list
-#
-# (the difference between singleStep and program is that \
-# llength [lindex $program 0] >= 2
-# while
-# llength [lindex $singleStep 0] == 1
-# )
-#
-# And for this application:
-#
-# singleStep :== { instruction varname {hasBeenSet currentValue} type
-# typeArgs help }
-# instruction :== "flags" | "value"
-# type :== knowType | anyword
-# knowType :== "string" | "int" | "boolean" | "boolflag" | "float"
-# | "choice"
-#
-# for type "choice" typeArgs is a list of possible choices, the first one
-# is the default value. for all other types the typeArgs is the default value
-#
-# a "boolflag" is the type for a flag whose presence or absence, without
-# additional arguments means respectively true or false (default flag type).
-#
-# programCounter is the index in the list of the currently processed
-# programStep (thus starting at 1 (0 is {"P" prgCounterValue}).
-# If it is a list it points toward each currently selected programStep.
-# (like for "flags", as they are optional, form a set and programStep).
-
-# Performance/Implementation issues
-# ---------------------------------
-# We use tcl lists instead of arrays because with tcl8.0
-# they should start to be much faster.
-# But this code use a lot of helper procs (like Lvarset)
-# which are quite slow and would be helpfully optimized
-# for instance by being written in C. Also our struture
-# is complex and there is maybe some places where the
-# string rep might be calculated at great exense. to be checked.
-
-#
-# Parse a given description and saves it here under the given key
-# generate a unused keyid if not given
-#
-proc ::tcl::OptKeyRegister {desc {key ""}} {
- variable OptDesc;
- variable OptDescN;
- if {[string compare $key ""] == 0} {
- # in case a key given to us as a parameter was a number
- while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
- set key $OptDescN;
- incr OptDescN;
- }
- # program counter
- set program [list [list "P" 1]];
-
- # are we processing flags (which makes a single program step)
- set inflags 0;
-
- set state {};
-
- # flag used to detect that we just have a single (flags set) subprogram.
- set empty 1;
-
- foreach item $desc {
- if {$state == "args"} {
- # more items after 'args'...
- return -code error "'args' special argument must be the last one";
- }
- set res [OptNormalizeOne $item];
- set state [lindex $res 0];
- if {$inflags} {
- if {$state == "flags"} {
- # add to 'subprogram'
- lappend flagsprg $res;
- } else {
- # put in the flags
- # structure for flag programs items is a list of
- # {subprgcounter {prg flag 1} {prg flag 2} {...}}
- lappend program $flagsprg;
- # put the other regular stuff
- lappend program $res;
- set inflags 0;
- set empty 0;
- }
- } else {
- if {$state == "flags"} {
- set inflags 1;
- # sub program counter + first sub program
- set flagsprg [list [list "P" 1] $res];
- } else {
- lappend program $res;
- set empty 0;
- }
- }
- }
- if {$inflags} {
- if {$empty} {
- # We just have the subprogram, optimize and remove
- # unneeded level:
- set program $flagsprg;
- } else {
- lappend program $flagsprg;
- }
- }
-
- set OptDesc($key) $program;
-
- return $key;
-}
-
-#
-# Free the storage for that given key
-#
-proc ::tcl::OptKeyDelete {key} {
- variable OptDesc;
- unset OptDesc($key);
-}
-
- # Get the parsed description stored under the given key.
- proc OptKeyGetDesc {descKey} {
- variable OptDesc;
- if {![info exists OptDesc($descKey)]} {
- return -code error "Unknown option description key \"$descKey\"";
- }
- set OptDesc($descKey);
- }
-
-# Parse entry point for ppl who don't want to register with a key,
-# for instance because the description changes dynamically.
-# (otherwise one should really use OptKeyRegister once + OptKeyParse
-# as it is way faster or simply OptProc which does it all)
-# Assign a temporary key, call OptKeyParse and then free the storage
-proc ::tcl::OptParse {desc arglist} {
- set tempkey [OptKeyRegister $desc];
- set ret [catch {uplevel [list ::tcl::OptKeyParse $tempkey $arglist]} res];
- OptKeyDelete $tempkey;
- return -code $ret $res;
-}
-
-# Helper function, replacement for proc that both
-# register the description under a key which is the name of the proc
-# (and thus unique to that code)
-# and add a first line to the code to call the OptKeyParse proc
-# Stores the list of variables that have been actually given by the user
-# (the other will be sets to their default value)
-# into local variable named "Args".
-proc ::tcl::OptProc {name desc body} {
- set namespace [uplevel namespace current];
- if { ([string match "::*" $name])
- || ([string compare $namespace "::"]==0)} {
- # absolute name or global namespace, name is the key
- set key $name;
- } else {
- # we are relative to some non top level namespace:
- set key "${namespace}::${name}";
- }
- OptKeyRegister $desc $key;
- uplevel [list proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
- return $key;
-}
-# Check that a argument has been given
-# assumes that "OptProc" has been used as it will check in "Args" list
-proc ::tcl::OptProcArgGiven {argname} {
- upvar Args alist;
- expr {[lsearch $alist $argname] >=0}
-}
-
- #######
- # Programs/Descriptions manipulation
-
- # Return the instruction word/list of a given step/(sub)program
- proc OptInstr {lst} {
- lindex $lst 0;
- }
- # Is a (sub) program or a plain instruction ?
- proc OptIsPrg {lst} {
- expr {[llength [OptInstr $lst]]>=2}
- }
- # Is this instruction a program counter or a real instr
- proc OptIsCounter {item} {
- expr {[lindex $item 0]=="P"}
- }
- # Current program counter (2nd word of first word)
- proc OptGetPrgCounter {lst} {
- Lget $lst {0 1}
- }
- # Current program counter (2nd word of first word)
- proc OptSetPrgCounter {lstName newValue} {
- upvar $lstName lst;
- set lst [lreplace $lst 0 0 [concat "P" $newValue]];
- }
- # returns a list of currently selected items.
- proc OptSelection {lst} {
- set res {};
- foreach idx [lrange [lindex $lst 0] 1 end] {
- lappend res [Lget $lst $idx];
- }
- return $res;
- }
-
- # Advance to next description
- proc OptNextDesc {descName} {
- uplevel [list Lvarincr $descName {0 1}];
- }
-
- # Get the current description, eventually descend
- proc OptCurDesc {descriptions} {
- lindex $descriptions [OptGetPrgCounter $descriptions];
- }
- # get the current description, eventually descend
- # through sub programs as needed.
- proc OptCurDescFinal {descriptions} {
- set item [OptCurDesc $descriptions];
- # Descend untill we get the actual item and not a sub program
- while {[OptIsPrg $item]} {
- set item [OptCurDesc $item];
- }
- return $item;
- }
- # Current final instruction adress
- proc OptCurAddr {descriptions {start {}}} {
- set adress [OptGetPrgCounter $descriptions];
- lappend start $adress;
- set item [lindex $descriptions $adress];
- if {[OptIsPrg $item]} {
- return [OptCurAddr $item $start];
- } else {
- return $start;
- }
- }
- # Set the value field of the current instruction
- proc OptCurSetValue {descriptionsName value} {
- upvar $descriptionsName descriptions
- # get the current item full adress
- set adress [OptCurAddr $descriptions];
- # use the 3th field of the item (see OptValue / OptNewInst)
- lappend adress 2
- Lvarset descriptions $adress [list 1 $value];
- # ^hasBeenSet flag
- }
-
- # empty state means done/paste the end of the program
- proc OptState {item} {
- lindex $item 0
- }
-
- # current state
- proc OptCurState {descriptions} {
- OptState [OptCurDesc $descriptions];
- }
-
- #######
- # Arguments manipulation
-
- # Returns the argument that has to be processed now
- proc OptCurrentArg {lst} {
- lindex $lst 0;
- }
- # Advance to next argument
- proc OptNextArg {argsName} {
- uplevel [list Lvarpop1 $argsName];
- }
- #######
-
-
-
-
-
- # Loop over all descriptions, calling OptDoOne which will
- # eventually eat all the arguments.
- proc OptDoAll {descriptionsName argumentsName} {
- upvar $descriptionsName descriptions
- upvar $argumentsName arguments;
-# puts "entered DoAll";
- # Nb: the places where "state" can be set are tricky to figure
- # because DoOne sets the state to flagsValue and return -continue
- # when needed...
- set state [OptCurState $descriptions];
- # We'll exit the loop in "OptDoOne" or when state is empty.
- while 1 {
- set curitem [OptCurDesc $descriptions];
- # Do subprograms if needed, call ourselves on the sub branch
- while {[OptIsPrg $curitem]} {
- OptDoAll curitem arguments
-# puts "done DoAll sub";
- # Insert back the results in current tree;
- Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
- $curitem;
- OptNextDesc descriptions;
- set curitem [OptCurDesc $descriptions];
- set state [OptCurState $descriptions];
- }
-# puts "state = \"$state\" - arguments=($arguments)";
- if {[Lempty $state]} {
- # Nothing left to do, we are done in this branch:
- break;
- }
- # The following statement can make us terminate/continue
- # as it use return -code {break, continue, return and error}
- # codes
- OptDoOne descriptions state arguments;
- # If we are here, no special return code where issued,
- # we'll step to next instruction :
-# puts "new state = \"$state\"";
- OptNextDesc descriptions;
- set state [OptCurState $descriptions];
- }
- }
-
- # Process one step for the state machine,
- # eventually consuming the current argument.
- proc OptDoOne {descriptionsName stateName argumentsName} {
- upvar $argumentsName arguments;
- upvar $descriptionsName descriptions;
- upvar $stateName state;
-
- # the special state/instruction "args" eats all
- # the remaining args (if any)
- if {($state == "args")} {
- if {![Lempty $arguments]} {
- # If there is no additional arguments, leave the default value
- # in.
- OptCurSetValue descriptions $arguments;
- set arguments {};
- }
-# puts "breaking out ('args' state: consuming every reminding args)"
- return -code break;
- }
-
- if {[Lempty $arguments]} {
- if {$state == "flags"} {
- # no argument and no flags : we're done
-# puts "returning to previous (sub)prg (no more args)";
- return -code return;
- } elseif {$state == "optValue"} {
- set state next; # not used, for debug only
- # go to next state
- return ;
- } else {
- return -code error [OptMissingValue $descriptions];
- }
- } else {
- set arg [OptCurrentArg $arguments];
- }
-
- switch $state {
- flags {
- # A non-dash argument terminates the options, as does --
-
- # Still a flag ?
- if {![OptIsFlag $arg]} {
- # don't consume the argument, return to previous prg
- return -code return;
- }
- # consume the flag
- OptNextArg arguments;
- if {[string compare "--" $arg] == 0} {
- # return from 'flags' state
- return -code return;
- }
-
- set hits [OptHits descriptions $arg];
- if {$hits > 1} {
- return -code error [OptAmbigous $descriptions $arg]
- } elseif {$hits == 0} {
- return -code error [OptFlagUsage $descriptions $arg]
- }
- set item [OptCurDesc $descriptions];
- if {[OptNeedValue $item]} {
- # we need a value, next state is
- set state flagValue;
- } else {
- OptCurSetValue descriptions 1;
- }
- # continue
- return -code continue;
- }
- flagValue -
- value {
- set item [OptCurDesc $descriptions];
- # Test the values against their required type
- if {[catch {OptCheckType $arg\
- [OptType $item] [OptTypeArgs $item]} val]} {
- return -code error [OptBadValue $item $arg $val]
- }
- # consume the value
- OptNextArg arguments;
- # set the value
- OptCurSetValue descriptions $val;
- # go to next state
- if {$state == "flagValue"} {
- set state flags
- return -code continue;
- } else {
- set state next; # not used, for debug only
- return ; # will go on next step
- }
- }
- optValue {
- set item [OptCurDesc $descriptions];
- # Test the values against their required type
- if {![catch {OptCheckType $arg\
- [OptType $item] [OptTypeArgs $item]} val]} {
- # right type, so :
- # consume the value
- OptNextArg arguments;
- # set the value
- OptCurSetValue descriptions $val;
- }
- # go to next state
- set state next; # not used, for debug only
- return ; # will go on next step
- }
- }
- # If we reach this point: an unknown
- # state as been entered !
- return -code error "Bug! unknown state in DoOne \"$state\"\
- (prg counter [OptGetPrgCounter $descriptions]:\
- [OptCurDesc $descriptions])";
- }
-
-# Parse the options given the key to previously registered description
-# and arguments list
-proc ::tcl::OptKeyParse {descKey arglist} {
-
- set desc [OptKeyGetDesc $descKey];
-
- # make sure -help always give usage
- if {[string compare "-help" [string tolower $arglist]] == 0} {
- return -code error [OptError "Usage information:" $desc 1];
- }
-
- OptDoAll desc arglist;
-
- if {![Lempty $arglist]} {
- return -code error [OptTooManyArgs $desc $arglist];
- }
-
- # Analyse the result
- # Walk through the tree:
- OptTreeVars $desc "#[expr {[info level]-1}]" ;
-}
-
- # determine string length for nice tabulated output
- proc OptTreeVars {desc level {vnamesLst {}}} {
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- set vnamesLst [OptTreeVars $item $level $vnamesLst];
- } else {
- set vname [OptVarName $item];
- upvar $level $vname var
- if {[OptHasBeenSet $item]} {
-# puts "adding $vname"
- # lets use the input name for the returned list
- # it is more usefull, for instance you can check that
- # no flags at all was given with expr
- # {![string match "*-*" $Args]}
- lappend vnamesLst [OptName $item];
- set var [OptValue $item];
- } else {
- set var [OptDefaultValue $item];
- }
- }
- }
- return $vnamesLst
- }
-
-
-# Check the type of a value
-# and emit an error if arg is not of the correct type
-# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
-proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
-# puts "checking '$arg' against '$type' ($typeArgs)";
-
- # only types "any", "choice", and numbers can have leading "-"
-
- switch -exact -- $type {
- int {
- if {![regexp {^(-+)?[0-9]+$} $arg]} {
- error "not an integer"
- }
- return $arg;
- }
- float {
- return [expr {double($arg)}]
- }
- script -
- list {
- # if llength fail : malformed list
- if {[llength $arg]==0} {
- if {[OptIsFlag $arg]} {
- error "no values with leading -"
- }
- }
- return $arg;
- }
- boolean {
- if {![regexp -nocase {^(true|false|0|1)$} $arg]} {
- error "non canonic boolean"
- }
- # convert true/false because expr/if is broken with "!,...
- if {$arg} {
- return 1
- } else {
- return 0
- }
- }
- choice {
- if {[lsearch -exact $typeArgs $arg] < 0} {
- error "invalid choice"
- }
- return $arg;
- }
- any {
- return $arg;
- }
- string -
- default {
- if {[OptIsFlag $arg]} {
- error "no values with leading -"
- }
- return $arg
- }
- }
- return neverReached;
-}
-
- # internal utilities
-
- # returns the number of flags matching the given arg
- # sets the (local) prg counter to the list of matches
- proc OptHits {descName arg} {
- upvar $descName desc;
- set hits 0
- set hitems {}
- set i 1;
-
- set larg [string tolower $arg];
- set len [string length $larg];
- set last [expr {$len-1}];
-
- foreach item [lrange $desc 1 end] {
- set flag [OptName $item]
- # lets try to match case insensitively
- # (string length ought to be cheap)
- set lflag [string tolower $flag];
- if {$len == [string length $lflag]} {
- if {[string compare $larg $lflag]==0} {
- # Exact match case
- OptSetPrgCounter desc $i;
- return 1;
- }
- } else {
- if {[string compare $larg [string range $lflag 0 $last]]==0} {
- lappend hitems $i;
- incr hits;
- }
- }
- incr i;
- }
- if {$hits} {
- OptSetPrgCounter desc $hitems;
- }
- return $hits
- }
-
- # Extract fields from the list structure:
-
- proc OptName {item} {
- lindex $item 1;
- }
- #
- proc OptHasBeenSet {item} {
- Lget $item {2 0};
- }
- #
- proc OptValue {item} {
- Lget $item {2 1};
- }
-
- proc OptIsFlag {name} {
- string match "-*" $name;
- }
- proc OptIsOpt {name} {
- string match {\?*} $name;
- }
- proc OptVarName {item} {
- set name [OptName $item];
- if {[OptIsFlag $name]} {
- return [string range $name 1 end];
- } elseif {[OptIsOpt $name]} {
- return [string trim $name "?"];
- } else {
- return $name;
- }
- }
- proc OptType {item} {
- lindex $item 3
- }
- proc OptTypeArgs {item} {
- lindex $item 4
- }
- proc OptHelp {item} {
- lindex $item 5
- }
- proc OptNeedValue {item} {
- string compare [OptType $item] boolflag
- }
- proc OptDefaultValue {item} {
- set val [OptTypeArgs $item]
- switch -exact -- [OptType $item] {
- choice {return [lindex $val 0]}
- boolean -
- boolflag {
- # convert back false/true to 0/1 because expr !$bool
- # is broken..
- if {$val} {
- return 1
- } else {
- return 0
- }
- }
- }
- return $val
- }
-
- # Description format error helper
- proc OptOptUsage {item {what ""}} {
- return -code error "invalid description format$what: $item\n\
- should be a list of {varname|-flagname ?-type? ?defaultvalue?\
- ?helpstring?}";
- }
-
-
- # Generate a canonical form single instruction
- proc OptNewInst {state varname type typeArgs help} {
- list $state $varname [list 0 {}] $type $typeArgs $help;
- # ^ ^
- # | |
- # hasBeenSet=+ +=currentValue
- }
-
- # Translate one item to canonical form
- proc OptNormalizeOne {item} {
- set lg [Lassign $item varname arg1 arg2 arg3];
-# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
- set isflag [OptIsFlag $varname];
- set isopt [OptIsOpt $varname];
- if {$isflag} {
- set state "flags";
- } elseif {$isopt} {
- set state "optValue";
- } elseif {[string compare $varname "args"]} {
- set state "value";
- } else {
- set state "args";
- }
-
- # apply 'smart' 'fuzzy' logic to try to make
- # description writer's life easy, and our's difficult :
- # let's guess the missing arguments :-)
-
- switch $lg {
- 1 {
- if {$isflag} {
- return [OptNewInst $state $varname boolflag false ""];
- } else {
- return [OptNewInst $state $varname any "" ""];
- }
- }
- 2 {
- # varname default
- # varname help
- set type [OptGuessType $arg1]
- if {[string compare $type "string"] == 0} {
- if {$isflag} {
- set type boolflag
- set def false
- } else {
- set type any
- set def ""
- }
- set help $arg1
- } else {
- set help ""
- set def $arg1
- }
- return [OptNewInst $state $varname $type $def $help];
- }
- 3 {
- # varname type value
- # varname value comment
-
- if {[regexp {^-(.+)$} $arg1 x type]} {
- # flags/optValue as they are optional, need a "value",
- # on the contrary, for a variable (non optional),
- # default value is pointless, 'cept for choices :
- if {$isflag || $isopt || ($type == "choice")} {
- return [OptNewInst $state $varname $type $arg2 ""];
- } else {
- return [OptNewInst $state $varname $type "" $arg2];
- }
- } else {
- return [OptNewInst $state $varname\
- [OptGuessType $arg1] $arg1 $arg2]
- }
- }
- 4 {
- if {[regexp {^-(.+)$} $arg1 x type]} {
- return [OptNewInst $state $varname $type $arg2 $arg3];
- } else {
- return -code error [OptOptUsage $item];
- }
- }
- default {
- return -code error [OptOptUsage $item];
- }
- }
- }
-
- # Auto magic lasy type determination
- proc OptGuessType {arg} {
- if {[regexp -nocase {^(true|false)$} $arg]} {
- return boolean
- }
- if {[regexp {^(-+)?[0-9]+$} $arg]} {
- return int
- }
- if {![catch {expr {double($arg)}}]} {
- return float
- }
- return string
- }
-
- # Error messages front ends
-
- proc OptAmbigous {desc arg} {
- OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
- }
- proc OptFlagUsage {desc arg} {
- OptError "bad flag \"$arg\", must be one of" $desc;
- }
- proc OptTooManyArgs {desc arguments} {
- OptError "too many arguments (unexpected argument(s): $arguments),\
- usage:"\
- $desc 1
- }
- proc OptParamType {item} {
- if {[OptIsFlag $item]} {
- return "flag";
- } else {
- return "parameter";
- }
- }
- proc OptBadValue {item arg {err {}}} {
-# puts "bad val err = \"$err\"";
- OptError "bad value \"$arg\" for [OptParamType $item]"\
- [list $item]
- }
- proc OptMissingValue {descriptions} {
-# set item [OptCurDescFinal $descriptions];
- set item [OptCurDesc $descriptions];
- OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
- (use -help for full usage) :"\
- [list $item]
- }
-
-proc ::tcl::OptKeyError {prefix descKey {header 0}} {
- OptError $prefix [OptKeyGetDesc $descKey] $header;
-}
-
- # determine string length for nice tabulated output
- proc OptLengths {desc nlName tlName dlName} {
- upvar $nlName nl;
- upvar $tlName tl;
- upvar $dlName dl;
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- OptLengths $item nl tl dl
- } else {
- SetMax nl [string length [OptName $item]]
- SetMax tl [string length [OptType $item]]
- set dv [OptTypeArgs $item];
- if {[OptState $item] != "header"} {
- set dv "($dv)";
- }
- set l [string length $dv];
- # limit the space allocated to potentially big "choices"
- if {([OptType $item] != "choice") || ($l<=12)} {
- SetMax dl $l
- } else {
- if {![info exists dl]} {
- set dl 0
- }
- }
- }
- }
- }
- # output the tree
- proc OptTree {desc nl tl dl} {
- set res "";
- foreach item $desc {
- if {[OptIsCounter $item]} continue;
- if {[OptIsPrg $item]} {
- append res [OptTree $item $nl $tl $dl];
- } else {
- set dv [OptTypeArgs $item];
- if {[OptState $item] != "header"} {
- set dv "($dv)";
- }
- append res [format "\n %-*s %-*s %-*s %s" \
- $nl [OptName $item] $tl [OptType $item] \
- $dl $dv [OptHelp $item]]
- }
- }
- return $res;
- }
-
-# Give nice usage string
-proc ::tcl::OptError {prefix desc {header 0}} {
- # determine length
- if {$header} {
- # add faked instruction
- set h [list [OptNewInst header Var/FlagName Type Value Help]];
- lappend h [OptNewInst header ------------ ---- ----- ----];
- lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
- set desc [concat $h $desc]
- }
- OptLengths $desc nl tl dl
- # actually output
- return "$prefix[OptTree $desc $nl $tl $dl]"
-}
-
-
-################ General Utility functions #######################
-
-#
-# List utility functions
-# Naming convention:
-# "Lvarxxx" take the list VARiable name as argument
-# "Lxxxx" take the list value as argument
-# (which is not costly with Tcl8 objects system
-# as it's still a reference and not a copy of the values)
-#
-
-# Is that list empty ?
-proc ::tcl::Lempty {list} {
- expr {[llength $list]==0}
-}
-
-# Gets the value of one leaf of a lists tree
-proc ::tcl::Lget {list indexLst} {
- if {[llength $indexLst] <= 1} {
- return [lindex $list $indexLst];
- }
- Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end];
-}
-# Sets the value of one leaf of a lists tree
-# (we use the version that does not create the elements because
-# it would be even slower... needs to be written in C !)
-# (nb: there is a non trivial recursive problem with indexes 0,
-# which appear because there is no difference between a list
-# of 1 element and 1 element alone : [list "a"] == "a" while
-# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
-# and [listp "a b"] maybe 0. listp does not exist either...)
-proc ::tcl::Lvarset {listName indexLst newValue} {
- upvar $listName list;
- if {[llength $indexLst] <= 1} {
- Lvarset1nc list $indexLst $newValue;
- } else {
- set idx [lindex $indexLst 0];
- set targetList [lindex $list $idx];
- # reduce refcount on targetList (not really usefull now,
- # could be with optimizing compiler)
-# Lvarset1 list $idx {};
- # recursively replace in targetList
- Lvarset targetList [lrange $indexLst 1 end] $newValue;
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
- }
-}
-# Set one cell to a value, eventually create all the needed elements
-# (on level-1 of lists)
-variable emptyList {}
-proc ::tcl::Lvarset1 {listName index newValue} {
- upvar $listName list;
- if {$index < 0} {return -code error "invalid negative index"}
- set lg [llength $list];
- if {$index >= $lg} {
- variable emptyList;
- for {set i $lg} {$i<$index} {incr i} {
- lappend list $emptyList;
- }
- lappend list $newValue;
- } else {
- set list [lreplace $list $index $index $newValue];
- }
-}
-# same as Lvarset1 but no bound checking / creation
-proc ::tcl::Lvarset1nc {listName index newValue} {
- upvar $listName list;
- set list [lreplace $list $index $index $newValue];
-}
-# Increments the value of one leaf of a lists tree
-# (which must exists)
-proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
- upvar $listName list;
- if {[llength $indexLst] <= 1} {
- Lvarincr1 list $indexLst $howMuch;
- } else {
- set idx [lindex $indexLst 0];
- set targetList [lindex $list $idx];
- # reduce refcount on targetList
- Lvarset1nc list $idx {};
- # recursively replace in targetList
- Lvarincr targetList [lrange $indexLst 1 end] $howMuch;
- # put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
- }
-}
-# Increments the value of one cell of a list
-proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
- upvar $listName list;
- set newValue [expr {[lindex $list $index]+$howMuch}];
- set list [lreplace $list $index $index $newValue];
- return $newValue;
-}
-# Removes the first element of a list
-# and returns the new list value
-proc ::tcl::Lvarpop1 {listName} {
- upvar $listName list;
- set list [lrange $list 1 end];
-}
-# Same but returns the removed element
-# (Like the tclX version)
-proc ::tcl::Lvarpop {listName} {
- upvar $listName list;
- set el [lindex $list 0];
- set list [lrange $list 1 end];
- return $el;
-}
-# Assign list elements to variables and return the length of the list
-proc ::tcl::Lassign {list args} {
- # faster than direct blown foreach (which does not byte compile)
- set i 0;
- set lg [llength $list];
- foreach vname $args {
- if {$i>=$lg} break
- uplevel [list set $vname [lindex $list $i]];
- incr i;
- }
- return $lg;
-}
-
-# Misc utilities
-
-# Set the varname to value if value is greater than varname's current value
-# or if varname is undefined
-proc ::tcl::SetMax {varname value} {
- upvar 1 $varname var
- if {![info exists var] || $value > $var} {
- set var $value
- }
-}
-
-# Set the varname to value if value is smaller than varname's current value
-# or if varname is undefined
-proc ::tcl::SetMin {varname value} {
- upvar 1 $varname var
- if {![info exists var] || $value < $var} {
- set var $value
- }
-}
-
-
- # everything loaded fine, lets create the test proc:
- # OptCreateTestProc
- # Don't need the create temp proc anymore:
- # rename OptCreateTestProc {}
-}
-
+++ /dev/null
-# Tcl package index file, version 1.1
-# This file is generated by the "pkg_mkIndex -direct" 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 opt 0.4.1 [list source [file join $dir optparse.tcl]]
proc pkg_compareExtension { fileName {ext {}} } {
global tcl_platform
- if {[string length $ext] == 0} {
- set ext [info sharedlibextension]
- }
+ if {![string length $ext]} {set ext [info sharedlibextension]}
if {[string equal $tcl_platform(platform) "windows"]} {
- return [string equal -nocase [file extension $fileName] $ext]
+ return [string equal -nocase [file extension $fileName] $ext]
} else {
- return [string equal [file extension $fileName] $ext]
+ # Some unices add trailing numbers after the .so, so
+ # we could have something like '.so.1.2'.
+ set root $fileName
+ while {1} {
+ set currExt [file extension $root]
+ if {[string equal $currExt $ext]} {
+ return 1
+ }
+
+ # The current extension does not match; if it is not a numeric
+ # value, quit, as we are only looking to ignore version number
+ # extensions. Otherwise we might return 1 in this case:
+ # pkg_compareExtension foo.so.bar .so
+ # which should not match.
+
+ if { ![string is integer -strict [string range $currExt 1 end]] } {
+ return 0
+ }
+ set root [file rootname $root]
+ }
}
}
proc pkg_mkIndex {args} {
global errorCode errorInfo
- set usage {"pkg_mkIndex ?-direct? ?-verbose? ?-load pattern? ?--? dir ?pattern ...?"};
+ set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
set argCount [llength $args]
if {$argCount < 1} {
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
+ if {[string length $loadPat]} {
+ if {$doVerbose} {
+ tclLog "currently loaded packages: '[info loaded]'"
+ tclLog "trying to load all packages matching $loadPat"
+ }
+ if {![llength [info loaded]]} {
+ tclLog "warning: no packages are currently loaded, nothing"
+ tclLog "can possibly match '$loadPat'"
+ }
+ }
foreach pkg [info loaded] {
if {! [string match $loadPat [lindex $pkg 1]]} {
continue
}
+ if {$doVerbose} {
+ tclLog "package [lindex $pkg 1] matches '$loadPat'"
+ }
if {[catch {
load [lindex $pkg 0] [lindex $pkg 1] $c
} err]} {
tclLog "warning: error while $what $file: $msg"
}
} else {
+ set what [$c eval set ::tcl::debug]
+ if {$doVerbose} {
+ tclLog "successful $what of $file"
+ }
set type [$c eval set ::tcl::type]
set cmds [lsort [$c eval array names ::tcl::newCmds]]
set pkgs [$c eval set ::tcl::newPkgs]
+ if {$doVerbose} {
+ tclLog "commands provided were $cmds"
+ tclLog "packages provided were $pkgs"
+ }
if {[llength $pkgs] > 1} {
tclLog "warning: \"$file\" provides more than one package ($pkgs)"
}
if {$doVerbose} {
tclLog "processed $file"
}
- interp delete $c
}
+ interp delete $c
}
append index "# Tcl package index file, version 1.1\n"
# interpreter to setup the package database.
proc tclMacPkgSearch {dir} {
- foreach x [glob -nocomplain [file join $dir *.shlb]] {
+ foreach x [glob -directory $dir -nocomplain *.shlb] {
if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
# in a catch statement, where we get the pkgIndex files out
# of the subdirectories
catch {
- foreach file [glob -nocomplain [file join $dir * pkgIndex.tcl]] {
+ foreach file [glob -directory $dir -join -nocomplain \
+ * pkgIndex.tcl] {
set dir [file dirname $file]
if {[file readable $file] && ![info exists procdDirs($dir)]} {
if {[catch {source $file} msg]} {
}
}
}
+ # On MacOSX also search the Resources/Scripts directories in
+ # the subdirectories for pkgIndex files
+ if {[string equal $::tcl_platform(platform) "unix"] && \
+ [string equal $::tcl_platform(os) "Darwin"]} {
+ set dir [lindex $use_path end]
+ catch {
+ foreach file [glob -directory $dir -join -nocomplain \
+ * Resources Scripts pkgIndex.tcl] {
+ set dir [file dirname $file]
+ if {[file readable $file] && ![info exists procdDirs($dir)]} {
+ if {[catch {source $file} msg]} {
+ tclLog "error reading package index file $file: $msg"
+ } else {
+ set procdDirs($dir) 1
+ }
+ }
+ }
+ }
+ }
set dir [lindex $use_path end]
set file [file join $dir pkgIndex.tcl]
# safe interps usually don't have "file readable", nor stderr channel
tclMacPkgSearch $dir
set procdDirs($dir) 1
}
- foreach x [glob -nocomplain [file join $dir *]] {
+ foreach x [glob -directory $dir -nocomplain *] {
if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
set dir $x
tclMacPkgSearch $dir
return $cmdline
}
-
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[info exists tcl_platform(debug)]} {
- package ifneeded registry 1.0 \
- [list load [file join $dir tclreg10d.dll] registry]
+ package ifneeded registry 1.1 \
+ [list load [file join $dir tclreg11d.dll] registry]
} else {
- package ifneeded registry 1.0 \
- [list load [file join $dir tclreg10.dll] registry]
+ package ifneeded registry 1.1 \
+ [list load [file join $dir tclreg11.dll] registry]
}
+++ /dev/null
-if {[info exists tcl_platform(debug)]} {
- package ifneeded registry 1.0 \
- [list load [file join $dir tclreg83d.dll] registry]
-} else {
- package ifneeded registry 1.0 \
- [list load [file join $dir tclreg83.dll] registry]
-}
if {[lsearch -exact $res $dir]<0} {
lappend res $dir
}
- foreach sub [glob -nocomplain -- [file join $dir *]] {
+ foreach sub [glob -directory $dir -nocomplain *] {
if {([file isdirectory $sub]) \
&& ([lsearch -exact $res $sub]<0) } {
# new sub dir, add it !
}
}
-
+
# file name control (limit access to files/ressources that should be
# a valid tcl source file)
proc CheckFileName {slave file} {
- # 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]
- if {[string length $ftail]>14} {
- error "$ftail: filename too long"
- }
- if {[regexp {\..*\.} $ftail]} {
- error "$ftail: more than one dot is forbidden"
- }
- if {[string compare $ftail "tclIndex"] && \
- [string compare -nocase [file extension $ftail] ".tcl"]} {
- error "$ftail: must be a *.tcl or tclIndex"
- }
+ # This used to limit what can be sourced to ".tcl" and forbid files
+ # with more than 1 dot and longer than 14 chars, but I changed that
+ # for 8.4 as a safe interp has enough internal protection already
+ # to allow sourcing anything. - hobbs
if {![file exists $file]} {
# don't tell the file path
+++ /dev/null
-# safeinit.tcl --
-#
-# This code runs in a master to manage a safe slave with Safe Tcl.
-# See the safe.n man page for details.
-#
-# Copyright (c) 1996-1997 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# SCCS: @(#) safeinit.tcl 1.38 97/06/20 12:57:39
-
-# This procedure creates a safe slave, initializes it with the
-# safe base and installs the aliases for the security policy mechanism.
-
-proc tcl_safeCreateInterp {slave} {
- global auto_path
-
- # Create the slave.
- interp create -safe $slave
-
- # Set its auto_path
- interp eval $slave [list set auto_path $auto_path]
-
- # And initialize it.
- return [tcl_safeInitInterp $slave]
-}
-
-# This procedure applies the initializations to an already existing
-# interpreter. It is useful when you want to enable an interpreter
-# created with "interp create -safe" to use security policies.
-
-proc tcl_safeInitInterp {slave} {
- upvar #0 tclSafe$slave state
- global tcl_library tk_library auto_path tcl_platform
-
- # These aliases let the slave load files to define new commands
-
- interp alias $slave source {} tclSafeAliasSource $slave
- interp alias $slave load {} tclSafeAliasLoad $slave
-
- # This alias lets the slave have access to a subset of the 'file'
- # command functionality.
- tclAliasSubset $slave file file dir.* join root.* ext.* tail \
- path.* split
-
- # This alias interposes on the 'exit' command and cleanly terminates
- # the slave.
- interp alias $slave exit {} tcl_safeDeleteInterp $slave
-
- # Source init.tcl into the slave, to get auto_load and other
- # procedures defined:
-
- if {$tcl_platform(platform) == "macintosh"} {
- if {[catch {interp eval $slave [list source -rsrc Init]}]} {
- if {[catch {interp eval $slave \
- [list source [file join $tcl_library init.tcl]]}]} {
- error "can't source init.tcl into slave $slave"
- }
- }
- } else {
- if {[catch {interp eval $slave \
- [list source [file join $tcl_library init.tcl]]}]} {
- error "can't source init.tcl into slave $slave"
- }
- }
-
- # Loading packages into slaves is handled by their master.
- # This is overloaded to deal with regular packages and security policies
-
- interp alias $slave tclPkgUnknown {} tclSafeAliasPkgUnknown $slave
- interp eval $slave {package unknown tclPkgUnknown}
-
- # We need a helper procedure to define a $dir variable and then
- # do a source of the pkgIndex.tcl file
- interp eval $slave \
- [list proc tclPkgSource {dir args} {
- if {[llength $args] == 2} {
- source [lindex $args 0] [lindex $args 1]
- } else {
- source [lindex $args 0]
- }
- }]
-
- # Let the slave inherit a few variables
- foreach varName \
- {tcl_library tcl_version tcl_patchLevel \
- tcl_platform(platform) auto_path} {
- upvar #0 $varName var
- interp eval $slave [list set $varName $var]
- }
-
- # Other variables are predefined with set values
- foreach {varName value} {
- auto_noexec 1
- errorCode {}
- errorInfo {}
- env() {}
- argv0 {}
- argv {}
- argc 0
- tcl_interactive 0
- } {
- interp eval $slave [list set $varName $value]
- }
-
- # If auto_path is not set in the slave, set it to empty so it has
- # a value and exists. Otherwise auto_loading and package require
- # will complain.
-
- interp eval $slave {
- if {![info exists auto_path]} {
- set auto_path {}
- }
- }
-
- # If we have Tk, make the slave have the same library as us:
-
- if {[info exists tk_library]} {
- interp eval $slave [list set tk_library $tk_library]
- }
-
- # Stub out auto-exec mechanism in slave
- interp eval $slave [list proc auto_execok {name} {return {}}]
-
- return $slave
-}
-
-# This procedure deletes a safe slave managed by Safe Tcl and
-# cleans up associated state:
-
-proc tcl_safeDeleteInterp {slave args} {
- upvar #0 tclSafe$slave state
-
- # If the slave has a policy loaded, clean it up now.
- if {[info exists state(policyLoaded)]} {
- set policy $state(policyLoaded)
- set proc ${policy}_PolicyCleanup
- if {[string compare [info proc $proc] $proc] == 0} {
- $proc $slave
- }
- }
-
- # Discard the global array of state associated with the slave, and
- # delete the interpreter.
- catch {unset state}
- catch {interp delete $slave}
-
- return
-}
-
-# This procedure computes the global security policy search path.
-
-proc tclSafeComputePolicyPath {} {
- global auto_path tclSafeAutoPathComputed tclSafePolicyPath
-
- set recompute 0
- if {(![info exists tclSafePolicyPath]) ||
- ("$tclSafePolicyPath" == "")} {
- set tclSafePolicyPath ""
- set tclSafeAutoPathComputed ""
- set recompute 1
- }
- if {"$tclSafeAutoPathComputed" != "$auto_path"} {
- set recompute 1
- set tclSafeAutoPathComputed $auto_path
- }
- if {$recompute == 1} {
- set tclSafePolicyPath ""
- foreach i $auto_path {
- lappend tclSafePolicyPath [file join $i policies]
- }
- }
- return $tclSafePolicyPath
-}
-
-# ---------------------------------------------------------------------------
-# ---------------------------------------------------------------------------
-
-# tclSafeAliasSource is the target of the "source" alias in safe interpreters.
-
-proc tclSafeAliasSource {slave args} {
- global auto_path errorCode errorInfo
-
- if {[llength $args] == 2} {
- if {[string compare "-rsrc" [lindex $args 0]] != 0} {
- return -code error "incorrect arguments to source"
- }
- if {[catch {interp invokehidden $slave source -rsrc [lindex $args 1]} \
- msg]} {
- return -code error $msg
- }
- } else {
- set file [lindex $args 0]
- if {[catch {tclFileInPath $file $auto_path $slave} msg]} {
- return -code error "permission denied"
- }
- set errorInfo ""
- if {[catch {interp invokehidden $slave source $file} msg]} {
- return -code error $msg
- }
- }
- return $msg
-}
-
-# tclSafeAliasLoad is the target of the "load" alias in safe interpreters.
-
-proc tclSafeAliasLoad {slave file args} {
- global auto_path
-
- if {[llength $args] == 2} {
- # Trying to load into another interpreter
- # Allow this for a child of the slave, or itself
- set other [lindex $args 1]
- foreach x $slave y $other {
- if {[string length $x] == 0} {
- break
- } elseif {[string compare $x $y] != 0} {
- return -code error "permission denied"
- }
- }
- set slave $other
- }
-
- if {[string length $file] && \
- [catch {tclFileInPath $file $auto_path $slave} msg]} {
- return -code error "permission denied"
- }
- if {[catch {
- switch [llength $args] {
- 0 {
- interp invokehidden $slave load $file
- }
- 1 -
- 2 {
- interp invokehidden $slave load $file [lindex $args 0]
- }
- default {
- error "too many arguments to load"
- }
- }
- } msg]} {
- return -code error $msg
- }
- return $msg
-}
-
-# tclFileInPath raises an error if the file is not found in
-# the list of directories contained in path.
-
-proc tclFileInPath {file path slave} {
- set realcheckpath [tclSafeCheckAutoPath $path $slave]
- set pwd [pwd]
- if {[file isdirectory $file]} {
- error "$file: not found"
- }
- set parent [file dirname $file]
- if {[catch {cd $parent} msg]} {
- error "$file: not found"
- }
- set realfilepath [file split [pwd]]
- foreach dir $realcheckpath {
- set match 1
- foreach a [file split $dir] b $realfilepath {
- if {[string length $a] == 0} {
- break
- } elseif {[string compare $a $b] != 0} {
- set match 0
- break
- }
- }
- if {$match} {
- cd $pwd
- return 1
- }
- }
- cd $pwd
- error "$file: not found"
-}
-
-# This procedure computes our expanded copy of the path, as needed.
-# It returns the path after expanding out all aliases.
-
-proc tclSafeCheckAutoPath {path slave} {
- global auto_path
- upvar #0 tclSafe$slave state
-
- if {![info exists state(expanded_auto_path)]} {
- # Compute for the first time:
- set state(cached_auto_path) $path
- } elseif {"$state(cached_auto_path)" != "$path"} {
- # The value of our path changed, so recompute:
- set state(cached_auto_path) $path
- } else {
- # No change: no need to recompute.
- return $state(expanded_auto_path)
- }
-
- set pwd [pwd]
- set state(expanded_auto_path) ""
- foreach dir $state(cached_auto_path) {
- if {![catch {cd $dir}]} {
- lappend state(expanded_auto_path) [pwd]
- }
- }
- cd $pwd
- return $state(expanded_auto_path)
-}
-
-proc tclSafeAliasPkgUnknown {slave package version {exact {}}} {
- tclSafeLoadPkg $slave $package $version $exact
-}
-
-proc tclSafeLoadPkg {slave package version exact} {
- if {[string length $version] == 0} {
- set version 1.0
- }
- tclSafeLoadPkgInternal $slave $package $version $exact 0
-}
-
-proc tclSafeLoadPkgInternal {slave package version exact round} {
- global auto_path
- upvar #0 tclSafe$slave state
-
- # Search the policy path again; it might have changed in the meantime.
-
- if {$round == 1} {
- tclSafeResearchPolicyPath
-
- if {[tclSafeLoadPolicy $slave $package $version]} {
- return
- }
- }
-
- # Try to load as a policy.
-
- if [tclSafeLoadPolicy $slave $package $version] {
- return
- }
-
- # The package is not a security policy, so do the regular setup.
-
- # Here we run tclPkgUnknown in the master, but we hijack
- # the source command so the setup ends up happening in the slave.
-
- rename source source.orig
- proc source {args} "upvar dir dir
- interp eval [list $slave] tclPkgSource \[list \$dir\] \$args"
-
- if [catch {tclPkgUnknown $package $version $exact} err] {
- global errorInfo
-
- rename source {}
- rename source.orig source
-
- error "$err\n$errorInfo"
- }
- rename source {}
- rename source.orig source
-
- # If we are in the first round, check if the package
- # is now known in the slave:
-
- if {$round == 0} {
- set ifneeded \
- [interp eval $slave [list package ifneeded $package $version]]
-
- if {"$ifneeded" == ""} {
- return [tclSafeLoadPkgInternal $slave $package $version $exact 1]
- }
- }
-}
-
-proc tclSafeResearchPolicyPath {} {
- global tclSafePolicyPath auto_index auto_path
-
- # If there was no change, do not search again.
-
- if {![info exists tclSafePolicyPath]} {
- set tclSafePolicyPath ""
- }
- set oldPolicyPath $tclSafePolicyPath
- set newPolicyPath [tclSafeComputePolicyPath]
- if {"$newPolicyPath" == "$oldPolicyPath"} {
- return
- }
-
- # Loop through the path from back to front so early directories
- # end up overriding later directories. This code is like auto_load,
- # but only new-style tclIndex files (version 2) are supported.
-
- for {set i [expr [llength $newPolicyPath] - 1]} \
- {$i >= 0} \
- {incr i -1} {
- set dir [lindex $newPolicyPath $i]
- set file [file join $dir tclIndex]
- if {[file exists $file]} {
- if {[catch {source $file} msg]} {
- puts stderr "error sourcing $file: $msg"
- }
- }
- foreach file [lsort [glob -nocomplain [file join $dir *]]] {
- if {[file isdir $file]} {
- set dir $file
- set file [file join $file tclIndex]
- if {[file exists $file]} {
- if {[catch {source $file} msg]} {
- puts stderr "error sourcing $file: $msg"
- }
- }
- }
- }
- }
-}
-
-proc tclSafeLoadPolicy {slave package version} {
- upvar #0 tclSafe$slave state
- global auto_index
-
- set proc ${package}_PolicyInit
-
- if {[info command $proc] == "$proc" ||
- [info exists auto_index($proc)]} {
- if [info exists state(policyLoaded)] {
- error "security policy $state(policyLoaded) already loaded"
- }
- $proc $slave $version
- interp eval $slave [list package provide $package $version]
- set state(policyLoaded) $package
- return 1
- } else {
- return 0
- }
-}
-# This procedure enables access from a safe interpreter to only a subset of
-# the subcommands of a command:
-
-proc tclSafeSubset {command okpat args} {
- set subcommand [lindex $args 0]
- if {[regexp $okpat $subcommand]} {
- return [eval {$command $subcommand} [lrange $args 1 end]]
- }
- error "not allowed to invoke subcommand $subcommand of $command"
-}
-
-# This procedure installs an alias in a slave that invokes "safesubset"
-# in the master to execute allowed subcommands. It precomputes the pattern
-# of allowed subcommands; you can use wildcards in the pattern if you wish
-# to allow subcommand abbreviation.
-#
-# Syntax is: tclAliasSubset slave alias target subcommand1 subcommand2...
-
-proc tclAliasSubset {slave alias target args} {
- set pat ^(; set sep ""
- foreach sub $args {
- append pat $sep$sub
- set sep |
- }
- append pat )\$
- interp alias $slave $alias {} tclSafeSubset $target $pat
-}
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
-package ifneeded tcltest 2.2 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.2.1 [list source [file join $dir tcltest.tcl]]
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles.
- variable Version 2.2
+ variable Version 2.2.1
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# return [Puts -nonewline [lindex $args end]]
} else {
set channel [lindex $args 0]
+ set newline \n
}
}
3 {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
+ set newline ""
}
}
}
if {[info exists channel]} {
if {[string equal $channel [[namespace parent]::outputChannel]]
|| [string equal $channel stdout]} {
- append outData [lindex $args end]\n
+ append outData [lindex $args end]$newline
return
} elseif {[string equal $channel [[namespace parent]::errorChannel]]
|| [string equal $channel stderr]} {
- append errData [lindex $args end]\n
+ append errData [lindex $args end]$newline
return
}
}
}
}
if {$codeFailure} {
- switch -- $code {
+ switch -- $returnCode {
0 { set msg "Test completed normally" }
1 { set msg "Test generated error" }
2 { set msg "Test generated return exception" }
4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
- puts [outputChannel] "---- $msg; Return code was: $code"
+ puts [outputChannel] "---- $msg; Return code was: $returnCode"
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
+++ /dev/null
-# Tcl package index file, version 1.1
-# 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 tcltest 1.0 [list tclPkgSetup $dir tcltest 1.0 \
- {{tcltest.tcl source {::tcltest::bytestring ::tcltest::cleanupTests \
- ::tcltest::dotests ::tcltest::makeDirectory ::tcltest::makeFile \
- ::tcltest::normalizeMsg ::tcltest::removeDirectory \
- ::tcltest::removeFile ::tcltest::restoreState ::tcltest::saveState \
- ::tcltest::test ::tcltest::threadReap ::tcltest::viewFile memory \
- ::tcltest:grep ::tcltest::getMatchingTestFiles }}}]
-
+++ /dev/null
-# tcltest.tcl --
-#
-# This file contains support code for the Tcl test suite. It
-# defines the ::tcltest namespace and finds and defines the output
-# directory, constraints available, output and error channels, etc. used
-# by Tcl tests. See the tcltest man page for more details.
-#
-# This design was based on the Tcl testing approach designed and
-# initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
-#
-# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package provide tcltest 1.0
-
-# create the "tcltest" namespace for all testing variables and procedures
-
-namespace eval tcltest {
-
- # Export the public tcltest procs
- set procList [list test cleanupTests saveState restoreState \
- normalizeMsg makeFile removeFile makeDirectory removeDirectory \
- viewFile bytestring safeFetch threadReap getMatchingFiles \
- loadTestedCommands normalizePath]
- foreach proc $procList {
- namespace export $proc
- }
-
- # ::tcltest::verbose defaults to "b"
- if {![info exists verbose]} {
- variable verbose "b"
- }
-
- # Match and skip patterns default to the empty list, except for
- # matchFiles, which defaults to all .test files in the testsDirectory
-
- if {![info exists match]} {
- variable match {}
- }
- if {![info exists skip]} {
- variable skip {}
- }
- if {![info exists matchFiles]} {
- variable matchFiles {*.test}
- }
- if {![info exists skipFiles]} {
- variable skipFiles {}
- }
-
- # By default, don't save core files
- if {![info exists preserveCore]} {
- variable preserveCore 0
- }
-
- # output goes to stdout by default
- if {![info exists outputChannel]} {
- variable outputChannel stdout
- }
-
- # errors go to stderr by default
- if {![info exists errorChannel]} {
- variable errorChannel stderr
- }
-
- # debug output doesn't get printed by default; debug level 1 spits
- # up only the tests that were skipped because they didn't match or were
- # specifically skipped. A debug level of 2 would spit up the tcltest
- # variables and flags provided; a debug level of 3 causes some additional
- # output regarding operations of the test harness. The tcltest package
- # currently implements only up to debug level 3.
- if {![info exists debug]} {
- variable debug 0
- }
-
- # Save any arguments that we might want to pass through to other programs.
- # This is used by the -args flag.
- if {![info exists parameters]} {
- variable parameters {}
- }
-
- # Count the number of files tested (0 if all.tcl wasn't called).
- # The all.tcl file will set testSingleFile to false, so stats will
- # not be printed until all.tcl calls the cleanupTests proc.
- # The currentFailure var stores the boolean value of whether the
- # current test file has had any failures. The failFiles list
- # stores the names of test files that had failures.
-
- if {![info exists numTestFiles]} {
- variable numTestFiles 0
- }
- if {![info exists testSingleFile]} {
- variable testSingleFile true
- }
- if {![info exists currentFailure]} {
- variable currentFailure false
- }
- if {![info exists failFiles]} {
- variable failFiles {}
- }
-
- # Tests should remove all files they create. The test suite will
- # check the current working dir for files created by the tests.
- # ::tcltest::filesMade keeps track of such files created using the
- # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
- # ::tcltest::filesExisted stores the names of pre-existing files.
-
- if {![info exists filesMade]} {
- variable filesMade {}
- }
- if {![info exists filesExisted]} {
- variable filesExisted {}
- }
-
- # ::tcltest::numTests will store test files as indices and the list
- # of files (that should not have been) left behind by the test files.
-
- if {![info exists createdNewFiles]} {
- variable createdNewFiles
- array set ::tcltest::createdNewFiles {}
- }
-
- # initialize ::tcltest::numTests array to keep track fo the number of
- # tests that pass, fail, and are skipped.
-
- if {![info exists numTests]} {
- variable numTests
- array set ::tcltest::numTests \
- [list Total 0 Passed 0 Skipped 0 Failed 0]
- }
-
- # initialize ::tcltest::skippedBecause array to keep track of
- # constraints that kept tests from running; a constraint name of
- # "userSpecifiedSkip" means that the test appeared on the list of tests
- # that matched the -skip value given to the flag; "userSpecifiedNonMatch"
- # means that the test didn't match the argument given to the -match flag;
- # both of these constraints are counted only if ::tcltest::debug is set to
- # true.
-
- if {![info exists skippedBecause]} {
- variable skippedBecause
- array set ::tcltest::skippedBecause {}
- }
-
- # initialize the ::tcltest::testConstraints array to keep track of valid
- # predefined constraints (see the explanation for the
- # ::tcltest::initConstraints proc for more details).
-
- if {![info exists testConstraints]} {
- variable testConstraints
- array set ::tcltest::testConstraints {}
- }
-
- # Don't run only the constrained tests by default
-
- if {![info exists limitConstraints]} {
- variable limitConstraints false
- }
-
- # A test application has to know how to load the tested commands into
- # the interpreter.
-
- if {![info exists loadScript]} {
- variable loadScript {}
- }
-
- # tests that use threads need to know which is the main thread
-
- if {![info exists mainThread]} {
- variable mainThread 1
- if {[info commands thread::id] != {}} {
- set mainThread [thread::id]
- } elseif {[info commands testthread] != {}} {
- set mainThread [testthread id]
- }
- }
-
- # save the original environment so that it can be restored later
-
- if {![info exists originalEnv]} {
- variable originalEnv
- array set ::tcltest::originalEnv [array get ::env]
- }
-
- # Set ::tcltest::workingDirectory to [pwd]. The default output directory
- # for Tcl tests is the working directory.
-
- if {![info exists workingDirectory]} {
- variable workingDirectory [pwd]
- }
- if {![info exists temporaryDirectory]} {
- variable temporaryDirectory $workingDirectory
- }
-
- # Tests should not rely on the current working directory.
- # Files that are part of the test suite should be accessed relative to
- # ::tcltest::testsDirectory.
-
- if {![info exists testsDirectory]} {
- set oldpwd [pwd]
- catch {cd [file join [file dirname [info script]] .. .. tests]}
- variable testsDirectory [pwd]
- cd $oldpwd
- unset oldpwd
- }
-
- # the variables and procs that existed when ::tcltest::saveState was
- # called are stored in a variable of the same name
- if {![info exists saveState]} {
- variable saveState {}
- }
-
- # Internationalization support
- if {![info exists isoLocale]} {
- variable isoLocale fr
- switch $tcl_platform(platform) {
- "unix" {
-
- # Try some 'known' values for some platforms:
-
- switch -exact -- $tcl_platform(os) {
- "FreeBSD" {
- set ::tcltest::isoLocale fr_FR.ISO_8859-1
- }
- HP-UX {
- set ::tcltest::isoLocale fr_FR.iso88591
- }
- Linux -
- IRIX {
- set ::tcltest::isoLocale fr
- }
- default {
-
- # Works on SunOS 4 and Solaris, and maybe others...
- # define it to something else on your system
- #if you want to test those.
-
- set ::tcltest::isoLocale iso_8859_1
- }
- }
- }
- "windows" {
- set ::tcltest::isoLocale French
- }
- }
- }
-
- # Set the location of the execuatble
- if {![info exists tcltest]} {
- variable tcltest [info nameofexecutable]
- }
-
- # save the platform information so it can be restored later
- if {![info exists originalTclPlatform]} {
- variable originalTclPlatform [array get tcl_platform]
- }
-
- # If a core file exists, save its modification time.
- if {![info exists coreModificationTime]} {
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
- variable coreModificationTime [file mtime [file join \
- $::tcltest::workingDirectory core]]
- }
- }
-
- # Tcl version numbers
- if {![info exists version]} {
- variable version 8.3
- }
- if {![info exists patchLevel]} {
- variable patchLevel 8.3.0
- }
-}
-
-# ::tcltest::Debug* --
-#
-# Internal helper procedures to write out debug information
-# dependent on the chosen level. A test shell may overide
-# them, f.e. to redirect the output into a different
-# channel, or even into a GUI.
-
-# ::tcltest::DebugPuts --
-#
-# Prints the specified string if the current debug level is
-# higher than the provided level argument.
-#
-# Arguments:
-# level The lowest debug level triggering the output
-# string The string to print out.
-#
-# Results:
-# Prints the string. Nothing else is allowed.
-#
-
-proc ::tcltest::DebugPuts {level string} {
- variable debug
- if {$debug >= $level} {
- puts $string
- }
-}
-
-# ::tcltest::DebugPArray --
-#
-# Prints the contents of the specified array if the current
-# debug level is higher than the provided level argument
-#
-# Arguments:
-# level The lowest debug level triggering the output
-# arrayvar The name of the array to print out.
-#
-# Results:
-# Prints the contents of the array. Nothing else is allowed.
-#
-
-proc ::tcltest::DebugPArray {level arrayvar} {
- variable debug
-
- if {$debug >= $level} {
- catch {upvar $arrayvar $arrayvar}
- parray $arrayvar
- }
-}
-
-# ::tcltest::DebugDo --
-#
-# Executes the script if the current debug level is greater than
-# the provided level argument
-#
-# Arguments:
-# level The lowest debug level triggering the execution.
-# script The tcl script executed upon a debug level high enough.
-#
-# Results:
-# Arbitrary side effects, dependent on the executed script.
-#
-
-proc ::tcltest::DebugDo {level script} {
- variable debug
-
- if {$debug >= $level} {
- uplevel $script
- }
-}
-
-# ::tcltest::AddToSkippedBecause --
-#
-# Increments the variable used to track how many tests were skipped
-# because of a particular constraint.
-#
-# Arguments:
-# constraint The name of the constraint to be modified
-#
-# Results:
-# Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't
-# previously exist - otherwise, it just increments it.
-
-proc ::tcltest::AddToSkippedBecause { constraint } {
- # add the constraint to the list of constraints that kept tests
- # from running
-
- if {[info exists ::tcltest::skippedBecause($constraint)]} {
- incr ::tcltest::skippedBecause($constraint)
- } else {
- set ::tcltest::skippedBecause($constraint) 1
- }
- return
-}
-
-# ::tcltest::PrintError --
-#
-# Prints errors to ::tcltest::errorChannel and then flushes that
-# channel, making sure that all messages are < 80 characters per line.
-#
-# Arguments:
-# errorMsg String containing the error to be printed
-#
-
-proc ::tcltest::PrintError {errorMsg} {
- set InitialMessage "Error: "
- set InitialMsgLen [string length $InitialMessage]
- puts -nonewline $::tcltest::errorChannel $InitialMessage
-
- # Keep track of where the end of the string is.
- set endingIndex [string length $errorMsg]
-
- if {$endingIndex < 80} {
- puts $::tcltest::errorChannel $errorMsg
- } else {
- # Print up to 80 characters on the first line, including the
- # InitialMessage.
- set beginningIndex [string last " " [string range $errorMsg 0 \
- [expr {80 - $InitialMsgLen}]]]
- puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
-
- while {$beginningIndex != "end"} {
- puts -nonewline $::tcltest::errorChannel \
- [string repeat " " $InitialMsgLen]
- if {[expr {$endingIndex - $beginningIndex}] < 72} {
- puts $::tcltest::errorChannel [string trim \
- [string range $errorMsg $beginningIndex end]]
- set beginningIndex end
- } else {
- set newEndingIndex [expr [string last " " [string range \
- $errorMsg $beginningIndex \
- [expr {$beginningIndex + 72}]]] + $beginningIndex]
- if {($newEndingIndex <= 0) \
- || ($newEndingIndex <= $beginningIndex)} {
- set newEndingIndex end
- }
- puts $::tcltest::errorChannel [string trim \
- [string range $errorMsg \
- $beginningIndex $newEndingIndex]]
- set beginningIndex $newEndingIndex
- }
- }
- }
- flush $::tcltest::errorChannel
- return
-}
-
-if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
- proc ::tcltest::initConstraintsHook {} {}
-}
-
-# ::tcltest::initConstraints --
-#
-# Check Constraintsuration information that will determine which tests
-# to run. To do this, create an array ::tcltest::testConstraints. Each
-# element has a 0 or 1 value. If the element is "true" then tests
-# with that constraint will be run, otherwise tests with that constraint
-# will be skipped. See the tcltest man page for the list of built-in
-# constraints defined in this procedure.
-#
-# Arguments:
-# none
-#
-# Results:
-# The ::tcltest::testConstraints array is reset to have an index for
-# each built-in test constraint.
-
-proc ::tcltest::initConstraints {} {
- global tcl_platform tcl_interactive tk_version
-
- # The following trace procedure makes it so that we can safely refer to
- # non-existent members of the ::tcltest::testConstraints array without
- # causing an error. Instead, reading a non-existent member will return 0.
- # This is necessary because tests are allowed to use constraint "X" without
- # ensuring that ::tcltest::testConstraints("X") is defined.
-
- trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
-
- proc ::tcltest::safeFetch {n1 n2 op} {
- if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
- set ::tcltest::testConstraints($n2) 0
- }
- }
-
- ::tcltest::initConstraintsHook
-
- set ::tcltest::testConstraints(unixOnly) \
- [string equal $tcl_platform(platform) "unix"]
- set ::tcltest::testConstraints(macOnly) \
- [string equal $tcl_platform(platform) "macintosh"]
- set ::tcltest::testConstraints(pcOnly) \
- [string equal $tcl_platform(platform) "windows"]
-
- set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
- set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
- set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
-
- set ::tcltest::testConstraints(unixOrPc) \
- [expr {$::tcltest::testConstraints(unix) \
- || $::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(macOrPc) \
- [expr {$::tcltest::testConstraints(mac) \
- || $::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(macOrUnix) \
- [expr {$::tcltest::testConstraints(mac) \
- || $::tcltest::testConstraints(unix)}]
-
- set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \
- "Windows NT"]
- set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \
- "Windows 95"]
- set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \
- "Windows 98"]
-
- # The following Constraints switches are used to mark tests that should
- # work, but have been temporarily disabled on certain platforms because
- # they don't and we haven't gotten around to fixing the underlying
- # problem.
-
- set ::tcltest::testConstraints(tempNotPc) \
- [expr {!$::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(tempNotMac) \
- [expr {!$::tcltest::testConstraints(mac)}]
- set ::tcltest::testConstraints(tempNotUnix) \
- [expr {!$::tcltest::testConstraints(unix)}]
-
- # The following Constraints switches are used to mark tests that crash on
- # certain platforms, so that they can be reactivated again when the
- # underlying problem is fixed.
-
- set ::tcltest::testConstraints(pcCrash) \
- [expr {!$::tcltest::testConstraints(pc)}]
- set ::tcltest::testConstraints(macCrash) \
- [expr {!$::tcltest::testConstraints(mac)}]
- set ::tcltest::testConstraints(unixCrash) \
- [expr {!$::tcltest::testConstraints(unix)}]
-
- # Skip empty tests
-
- set ::tcltest::testConstraints(emptyTest) 0
-
- # By default, tests that expose known bugs are skipped.
-
- set ::tcltest::testConstraints(knownBug) 0
-
- # By default, non-portable tests are skipped.
-
- set ::tcltest::testConstraints(nonPortable) 0
-
- # Some tests require user interaction.
-
- set ::tcltest::testConstraints(userInteraction) 0
-
- # Some tests must be skipped if the interpreter is not in interactive mode
-
- if {[info exists tcl_interactive]} {
- set ::tcltest::testConstraints(interactive) $::tcl_interactive
- } else {
- set ::tcltest::testConstraints(interactive) 0
- }
-
- # Some tests can only be run if the installation came from a CD image
- # instead of a web image
- # Some tests must be skipped if you are running as root on Unix.
- # Other tests can only be run if you are running as root on Unix.
-
- set ::tcltest::testConstraints(root) 0
- set ::tcltest::testConstraints(notRoot) 1
- set user {}
- if {[string equal $tcl_platform(platform) "unix"]} {
- catch {set user [exec whoami]}
- if {[string equal $user ""]} {
- catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
- }
- if {([string equal $user "root"]) || ([string equal $user ""])} {
- set ::tcltest::testConstraints(root) 1
- set ::tcltest::testConstraints(notRoot) 0
- }
- }
-
- # Set nonBlockFiles constraint: 1 means this platform supports
- # setting files into nonblocking mode.
-
- if {[catch {set f [open defs r]}]} {
- set ::tcltest::testConstraints(nonBlockFiles) 1
- } else {
- if {[catch {fconfigure $f -blocking off}] == 0} {
- set ::tcltest::testConstraints(nonBlockFiles) 1
- } else {
- set ::tcltest::testConstraints(nonBlockFiles) 0
- }
- close $f
- }
-
- # Set asyncPipeClose constraint: 1 means this platform supports
- # async flush and async close on a pipe.
- #
- # Test for SCO Unix - cannot run async flushing tests because a
- # potential problem with select is apparently interfering.
- # (Mark Diekhans).
-
- if {[string equal $tcl_platform(platform) "unix"]} {
- if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
- set ::tcltest::testConstraints(asyncPipeClose) 0
- } else {
- set ::tcltest::testConstraints(asyncPipeClose) 1
- }
- } else {
- set ::tcltest::testConstraints(asyncPipeClose) 1
- }
-
- # Test to see if we have a broken version of sprintf with respect
- # to the "e" format of floating-point numbers.
-
- set ::tcltest::testConstraints(eformat) 1
- if {![string equal "[format %g 5e-5]" "5e-05"]} {
- set ::tcltest::testConstraints(eformat) 0
- }
-
- # Test to see if execed commands such as cat, echo, rm and so forth are
- # present on this machine.
-
- set ::tcltest::testConstraints(unixExecs) 1
- if {[string equal $tcl_platform(platform) "macintosh"]} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([string equal $tcl_platform(platform) "windows"])} {
- if {[catch {exec cat defs}] == 1} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec echo hello}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec sh -c echo hello}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec wc defs}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {$::tcltest::testConstraints(unixExecs) == 1} {
- exec echo hello > removeMe
- if {[catch {exec rm removeMe}] == 1} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec sleep 1}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec fgrep unixExecs defs}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec ps}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec echo abc > removeMe}] == 0) && \
- ([catch {exec chmod 644 removeMe}] == 1) && \
- ([catch {exec rm removeMe}] == 0)} {
- set ::tcltest::testConstraints(unixExecs) 0
- } else {
- catch {exec rm -f removeMe}
- }
- if {($::tcltest::testConstraints(unixExecs) == 1) && \
- ([catch {exec mkdir removeMe}] == 1)} {
- set ::tcltest::testConstraints(unixExecs) 0
- } else {
- catch {exec rm -r removeMe}
- }
- }
-
- # Locate tcltest executable
-
- if {![info exists tk_version]} {
- set tcltest [info nameofexecutable]
-
- if {$tcltest == "{}"} {
- set tcltest {}
- }
- }
-
- set ::tcltest::testConstraints(stdio) 0
- catch {
- catch {file delete -force tmp}
- set f [open tmp w]
- puts $f {
- exit
- }
- close $f
-
- set f [open "|[list $tcltest tmp]" r]
- close $f
-
- set ::tcltest::testConstraints(stdio) 1
- }
- catch {file delete -force tmp}
-
- # Deliberately call socket with the wrong number of arguments. The error
- # message you get will indicate whether sockets are available on this
- # system.
-
- catch {socket} msg
- set ::tcltest::testConstraints(socket) \
- [expr {$msg != "sockets are not available on this system"}]
-
- # Check for internationalization
-
- if {[info commands testlocale] == ""} {
- # No testlocale command, no tests...
- set ::tcltest::testConstraints(hasIsoLocale) 0
- } else {
- set ::tcltest::testConstraints(hasIsoLocale) \
- [string length [::tcltest::set_iso8859_1_locale]]
- ::tcltest::restore_locale
- }
-}
-
-# ::tcltest::PrintUsageInfoHook
-#
-# Hook used for customization of display of usage information.
-#
-
-if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
- proc ::tcltest::PrintUsageInfoHook {} {}
-}
-
-# ::tcltest::PrintUsageInfo
-#
-# Prints out the usage information for package tcltest. This can be
-# customized with the redefinition of ::tcltest::PrintUsageInfoHook.
-#
-# Arguments:
-# none
-#
-
-proc ::tcltest::PrintUsageInfo {} {
- puts [format "Usage: [file tail [info nameofexecutable]] \
- script ?-help? ?flag value? ... \n\
- Available flags (and valid input values) are: \n\
- -help \t Display this usage information. \n\
- -verbose level \t Takes any combination of the values \n\
- \t 'p', 's' and 'b'. Test suite will \n\
- \t display all passed tests if 'p' is \n\
- \t specified, all skipped tests if 's' \n\
- \t is specified, and the bodies of \n\
- \t failed tests if 'b' is specified. \n\
- \t The default value is 'b'. \n\
- -constraints list\t Do not skip the listed constraints\n\
- -limitconstraints bool\t Only run tests with the constraints\n\
- \t listed in -constraints.\n\
- -match pattern \t Run all tests within the specified \n\
- \t files that match the glob pattern \n\
- \t given. \n\
- -skip pattern \t Skip all tests within the set of \n\
- \t specified tests (via -match) and \n\
- \t files that match the glob pattern \n\
- \t given. \n\
- -file pattern \t Run tests in all test files that \n\
- \t match the glob pattern given. \n\
- -notfile pattern\t Skip all test files that match the \n\
- \t glob pattern given. \n\
- -preservecore level \t If 2, save any core files produced \n\
- \t during testing in the directory \n\
- \t specified by -tmpdir. If 1, notify the\n\
- \t user if core files are created. The default \n\
- \t is $::tcltest::preserveCore. \n\
- -tmpdir directory\t Save temporary files in the specified\n\
- \t directory. The default value is \n\
- \t $::tcltest::temporaryDirectory. \n\
- -testdir directories\t Search tests in the specified\n\
- \t directories. The default value is \n\
- \t $::tcltest::testsDirectory. \n\
- -outfile file \t Send output from test runs to the \n\
- \t specified file. The default is \n\
- \t stdout. \n\
- -errfile file \t Send errors from test runs to the \n\
- \t specified file. The default is \n\
- \t stderr. \n\
- -loadfile file \t Read the script to load the tested \n\
- \t commands from the specified file. \n\
- -load script \t Specifies the script to load the tested \n\
- \t commands. \n\
- -debug level \t Internal debug flag."]
- ::tcltest::PrintUsageInfoHook
- return
-}
-
-# ::tcltest::CheckDirectory --
-#
-# This procedure checks whether the specified path is a readable
-# and/or writable directory. If one of the conditions is not
-# satisfied an error is printed and the application aborted. The
-# procedure assumes that the caller already checked the existence
-# of the path.
-#
-# Arguments
-# rw Information what attributes to check. Allowed values:
-# r, w, rw, wr. If 'r' is part of the value the directory
-# must be readable. 'w' associates to 'writable'.
-# dir The directory to check.
-# errMsg The string to prepend to the actual error message before
-# printing it.
-#
-# Results
-# none
-#
-
-proc ::tcltest::CheckDirectory {rw dir errMsg} {
- # Allowed values for 'rw': r, w, rw, wr
-
- if {![file isdir $dir]} {
- ::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
- exit 1
- } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
- ::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
- exit 1
- } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
- ::tcltest::PrintError "$errMsg \"$dir\" is not readable"
- exit 1
- }
-}
-
-# ::tcltest::normalizePath --
-#
-# This procedure resolves any symlinks in the path thus creating a
-# path without internal redirection. It assumes that the incoming
-# path is absolute.
-#
-# Arguments
-# pathVar contains the name of the variable containing the path to modify.
-#
-# Results
-# The path is modified in place.
-#
-
-proc ::tcltest::normalizePath {pathVar} {
- upvar $pathVar path
-
- set oldpwd [pwd]
- catch {cd $path}
- set path [pwd]
- cd $oldpwd
-}
-
-# ::tcltest::MakeAbsolutePath --
-#
-# This procedure checks whether the incoming path is absolute or not.
-# Makes it absolute if it was not.
-#
-# Arguments
-# pathVar contains the name of the variable containing the path to modify.
-# prefix is optional, contains the path to use to make the other an
-# absolute one. The current working directory is used if it was
-# not specified.
-#
-# Results
-# The path is modified in place.
-#
-
-proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
- upvar $pathVar path
-
- if {![string equal [file pathtype $path] "absolute"]} {
- if {$prefix == {}} {
- set prefix [pwd]
- }
-
- set path [file join $prefix $path]
- }
-}
-
-# ::tcltest::processCmdLineArgsFlagsHook --
-#
-# This hook is used to add to the list of command line arguments that are
-# processed by ::tcltest::processCmdLineArgs.
-#
-
-if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
- proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
-}
-
-# ::tcltest::processCmdLineArgsHook --
-#
-# This hook is used to actually process the flags added by
-# ::tcltest::processCmdLineArgsAddFlagsHook.
-#
-# Arguments:
-# flags The flags that have been pulled out of argv
-#
-
-if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
- proc ::tcltest::processCmdLineArgsHook {flag} {}
-}
-
-# ::tcltest::processCmdLineArgs --
-#
-# Use command line args to set the verbose, skip, and
-# match, outputChannel, errorChannel, debug, and temporaryDirectory
-# variables.
-#
-# This procedure must be run after constraints are initialized, because
-# some constraints can be overridden.
-#
-# Arguments:
-# none
-#
-# Results:
-# Sets the above-named variables in the tcltest namespace.
-
-proc ::tcltest::processCmdLineArgs {} {
- global argv
-
- # The "argv" var doesn't exist in some cases, so use {}.
-
- if {(![info exists argv]) || ([llength $argv] < 1)} {
- set flagArray {}
- } else {
- set flagArray $argv
- }
-
- # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
- # Note that -verbose cannot be abbreviated to -v in wish because it
- # conflicts with the wish option -visual.
-
- # Process -help first
- if {([lsearch -exact $flagArray {-help}] != -1) || \
- ([lsearch -exact $flagArray {-h}] != -1)} {
- ::tcltest::PrintUsageInfo
- exit 1
- }
-
- if {[catch {array set flag $flagArray}]} {
- ::tcltest::PrintError "odd number of arguments specified on command line: \
- $argv"
- ::tcltest::PrintUsageInfo
- exit 1
- }
-
- # -help is not listed since it has already been processed
- lappend defaultFlags -verbose -match -skip -constraints \
- -outfile -errfile -debug -tmpdir -file -notfile \
- -preservecore -limitconstraints -args -testdir \
- -load -loadfile
- set defaultFlags [concat $defaultFlags \
- [ ::tcltest::processCmdLineArgsAddFlagsHook ]]
-
- foreach arg $defaultFlags {
- set abbrev [string range $arg 0 1]
- if {([info exists flag($abbrev)]) && \
- ([lsearch -exact $flagArray $arg] < [lsearch -exact \
- $flagArray $abbrev])} {
- set flag($arg) $flag($abbrev)
- }
- }
-
- # Set ::tcltest::parameters to the arg of the -args flag, if given
- if {[info exists flag(-args)]} {
- set ::tcltest::parameters $flag(-args)
- }
-
- # Set ::tcltest::verbose to the arg of the -verbose flag, if given
-
- if {[info exists flag(-verbose)]} {
- set ::tcltest::verbose $flag(-verbose)
- }
-
- # Set ::tcltest::match to the arg of the -match flag, if given.
-
- if {[info exists flag(-match)]} {
- set ::tcltest::match $flag(-match)
- }
-
- # Set ::tcltest::skip to the arg of the -skip flag, if given
-
- if {[info exists flag(-skip)]} {
- set ::tcltest::skip $flag(-skip)
- }
-
- # Handle the -file and -notfile flags
- if {[info exists flag(-file)]} {
- set ::tcltest::matchFiles $flag(-file)
- }
- if {[info exists flag(-notfile)]} {
- set ::tcltest::skipFiles $flag(-notfile)
- }
-
- # Use the -constraints flag, if given, to turn on constraints that are
- # turned off by default: userInteractive knownBug nonPortable. This
- # code fragment must be run after constraints are initialized.
-
- if {[info exists flag(-constraints)]} {
- foreach elt $flag(-constraints) {
- set ::tcltest::testConstraints($elt) 1
- }
- }
-
- # Use the -limitconstraints flag, if given, to tell the harness to limit
- # tests run to those that were specified using the -constraints flag. If
- # the -constraints flag was not specified, print out an error and exit.
- if {[info exists flag(-limitconstraints)]} {
- if {![info exists flag(-constraints)]} {
- puts "You can only use the -limitconstraints flag with \
- -constraints"
- exit 1
- }
- set ::tcltest::limitConstraints $flag(-limitconstraints)
- foreach elt [array names ::tcltest::testConstraints] {
- if {[lsearch -exact $flag(-constraints) $elt] == -1} {
- set ::tcltest::testConstraints($elt) 0
- }
- }
- }
-
- # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
- # given.
- #
- # If the path is relative, make it absolute. If the file exists but
- # is not a dir, then return an error.
- #
- # If ::tcltest::temporaryDirectory does not already exist, create it.
- # If you cannot create it, then return an error.
-
- set tmpDirError ""
- if {[info exists flag(-tmpdir)]} {
- set ::tcltest::temporaryDirectory $flag(-tmpdir)
-
- MakeAbsolutePath ::tcltest::temporaryDirectory
- set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
- }
- if {[file exists $::tcltest::temporaryDirectory]} {
- ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
- } else {
- file mkdir $::tcltest::temporaryDirectory
- }
-
- normalizePath ::tcltest::temporaryDirectory
-
- # Set the ::tcltest::testsDirectory to the arg of -testdir, if
- # given.
- #
- # If the path is relative, make it absolute. If the file exists but
- # is not a dir, then return an error.
- #
- # If ::tcltest::temporaryDirectory does not already exist return an error.
-
- set testDirError ""
- if {[info exists flag(-testdir)]} {
- set ::tcltest::testsDirectory $flag(-testdir)
-
- MakeAbsolutePath ::tcltest::testsDirectory
- set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
- }
- if {[file exists $::tcltest::testsDirectory]} {
- ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
- } else {
- ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
- does not exist"
- exit 1
- }
-
- normalizePath ::tcltest::testsDirectory
-
- # Save the names of files that already exist in
- # the output directory.
- foreach file [glob -nocomplain \
- [file join $::tcltest::temporaryDirectory *]] {
- lappend ::tcltest::filesExisted [file tail $file]
- }
-
- # If an alternate error or output files are specified, change the
- # default channels.
-
- if {[info exists flag(-outfile)]} {
- set tmp $flag(-outfile)
- MakeAbsolutePath tmp $::tcltest::temporaryDirectory
- set ::tcltest::outputChannel [open $tmp w]
- }
-
- if {[info exists flag(-errfile)]} {
- set tmp $flag(-errfile)
- MakeAbsolutePath tmp $::tcltest::temporaryDirectory
- set ::tcltest::errorChannel [open $tmp w]
- }
-
- # If a load script was specified, either directly or through
- # a file, remember it for later usage.
-
- if {[info exists flag(-load)] && \
- ([lsearch -exact $flagArray -load] > \
- [lsearch -exact $flagArray -loadfile])} {
- set ::tcltest::loadScript $flag(-load)
- }
-
- if {[info exists flag(-loadfile)] && \
- ([lsearch -exact $flagArray -loadfile] > \
- [lsearch -exact $flagArray -load]) } {
- set tmp $flag(-loadfile)
- MakeAbsolutePath tmp $::tcltest::temporaryDirectory
- set tmp [open $tmp r]
- set ::tcltest::loadScript [read $tmp]
- close $tmp
- }
-
- # If the user specifies debug testing, print out extra information during
- # the run.
- if {[info exists flag(-debug)]} {
- set ::tcltest::debug $flag(-debug)
- }
-
- # Handle -preservecore
- if {[info exists flag(-preservecore)]} {
- set ::tcltest::preserveCore $flag(-preservecore)
- }
-
- # Call the hook
- ::tcltest::processCmdLineArgsHook [array get flag]
-
- # Spit out everything you know if we're at a debug level 2 or greater
-
- DebugPuts 2 "Flags passed into tcltest:"
- DebugPArray 2 flag
- DebugPuts 2 "::tcltest::debug = $::tcltest::debug"
- DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory"
- DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory"
- DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
- DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel"
- DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel"
- DebugPuts 2 "Original environment (::tcltest::originalEnv):"
- DebugPArray 2 ::tcltest::originalEnv
- DebugPuts 2 "Constraints:"
- DebugPArray 2 ::tcltest::testConstraints
-}
-
-# ::tcltest::loadTestedCommands --
-#
-# Uses the specified script to load the commands to test. Allowed to
-# be empty, as the tested commands could have been compiled into the
-# interpreter.
-#
-# Arguments
-# none
-#
-# Results
-# none
-
-proc ::tcltest::loadTestedCommands {} {
- if {$::tcltest::loadScript == {}} {
- return
- }
-
- uplevel #0 $::tcltest::loadScript
-}
-
-# ::tcltest::cleanupTests --
-#
-# Remove files and dirs created using the makeFile and makeDirectory
-# commands since the last time this proc was invoked.
-#
-# Print the names of the files created without the makeFile command
-# since the tests were invoked.
-#
-# Print the number tests (total, passed, failed, and skipped) since the
-# tests were invoked.
-#
-# Restore original environment (as reported by special variable env).
-
-proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
-
- set testFileName [file tail [info script]]
-
- # Call the cleanup hook
- ::tcltest::cleanupTestsHook
-
- # Remove files and directories created by the :tcltest::makeFile and
- # ::tcltest::makeDirectory procedures.
- # Record the names of files in ::tcltest::workingDirectory that were not
- # pre-existing, and associate them with the test file that created them.
-
- if {!$calledFromAllFile} {
- foreach file $::tcltest::filesMade {
- if {[file exists $file]} {
- catch {file delete -force $file}
- }
- }
- set currentFiles {}
- foreach file [glob -nocomplain \
- [file join $::tcltest::temporaryDirectory *]] {
- lappend currentFiles [file tail $file]
- }
- set newFiles {}
- foreach file $currentFiles {
- if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
- lappend newFiles $file
- }
- }
- set ::tcltest::filesExisted $currentFiles
- if {[llength $newFiles] > 0} {
- set ::tcltest::createdNewFiles($testFileName) $newFiles
- }
- }
-
- if {$calledFromAllFile || $::tcltest::testSingleFile} {
-
- # print stats
-
- puts -nonewline $::tcltest::outputChannel "$testFileName:"
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- puts -nonewline $::tcltest::outputChannel \
- "\t$index\t$::tcltest::numTests($index)"
- }
- puts $::tcltest::outputChannel ""
-
- # print number test files sourced
- # print names of files that ran tests which failed
-
- if {$calledFromAllFile} {
- puts $::tcltest::outputChannel \
- "Sourced $::tcltest::numTestFiles Test Files."
- set ::tcltest::numTestFiles 0
- if {[llength $::tcltest::failFiles] > 0} {
- puts $::tcltest::outputChannel \
- "Files with failing tests: $::tcltest::failFiles"
- set ::tcltest::failFiles {}
- }
- }
-
- # if any tests were skipped, print the constraints that kept them
- # from running.
-
- set constraintList [array names ::tcltest::skippedBecause]
- if {[llength $constraintList] > 0} {
- puts $::tcltest::outputChannel \
- "Number of tests skipped for each constraint:"
- foreach constraint [lsort $constraintList] {
- puts $::tcltest::outputChannel \
- "\t$::tcltest::skippedBecause($constraint)\t$constraint"
- unset ::tcltest::skippedBecause($constraint)
- }
- }
-
- # report the names of test files in ::tcltest::createdNewFiles, and
- # reset the array to be empty.
-
- set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
- if {[llength $testFilesThatTurded] > 0} {
- puts $::tcltest::outputChannel "Warning: files left behind:"
- foreach testFile $testFilesThatTurded {
- puts $::tcltest::outputChannel \
- "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
- unset ::tcltest::createdNewFiles($testFile)
- }
- }
-
- # reset filesMade, filesExisted, and numTests
-
- set ::tcltest::filesMade {}
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- set ::tcltest::numTests($index) 0
- }
-
- # exit only if running Tk in non-interactive mode
-
- global tk_version tcl_interactive
- if {[info exists tk_version] && ![info exists tcl_interactive]} {
- exit
- }
- } else {
-
- # if we're deferring stat-reporting until all files are sourced,
- # then add current file to failFile list if any tests in this file
- # failed
-
- incr ::tcltest::numTestFiles
- if {($::tcltest::currentFailure) && \
- ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
- lappend ::tcltest::failFiles $testFileName
- }
- set ::tcltest::currentFailure false
-
- # restore the environment to the state it was in before this package
- # was loaded
-
- set newEnv {}
- set changedEnv {}
- set removedEnv {}
- foreach index [array names ::env] {
- if {![info exists ::tcltest::originalEnv($index)]} {
- lappend newEnv $index
- unset ::env($index)
- } else {
- if {$::env($index) != $::tcltest::originalEnv($index)} {
- lappend changedEnv $index
- set ::env($index) $::tcltest::originalEnv($index)
- }
- }
- }
- foreach index [array names ::tcltest::originalEnv] {
- if {![info exists ::env($index)]} {
- lappend removedEnv $index
- set ::env($index) $::tcltest::originalEnv($index)
- }
- }
- if {[llength $newEnv] > 0} {
- puts $::tcltest::outputChannel \
- "env array elements created:\t$newEnv"
- }
- if {[llength $changedEnv] > 0} {
- puts $::tcltest::outputChannel \
- "env array elements changed:\t$changedEnv"
- }
- if {[llength $removedEnv] > 0} {
- puts $::tcltest::outputChannel \
- "env array elements removed:\t$removedEnv"
- }
-
- set changedTclPlatform {}
- foreach index [array names ::tcltest::originalTclPlatform] {
- if {$::tcl_platform($index) != \
- $::tcltest::originalTclPlatform($index)} {
- lappend changedTclPlatform $index
- set ::tcl_platform($index) \
- $::tcltest::originalTclPlatform($index)
- }
- }
- if {[llength $changedTclPlatform] > 0} {
- puts $::tcltest::outputChannel \
- "tcl_platform array elements changed:\t$changedTclPlatform"
- }
-
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
- if {$::tcltest::preserveCore > 1} {
- puts $::tcltest::outputChannel "produced core file! \
- Moving file to: \
- [file join $::tcltest::temporaryDirectory core-$name]"
- flush $::tcltest::outputChannel
- catch {file rename -force \
- [file join $::tcltest::workingDirectory core] \
- [file join $::tcltest::temporaryDirectory \
- core-$name]} msg
- if {[string length $msg] > 0} {
- ::tcltest::PrintError "Problem renaming file: $msg"
- }
- } else {
- # Print a message if there is a core file and (1) there
- # previously wasn't one or (2) the new one is different from
- # the old one.
-
- if {[info exists ::tcltest::coreModificationTime]} {
- if {$::tcltest::coreModificationTime != [file mtime \
- [file join $::tcltest::workingDirectory core]]} {
- puts $::tcltest::outputChannel "A core file was created!"
- }
- } else {
- puts $::tcltest::outputChannel "A core file was created!"
- }
- }
- }
- }
-}
-
-# ::tcltest::cleanupTestsHook --
-#
-# This hook allows a harness that builds upon tcltest to specify
-# additional things that should be done at cleanup.
-#
-
-if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
- proc ::tcltest::cleanupTestsHook {} {}
-}
-
-# test --
-#
-# This procedure runs a test and prints an error message if the test fails.
-# If ::tcltest::verbose has been set, it also prints a message even if the
-# test succeeds. The test will be skipped if it doesn't match the
-# ::tcltest::match variable, if it matches an element in
-# ::tcltest::skip, or if one of the elements of "constraints" turns
-# out not to be true.
-#
-# Arguments:
-# name - Name of test, in the form foo-1.2.
-# description - Short textual description of the test, to
-# help humans understand what it does.
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "::tcltest::testConstraints". If any of these
-# elements is zero, the test is skipped.
-# This argument may be omitted.
-# script - Script to run to carry out the test. It must
-# return a result that can be checked for
-# correctness.
-# expectedAnswer - Expected result from script.
-
-proc ::tcltest::test {name description script expectedAnswer args} {
-
- DebugPuts 3 "Running $name ($description)"
-
- incr ::tcltest::numTests(Total)
-
- # skip the test if it's name matches an element of skip
-
- foreach pattern $::tcltest::skip {
- if {[string match $pattern $name]} {
- incr ::tcltest::numTests(Skipped)
- DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
- return
- }
- }
-
- # skip the test if it's name doesn't match any element of match
-
- if {[llength $::tcltest::match] > 0} {
- set ok 0
- foreach pattern $::tcltest::match {
- if {[string match $pattern $name]} {
- set ok 1
- break
- }
- }
- if {!$ok} {
- incr ::tcltest::numTests(Skipped)
- DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
- return
- }
- }
-
- set i [llength $args]
- if {$i == 0} {
- set constraints {}
- # If we're limited to the listed constraints and there aren't any
- # listed, then we shouldn't run the test.
- if {$::tcltest::limitConstraints} {
- ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
- incr ::tcltest::numTests(Skipped)
- return
- }
- } elseif {$i == 1} {
-
- # "constraints" argument exists; shuffle arguments down, then
- # make sure that the constraints are satisfied.
-
- set constraints $script
- set script $expectedAnswer
- set expectedAnswer [lindex $args 0]
- set doTest 0
- if {[string match {*[$\[]*} $constraints] != 0} {
- # full expression, e.g. {$foo > [info tclversion]}
- catch {set doTest [uplevel #0 expr $constraints]}
- } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
- # something like {a || b} should be turned into
- # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
- regsub -all {[.\w]+} $constraints \
- {$::tcltest::testConstraints(&)} c
- catch {set doTest [eval expr $c]}
- } else {
- # just simple constraints such as {unixOnly fonts}.
- set doTest 1
- foreach constraint $constraints {
- if {(![info exists ::tcltest::testConstraints($constraint)]) \
- || (!$::tcltest::testConstraints($constraint))} {
- set doTest 0
-
- # store the constraint that kept the test from running
- set constraints $constraint
- break
- }
- }
- }
- if {$doTest == 0} {
- if {[string first s $::tcltest::verbose] != -1} {
- puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
- }
-
- incr ::tcltest::numTests(Skipped)
- ::tcltest::AddToSkippedBecause $constraints
- return
- }
- } else {
- error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
- }
-
- # Save information about the core file. You need to restore the original
- # tcl_platform environment because some of the tests mess with tcl_platform.
-
- if {$::tcltest::preserveCore} {
- set currentTclPlatform [array get tcl_platform]
- array set tcl_platform $::tcltest::originalTclPlatform
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
- set coreModTime [file mtime [file join \
- $::tcltest::workingDirectory core]]
- }
- array set tcl_platform $currentTclPlatform
- }
-
- # If there is no "memory" command (because memory debugging isn't
- # enabled), then don't attempt to use the command.
-
- if {[info commands memory] != {}} {
- memory tag $name
- }
-
- set code [catch {uplevel $script} actualAnswer]
- if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
- incr ::tcltest::numTests(Passed)
- if {[string first p $::tcltest::verbose] != -1} {
- puts $::tcltest::outputChannel "++++ $name PASSED"
- }
- } else {
- incr ::tcltest::numTests(Failed)
- set ::tcltest::currentFailure true
- if {[string first b $::tcltest::verbose] == -1} {
- set script ""
- }
- puts $::tcltest::outputChannel "\n==== $name $description FAILED"
- if {$script != ""} {
- puts $::tcltest::outputChannel "==== Contents of test case:"
- puts $::tcltest::outputChannel $script
- }
- if {$code != 0} {
- if {$code == 1} {
- puts $::tcltest::outputChannel "==== Test generated error:"
- puts $::tcltest::outputChannel $actualAnswer
- } elseif {$code == 2} {
- puts $::tcltest::outputChannel "==== Test generated return exception; result was:"
- puts $::tcltest::outputChannel $actualAnswer
- } elseif {$code == 3} {
- puts $::tcltest::outputChannel "==== Test generated break exception"
- } elseif {$code == 4} {
- puts $::tcltest::outputChannel "==== Test generated continue exception"
- } else {
- puts $::tcltest::outputChannel "==== Test generated exception $code; message was:"
- puts $::tcltest::outputChannel $actualAnswer
- }
- } else {
- puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
- }
- puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
- puts $::tcltest::outputChannel "==== $name FAILED\n"
- }
- if {$::tcltest::preserveCore} {
- set currentTclPlatform [array get tcl_platform]
- if {[file exists [file join $::tcltest::workingDirectory core]]} {
- if {$::tcltest::preserveCore > 1} {
- puts $::tcltest::outputChannel "==== $name produced core file! \
- Moving file to: \
- [file join $::tcltest::temporaryDirectory core-$name]"
- catch {file rename -force \
- [file join $::tcltest::workingDirectory core] \
- [file join $::tcltest::temporaryDirectory \
- core-$name]} msg
- if {[string length $msg] > 0} {
- ::tcltest::PrintError "Problem renaming file: $msg"
- }
- } else {
- # Print a message if there is a core file and (1) there
- # previously wasn't one or (2) the new one is different from
- # the old one.
-
- if {[info exists coreModTime]} {
- if {$coreModTime != [file mtime \
- [file join $::tcltest::workingDirectory core]]} {
- puts $::tcltest::outputChannel "==== $name produced core file!"
- }
- } else {
- puts $::tcltest::outputChannel "==== $name produced core file!"
- }
- }
- }
- array set tcl_platform $currentTclPlatform
- }
-}
-
-# ::tcltest::getMatchingFiles
-#
-# Looks at the patterns given to match and skip files
-# and uses them to put together a list of the tests that will be run.
-#
-# Arguments:
-# none
-#
-# Results:
-# The constructed list is returned to the user. This will primarily
-# be used in 'all.tcl' files.
-
-proc ::tcltest::getMatchingFiles {args} {
- set matchingFiles {}
- if {[llength $args]} {
- set searchDirectory $args
- } else {
- set searchDirectory [list $::tcltest::testsDirectory]
- }
- # Find the matching files in the list of directories and then remove the
- # ones that match the skip pattern
- foreach directory $searchDirectory {
- set matchFileList {}
- foreach match $::tcltest::matchFiles {
- set matchFileList [concat $matchFileList \
- [glob -nocomplain [file join $directory $match]]]
- }
- if {[string compare {} $::tcltest::skipFiles]} {
- set skipFileList {}
- foreach skip $::tcltest::skipFiles {
- set skipFileList [concat $skipFileList \
- [glob -nocomplain [file join $directory $skip]]]
- }
- foreach file $matchFileList {
- # Only include files that don't match the skip pattern and
- # aren't SCCS lock files.
- if {([lsearch -exact $skipFileList $file] == -1) && \
- (![string match l.*.test [file tail $file]])} {
- lappend matchingFiles $file
- }
- }
- } else {
- set matchingFiles [concat $matchingFiles $matchFileList]
- }
- }
- if {[string equal $matchingFiles {}]} {
- ::tcltest::PrintError "No test files remain after applying \
- your match and skip patterns!"
- }
- return $matchingFiles
-}
-
-# The following two procs are used in the io tests.
-
-proc ::tcltest::openfiles {} {
- if {[catch {testchannel open} result]} {
- return {}
- }
- return $result
-}
-
-proc ::tcltest::leakfiles {old} {
- if {[catch {testchannel open} new]} {
- return {}
- }
- set leak {}
- foreach p $new {
- if {[lsearch $old $p] < 0} {
- lappend leak $p
- }
- }
- return $leak
-}
-
-# ::tcltest::saveState --
-#
-# Save information regarding what procs and variables exist.
-#
-# Arguments:
-# none
-#
-# Results:
-# Modifies the variable ::tcltest::saveState
-
-proc ::tcltest::saveState {} {
- uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
- DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState"
-}
-
-# ::tcltest::restoreState --
-#
-# Remove procs and variables that didn't exist before the call to
-# ::tcltest::saveState.
-#
-# Arguments:
-# none
-#
-# Results:
-# Removes procs and variables from your environment if they don't exist
-# in the ::tcltest::saveState variable.
-
-proc ::tcltest::restoreState {} {
- foreach p [info procs] {
- if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
- (![string equal ::tcltest::$p [namespace origin $p]])} {
-
- DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
- rename $p {}
- }
- }
- foreach p [uplevel #0 {info vars}] {
- if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
- DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
- uplevel #0 "catch {unset $p}"
- }
- }
-}
-
-# ::tcltest::normalizeMsg --
-#
-# Removes "extra" newlines from a string.
-#
-# Arguments:
-# msg String to be modified
-#
-
-proc ::tcltest::normalizeMsg {msg} {
- regsub "\n$" [string tolower $msg] "" msg
- regsub -all "\n\n" $msg "\n" msg
- regsub -all "\n\}" $msg "\}" msg
- return $msg
-}
-
-# makeFile --
-#
-# Create a new file with the name <name>, and write <contents> to it.
-#
-# If this file hasn't been created via makeFile since the last time
-# cleanupTests was called, add it to the $filesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-proc ::tcltest::makeFile {contents name} {
- global tcl_platform
-
- DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
-
- set fullName [file join $::tcltest::temporaryDirectory $name]
- set fd [open $fullName w]
-
- fconfigure $fd -translation lf
-
- if {[string equal [string index $contents end] "\n"]} {
- puts -nonewline $fd $contents
- } else {
- puts $fd $contents
- }
- close $fd
-
- if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
- lappend ::tcltest::filesMade $fullName
- }
- return $fullName
-}
-
-# ::tcltest::removeFile --
-#
-# Removes the named file from the filesystem
-#
-# Arguments:
-# name file to be removed
-#
-
-proc ::tcltest::removeFile {name} {
- DebugPuts 3 "::tcltest::removeFile: removing $name"
- file delete [file join $::tcltest::temporaryDirectory $name]
-}
-
-# makeDirectory --
-#
-# Create a new dir with the name <name>.
-#
-# If this dir hasn't been created via makeDirectory since the last time
-# cleanupTests was called, add it to the $directoriesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-proc ::tcltest::makeDirectory {name} {
- file mkdir $name
-
- set fullName [file join [pwd] $name]
- if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
- lappend ::tcltest::filesMade $fullName
- }
-}
-
-# ::tcltest::removeDirectory --
-#
-# Removes a named directory from the file system.
-#
-# Arguments:
-# name Name of the directory to remove
-#
-
-proc ::tcltest::removeDirectory {name} {
- file delete -force $name
-}
-
-proc ::tcltest::viewFile {name} {
- global tcl_platform
- if {([string equal $tcl_platform(platform) "macintosh"]) || \
- ($::tcltest::testConstraints(unixExecs) == 0)} {
- set f [open [file join $::tcltest::temporaryDirectory $name]]
- set data [read -nonewline $f]
- close $f
- return $data
- } else {
- exec cat [file join $::tcltest::temporaryDirectory $name]
- }
-}
-
-# grep --
-#
-# Evaluate a given expression against each element of a list and return all
-# elements for which the expression evaluates to true. For the purposes of
-# this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
-# value of the current element within the expression. This is equivalent to
-# the perl grep command where CURRENT_ELEMENT would be the name for the special
-# variable $_.
-#
-# Examples of usage would be:
-# set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
-# set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
-#
-# Use of the CURRENT_ELEMENT keyword is optional. If it is left out, it is
-# assumed to be the final argument to the expression provided.
-#
-# Example:
-# grep {regexp a} $someList
-#
-proc ::tcltest::grep { expression searchList } {
- foreach element $searchList {
- if {[regsub -all CURRENT_ELEMENT $expression $element \
- newExpression] == 0} {
- set newExpression "$expression {$element}"
- }
- if {[eval $newExpression] == 1} {
- lappend returnList $element
- }
- }
- if {[info exists returnList]} {
- return $returnList
- }
- return
-}
-
-#
-# Construct a string that consists of the requested sequence of bytes,
-# as opposed to a string of properly formed UTF-8 characters.
-# This allows the tester to
-# 1. Create denormalized or improperly formed strings to pass to C procedures
-# that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-# to confirm that "\xe0\0" in a Tcl script is stored internally in
-# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
-#
-# Generally, it's a bad idea to examine the bytes in a Tcl string or to
-# construct improperly formed strings in this manner, because it involves
-# exposing that Tcl uses UTF-8 internally.
-
-proc ::tcltest::bytestring {string} {
- encoding convertfrom identity $string
-}
-
-#
-# Internationalization / ISO support procs -- dl
-#
-proc ::tcltest::set_iso8859_1_locale {} {
- if {[info commands testlocale] != ""} {
- set ::tcltest::previousLocale [testlocale ctype]
- testlocale ctype $::tcltest::isoLocale
- }
- return
-}
-
-proc ::tcltest::restore_locale {} {
- if {[info commands testlocale] != ""} {
- testlocale ctype $::tcltest::previousLocale
- }
- return
-}
-
-# threadReap --
-#
-# Kill all threads except for the main thread.
-# Do nothing if testthread is not defined.
-#
-# Arguments:
-# none.
-#
-# Results:
-# Returns the number of existing threads.
-proc ::tcltest::threadReap {} {
- if {[info commands testthread] != {}} {
-
- # testthread built into tcltest
-
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != $::tcltest::mainThread} {
- catch {testthread send -async $tid {testthread exit}}
- }
- }
- ## Enter a bit a sleep to give the threads enough breathing
- ## room to kill themselves off, otherwise the end up with a
- ## massive queue of repeated events
- after 1
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- } elseif {[info commands thread::id] != {}} {
-
- # Thread extension
-
- thread::errorproc ThreadNullError
- while {[llength [thread::names]] > 1} {
- foreach tid [thread::names] {
- if {$tid != $::tcltest::mainThread} {
- catch {thread::send -async $tid {thread::exit}}
- }
- }
- ## Enter a bit a sleep to give the threads enough breathing
- ## room to kill themselves off, otherwise the end up with a
- ## massive queue of repeated events
- after 1
- }
- thread::errorproc ThreadError
- return [llength [thread::names]]
- } else {
- return 1
- }
-}
-
-# Initialize the constraints and set up command line arguments
-namespace eval tcltest {
- # Ensure that we have a minimal auto_path so we don't pick up extra junk.
- set ::auto_path [list [info library]]
-
- ::tcltest::initConstraints
- if {[namespace children ::tcltest] == {}} {
- ::tcltest::processCmdLineArgs
- }
-}
-
This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation and other parties. The following terms apply to all files
+associated with the software unless explicitly disclaimed in
+individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
<BR>
<B>AppleScript <A NAME="decompile">decompile</A></B> <I>scriptName</I>
<BR>
-<B>AppleScript delete </B><I>scriptName</I>
+<B>AppleScript <A NAME="delete">delete</A> </B><I>what scriptName</I>
<BR>
<B>AppleScript <A NAME="execute">execute</A> </B><I>?flags value?</I> <I>scriptData1
?scriptData2 ...?</I>
and returns the source code.
<P>
<DT>
- <I>AppleScript</I> <B>delete </B><I>scriptName</I>
+ <I>AppleScript</I> <B><A NAME="delete">delete</A> </B><I>what scriptName</I>
<BR>
<DD>
- This deletes the script data compiled into the script scriptName,
- and frees up all the resources associated with it.
+ This deletes contexts or script data. The allowed values for "what" are:
+ <P>
+ <DL>
+ <DT>
+ <P>
+ <B>context</B>
+ <DD>
+ This deletes the context scriptName,
+ and frees up all the resources associated with it.
+ <DT>
+ <P>
+ <B>script</B>
+ <DD>
+ This deletes the script data compiled into the script scriptName,
+ and frees up all the resources associated with it.
+ </DL>
<P>
<DT>
<I>AppleScript</I> <B><A NAME="execute">execute</A> </B><I>?flags value?</I> <I>scriptData1
#include "tclMacCommonPch.h"
-/* #define TCL_REGISTER_LIBRARY 1 */
#define USE_TCL_STUBS
-
-/*
- * Place any includes below that will are needed by the majority of the
- * and is OK to be in any file in the system. The pragma's are used
- * to control what functions are exported in the Tcl shared library.
- */
-
-#pragma export on
-#pragma export off
-
#pragma precompile_target "MW_TclHeader68K"
#endif
-#include "tclMacCommonPch.h"
-
-/*
- * Place any includes below that will are needed by the majority of the
- * and is OK to be in any file in the system. The pragma's are used
- * to control what functions are exported in the Tcl shared library.
- */
-
-#pragma export on
-#include "tcl.h"
-#include "tclMac.h"
-#include "tclInt.h"
-#include "MoreFiles.h"
-#include "MoreFilesExtras.h"
-
-#pragma export reset
-
+#include "MW_TclHeaderCommon.h"
/*
- * MW_TclHeader.pch --
+ * MW_TclTestHeader.pch --
*
* This file is the source for a pre-compilied header that gets used
* for all files in the Tcl projects. This make compilies go a bit
#pragma precompile_target "MW_TclTestHeader68K"
#endif
-#define TCL_DEBUG 1
-
-/*#define TCL_THREADS 1*/
+#define BUILD_tcl 1
-#include "tclMacCommonPch.h"
+#define STATIC_BUILD 1
-/*
- * Place any includes below that will are needed by the majority of the
- * and is OK to be in any file in the system. The pragma's are used
- * to control what functions are exported in the Tcl shared library.
- */
-
-#pragma export on
-#include "tcl.h"
-#include "tclMac.h"
-#include "tclInt.h"
-#include "MoreFiles.h"
-#include "MoreFilesExtras.h"
-
-#pragma export reset
+#define TCL_DEBUG 1
+#define TCL_THREADS 1
+#include "MW_TclHeaderCommon.h"
-Tcl 8.3 for Macintosh
-
-by Ray Johnson
-Scriptics Corporation
-rjohnson@scriptics.com
-with major help from
-Jim Ingham
-Cygnus Solutions
-jingham@cygnus.com
+Tcl 8.4 for Macintosh
RCS: @(#) $Id$
---------------
This is the README file for the Macintosh version of the Tcl
-scripting language. The home page for the Macintosh releases is
- http://dev.scriptics.com/software/mac/
+scripting language. The home page for the Mac/Tcl info is
+ http://www.tcl.tk/software/mac/
A summary of what's new in this release is at
- http://dev.scriptics.com/software/tcltk/8.3.html
+ http://www.tcl.tk/software/tcltk/8.4.html
A summary of Macintosh-specific features is at
- http://dev.scriptics.com/software/mac/features.html
-
+ http://www.tcl.tk/software/mac/features.html
2. The Distribution
-------------------
The "html" subdirectory contains reference documentation in
in the HTML format. You may also find these pages at:
- http://dev.scriptics.com/man/tcl<version>/contents.html
+ http://www.tcl.tk/man/
3. Compiling Tcl
----------------
The included project files should work fine. However, for
current release notes please check this page:
- http://dev.scriptics.com/doc/howto/compile.html#mac
-
-If you have comments or Bug reports send them to:
-Jim Ingham
-jingham@cygnus.com
+ http://www.tcl.tk/doc/howto/compile.html#mac
+If you have comments or Bug reports, please use the SourceForge
+Bug tracker to report them:
+ http://tcl.sourceforge.net/
This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation and other parties. The following terms apply to all files
+associated with the software unless explicitly disclaimed in
+individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
#include <Files.h>
#include <Events.h>
-/*
- * "export" is a MetroWerks specific pragma. It flags the linker that
- * any symbols that are defined when this pragma is on will be exported
- * to shared libraries that link with this library.
- */
-
-#pragma export on
-
typedef int (*Tcl_MacConvertEventPtr) _ANSI_ARGS_((EventRecord *eventPtr));
#include "tclPlatDecls.h"
-#pragma export reset
-
#endif /* _TCLMAC */
#include "tclInt.h"
#include "tclMacInt.h"
#include <Memory.h>
+#include <Gestalt.h>
#include <stdlib.h>
#include <string.h>
*/
#define MEMORY_ALL_SYS 1 /* All memory should come from the system
heap. */
+#define MEMORY_DONT_USE_TEMPMEM 2 /* Don't use temporary memory but system memory. */
/*
* Amount of space to leave in the application heap for the Toolbox to work.
*/
-#define TOOLBOX_SPACE (32 * 1024)
+#define TOOLBOX_SPACE (512 * 1024)
static int memoryFlags = 0;
static Handle toolGuardHandle = NULL;
* the way out. If we can't, we go to the
* system heap directly. */
+static int tclUseMemTracking = 0; /* Are we tracking memory allocations?
+ * On recent versions of the MacOS this
+ * is no longer necessary, as we can use
+ * temporary memory which is freed by the
+ * OS after a quit or crash. */
+
+static size_t tclExtraHdlSize = 0; /* Size of extra memory allocated at the start
+ * of each block when using memory tracking
+ * ( == 0 otherwise) */
/*
* The following typedef and variable are used to keep track of memory
typedef struct listEl {
Handle memoryHandle;
struct listEl * next;
+ struct listEl * prec;
} ListEl;
-ListEl * systemMemory = NULL;
-ListEl * appMemory = NULL;
+static ListEl * systemMemory = NULL;
+static ListEl * appMemory = NULL;
/*
* Prototypes for functions used only in this file.
Handle hand;
void *newPtr;
int maxsize;
+ OSErr err;
- hand = * (Handle *) ((Ptr) oldPtr - sizeof(Handle));
+ if (tclUseMemTracking) {
+ hand = ((ListEl *) ((Ptr) oldPtr - tclExtraHdlSize))->memoryHandle;
+ } else {
+ hand = RecoverHandle((Ptr) oldPtr);
+ }
maxsize = GetHandleSize(hand) - sizeof(Handle);
if (maxsize < size) {
+ HUnlock(hand);
+ SetHandleSize(hand,size + tclExtraHdlSize);
+ err = MemError();
+ HLock(hand);
+ if(err==noErr){
+ newPtr=(*hand + tclExtraHdlSize);
+ } else {
newPtr = TclpSysAlloc(size, 1);
- memcpy(newPtr, oldPtr, maxsize);
+ if(newPtr!=NULL) {
+ memmove(newPtr, oldPtr, maxsize);
TclpSysFree(oldPtr);
+ }
+ }
} else {
newPtr = oldPtr;
}
{
Handle hand = NULL;
ListEl * newMemoryRecord;
+ int isSysMem = 0;
+ static int initialized=0;
+
+ if (!initialized) {
+ long response = 0;
+ OSErr err = noErr;
+ int useTempMem = 0;
+
+ /* Check if we can use temporary memory */
+ initialized=1;
+ err = Gestalt(gestaltOSAttr, &response);
+ if (err == noErr) {
+ useTempMem = response & (1 << gestaltRealTempMemory);
+ }
+ tclUseMemTracking = !useTempMem || (memoryFlags & MEMORY_DONT_USE_TEMPMEM);
+ if(tclUseMemTracking) {
+ tclExtraHdlSize = sizeof(ListEl);
+ /*
+ * We are allocating memory directly from the system
+ * heap. We need to install an exit handle
+ * to ensure the memory is cleaned up.
+ */
+ TclMacInstallExitToShellPatch(CleanUpExitProc);
+ }
+ }
if (!(memoryFlags & MEMORY_ALL_SYS)) {
if (toolGuardHandle == NULL) {
toolGuardHandle = NewHandle(TOOLBOX_SPACE);
if (toolGuardHandle != NULL) {
+ HLock(toolGuardHandle);
HPurge(toolGuardHandle);
}
}
if (toolGuardHandle != NULL) {
HLock(toolGuardHandle);
- hand = NewHandle(size + sizeof(Handle));
+ hand = NewHandle(size + tclExtraHdlSize);
HUnlock(toolGuardHandle);
}
}
- if (hand != NULL) {
- newMemoryRecord = (ListEl *) NewPtr(sizeof(ListEl));
- if (newMemoryRecord == NULL) {
- DisposeHandle(hand);
- return NULL;
- }
- newMemoryRecord->memoryHandle = hand;
- newMemoryRecord->next = appMemory;
- appMemory = newMemoryRecord;
- } else {
+ if (hand == NULL) {
/*
* Ran out of memory in application space. Lets try to get
* more memory from system. Otherwise, we return NULL to
* denote failure.
*/
+ if(!tclUseMemTracking) {
+ /* Use Temporary Memory instead of System Heap when available */
+ OSErr err;
+ isBin = 1; /* always HLockHi TempMemHandles */
+ hand = TempNewHandle(size + tclExtraHdlSize,&err);
+ if(err!=noErr) { hand=NULL; }
+ } else {
+ /* Use system heap when tracking memory */
+ isSysMem=1;
isBin = 0;
- hand = NewHandleSys(size + sizeof(Handle));
- if (hand == NULL) {
- return NULL;
+ hand = NewHandleSys(size + tclExtraHdlSize);
}
- if (systemMemory == NULL) {
- /*
- * This is the first time we've attempted to allocate memory
- * directly from the system heap. We need to now install the
- * exit handle to ensure the memory is cleaned up.
- */
- TclMacInstallExitToShellPatch(CleanUpExitProc);
}
- newMemoryRecord = (ListEl *) NewPtrSys(sizeof(ListEl));
- if (newMemoryRecord == NULL) {
- DisposeHandle(hand);
+ if (hand == NULL) {
return NULL;
}
- newMemoryRecord->memoryHandle = hand;
- newMemoryRecord->next = systemMemory;
- systemMemory = newMemoryRecord;
- }
if (isBin) {
HLockHi(hand);
} else {
HLock(hand);
}
- (** (Handle **) hand) = hand;
-
- return (*hand + sizeof(Handle));
+ if(tclUseMemTracking) {
+ /* Only need to do this when tracking memory */
+ newMemoryRecord = (ListEl *) *hand;
+ newMemoryRecord->memoryHandle = hand;
+ newMemoryRecord->prec = NULL;
+ if(isSysMem) {
+ newMemoryRecord->next = systemMemory;
+ systemMemory = newMemoryRecord;
+ } else {
+ newMemoryRecord->next = appMemory;
+ appMemory = newMemoryRecord;
+ }
+ if(newMemoryRecord->next!=NULL) {
+ newMemoryRecord->next->prec=newMemoryRecord;
+ }
+ }
+
+ return (*hand + tclExtraHdlSize);
}
\f
/*
TclpSysFree(
void * ptr) /* Free this system memory. */
{
- Handle hand;
- OSErr err;
+ if(tclUseMemTracking) {
+ /* Only need to do this when tracking memory */
+ ListEl *memRecord;
- hand = * (Handle *) ((Ptr) ptr - sizeof(Handle));
- DisposeHandle(hand);
- *hand = NULL;
- err = MemError();
+ memRecord = (ListEl *) ((Ptr) ptr - tclExtraHdlSize);
+ /* Remove current record from linked list */
+ if(memRecord->next!=NULL) {
+ memRecord->next->prec=memRecord->prec;
+ }
+ if(memRecord->prec!=NULL) {
+ memRecord->prec->next=memRecord->next;
+ }
+ if(memRecord==appMemory) {
+ appMemory=memRecord->next;
+ } else if(memRecord==systemMemory) {
+ systemMemory=memRecord->next;
+ }
+ DisposeHandle(memRecord->memoryHandle);
+ } else {
+ DisposeHandle(RecoverHandle((Ptr) ptr));
+ }
}
\f
/*
{
ListEl * memRecord;
+ if(tclUseMemTracking) {
+ /* Only need to do this when tracking memory */
while (systemMemory != NULL) {
memRecord = systemMemory;
systemMemory = memRecord->next;
- if (*(memRecord->memoryHandle) != NULL) {
- DisposeHandle(memRecord->memoryHandle);
- }
- DisposePtr((void *) memRecord);
+ DisposeHandle(memRecord->memoryHandle);
+ }
}
}
\f
{
ListEl * memRecord;
+ if(tclUseMemTracking) {
+ /* Only need to do this when tracking memory */
while (systemMemory != NULL) {
memRecord = systemMemory;
systemMemory = memRecord->next;
- if (*(memRecord->memoryHandle) != NULL) {
- DisposeHandle(memRecord->memoryHandle);
- }
- DisposePtr((void *) memRecord);
+ DisposeHandle(memRecord->memoryHandle);
}
while (appMemory != NULL) {
memRecord = appMemory;
appMemory = memRecord->next;
- if (*(memRecord->memoryHandle) != NULL) {
- DisposeHandle(memRecord->memoryHandle);
- }
- DisposePtr((void *) memRecord);
+ DisposeHandle(memRecord->memoryHandle);
+ }
}
}
\f
# include <console.h>
#elif defined(__MWERKS__)
# include <SIOUX.h>
-short InstallConsole _ANSI_ARGS_((short fd));
+EXTERN short InstallConsole _ANSI_ARGS_((short fd));
#endif
#ifdef TCL_TEST
SIOUXSettings.autocloseonquit = true;
SIOUXSettings.showstatusline = true;
SIOUXSettings.asktosaveonclose = false;
+ SIOUXSettings.wasteusetempmemory = true;
InstallConsole(0);
SIOUXSetTitle("\pTcl Interpreter");
* the version string for Tcl.
*/
-#define RESOURCE_INCLUDED
+#define RC_INVOKED
#include "tcl.h"
#if (TCL_RELEASE_LEVEL == 0)
#if (TCL_RELEASE_LEVEL == 2)
# define MINOR_VERSION (TCL_MINOR_VERSION * 16) + TCL_RELEASE_SERIAL
+# define RELEASE_CODE 0x00
#else
# define MINOR_VERSION TCL_MINOR_VERSION * 16
+# define RELEASE_CODE TCL_RELEASE_SERIAL
#endif
resource 'vers' (1) {
TCL_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
+ RELEASE_LEVEL, RELEASE_CODE, verUS,
TCL_PATCH_LEVEL,
- TCL_PATCH_LEVEL ", by Ray Johnson & Jim Ingham © Scriptics Inc"
+ TCL_PATCH_LEVEL ", by Ray Johnson & Jim Ingham" "\n" "© 2001 Tcl Core Team"
};
resource 'vers' (2) {
TCL_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
+ RELEASE_LEVEL, RELEASE_CODE, verUS,
TCL_PATCH_LEVEL,
- "Tcl Shell " TCL_PATCH_LEVEL " © 1996-1997 Sun Microsystems, 1998-1999 Scriptics Inc"
+ "Tcl Shell " TCL_PATCH_LEVEL " © 1993-2001"
};
#define TCL_APP_CREATOR 'Tcl '
type TCL_APP_CREATOR as 'STR ';
resource TCL_APP_CREATOR (0, purgeable) {
- "Tcl Shell " TCL_PATCH_LEVEL " © 1996-1999"
+ "Tcl Shell " TCL_PATCH_LEVEL " © 1993-2001"
};
/*
'APPL', "Tcl Shell",
}
};
+
+/*
+ * The following resource is used when creating the 'env' variable in
+ * the Macintosh environment. The creation mechanisim looks for the
+ * 'STR#' resource named "Tcl Environment Variables" rather than a
+ * specific resource number. (In other words, feel free to change the
+ * resource id if it conflicts with your application.) Each string in
+ * the resource must be of the form "KEYWORD=SOME STRING". See Tcl
+ * documentation for futher information about the env variable.
+ *
+ * A good example of something you may want to set is: "TCL_LIBRARY=My
+ * disk:etc."
+ */
+
+resource 'STR#' (128, "Tcl Environment Variables") {
+ {
+ /*
+ "SCHEDULE_NAME=Agent Controller Schedule",
+ "SCHEDULE_PATH=Lozoya:System Folder:Tcl Lib:Tcl-Scheduler"
+ */
+ };
+};
+
+data 'alis' (1000, "Library Folder") {
+ $"0000 0000 00BA 0002 0001 012F 0000 0000" /* .....\86...../.... */
+ $"0000 0000 0000 0000 0000 0000 0000 0000" /* ................ */
+ $"0000 0000 0000 985C FB00 4244 0000 0000" /* ......ò\\9a.BD.... */
+ $"0002 1328 5375 7070 6F72 7420 4C69 6272" /* ...(Support Libr */
+ $"6172 6965 7329 0000 0000 0000 0000 0000" /* aries).......... */
+ $"0000 0000 0000 0000 0000 0000 0000 0000" /* ................ */
+ $"0000 0000 0000 0000 0000 0000 0000 0000" /* ................ */
+ $"0000 0076 8504 B617 A796 003D 0027 025B" /* ...vÖ.\8f.ßñ.=.'.[ */
+ $"01E4 0001 0001 0000 0000 0000 0000 0000" /* .\94.............. */
+ $"0000 0000 0000 0000 0001 2F00 0002 0015" /* ........../..... */
+ $"2F3A 2853 7570 706F 7274 204C 6962 7261" /* /:(Support Libra */
+ $"7269 6573 2900 FFFF 0000" /* ries).\9d\9d.. */
+};
+
static Tcl_Interp *interp; /* Interpreter for application. */
-#ifdef TCL_MEM_DEBUG
-static char dumpFile[100]; /* Records where to dump memory allocation
- * information. */
-static int quitFlag = 0; /* 1 means "checkmem" command was called,
- * so the application should quit and dump
- * memory allocation information. */
-#endif
-
/*
* Forward references for procedures defined later in this file:
*/
-#ifdef TCL_MEM_DEBUG
-static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char *argv[]));
-#endif
void TclMacDoNotification(char *mssg);
void TclMacNotificationResponse(NMRecPtr nmRec);
int Tcl_MacBGNotifyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
-#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
- Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
-#endif
/*
* Make command-line arguments available in the Tcl variables "argc"
}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * CheckmemCmd --
- *
- * This is the command procedure for the "checkmem" command, which
- * causes the application to exit after printing information about
- * memory usage to the file passed to this command as its first
- * argument.
- *
- * Results:
- * Returns a standard Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-#ifdef TCL_MEM_DEBUG
-
- /* ARGSUSED */
-static int
-CheckmemCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Interpreter for evaluation. */
- int argc; /* Number of arguments. */
- char *argv[]; /* String values of arguments. */
-{
- extern char *tclMemDumpFileName;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " fileName\"", (char *) NULL);
- return TCL_ERROR;
- }
- strcpy(dumpFile, argv[1]);
- tclMemDumpFileName = dumpFile;
- quitFlag = 1;
- return TCL_OK;
-}
-#endif
#include <MoreFiles.h>
#include <MoreFilesExtras.h>
-
-/*
- * The following are flags returned by GetOpenMode. They
- * are or'd together to determine how opening and handling
- * a file should occur.
- */
-
-#define TCL_RDONLY (1<<0)
-#define TCL_WRONLY (1<<1)
-#define TCL_RDWR (1<<2)
-#define TCL_CREAT (1<<3)
-#define TCL_TRUNC (1<<4)
-#define TCL_APPEND (1<<5)
-#define TCL_ALWAYS_APPEND (1<<6)
-#define TCL_EXCL (1<<7)
-#define TCL_NOCTTY (1<<8)
-#define TCL_NONBLOCK (1<<9)
-#define TCL_RW_MODES (TCL_RDONLY|TCL_WRONLY|TCL_RDWR)
+#ifdef __MSL__
+#include <unix.mac.h>
+#define TCL_FILE_CREATOR (__getcreator(0))
+#else
+#define TCL_FILE_CREATOR 'MPW '
+#endif
/*
* This structure describes per-instance state of a
static int FileInput _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
static int FileOutput _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCode));
+ CONST char *buf, int toWrite, int *errorCode));
static int FileSeek _ANSI_ARGS_((ClientData instanceData,
long offset, int mode, int *errorCode));
static void FileSetupProc _ANSI_ARGS_((ClientData clientData,
int flags));
-static int GetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
- CONST char *string));
static Tcl_Channel OpenFileChannel _ANSI_ARGS_((CONST char *fileName,
int mode, int permissions, int *errorCodePtr));
static int StdIOBlockMode _ANSI_ARGS_((ClientData instanceData,
static int StdIOInput _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
static int StdIOOutput _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCode));
+ CONST char *buf, int toWrite, int *errorCode));
static int StdIOSeek _ANSI_ARGS_((ClientData instanceData,
long offset, int mode, int *errorCode));
static int StdReady _ANSI_ARGS_((ClientData instanceData,
static Tcl_ChannelType consoleChannelType = {
"file", /* Type name. */
- StdIOBlockMode, /* Set blocking/nonblocking mode.*/
+ (Tcl_ChannelTypeVersion)StdIOBlockMode, /* Set blocking/nonblocking mode.*/
StdIOClose, /* Close proc. */
StdIOInput, /* Input proc. */
StdIOOutput, /* Output proc. */
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
- FileBlockMode, /* Set blocking or
+ (Tcl_ChannelTypeVersion)FileBlockMode, /* Set blocking or
* non-blocking mode.*/
FileClose, /* Close proc. */
FileInput, /* Input proc. */
static int
StdIOOutput(
ClientData instanceData, /* Unused. */
- char *buf, /* The data buffer. */
+ CONST char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
*errorCode = 0;
errno = 0;
fd = (int) ((FileState*)instanceData)->fileRef;
- written = write(fd, buf, (size_t) toWrite);
+ written = write(fd, (void*)buf, (size_t) toWrite);
if (written > -1) {
return written;
}
static int
StdIOSeek(
- ClientData instanceData, /* Unused. */
- long offset, /* Offset to seek to. */
- int mode, /* Relative to where
- * should we seek? */
- int *errorCodePtr) /* To store error code. */
+ ClientData instanceData, /* Unused. */
+ long offset, /* Offset to seek to. */
+ int mode, /* Relative to where should we seek? */
+ int *errorCodePtr) /* To store error code. */
{
int newLoc;
int fd;
*
* TclpOpenFileChannel --
*
- * Open an File based channel on Unix systems.
+ * Open a File based channel on MacOS systems.
*
* Results:
* The new channel or NULL. If NULL, the output argument
TclpOpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting;
* can be NULL. */
- char *fileName, /* Name of file to open. */
- char *modeString, /* A list of POSIX open modes or
- * a string such as "rw". */
+ Tcl_Obj *pathPtr, /* Name of file to open. */
+ int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel chan;
- int mode;
- char *native;
- Tcl_DString ds, buffer;
+ CONST char *native;
int errorCode;
- mode = GetOpenMode(interp, modeString);
- if (mode == -1) {
+ native = Tcl_FSGetNativePath(pathPtr);
+ if (native == NULL) {
return NULL;
}
-
- if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
- return NULL;
- }
- native = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
- Tcl_DStringLength(&buffer), &ds);
chan = OpenFileChannel(native, mode, permissions, &errorCode);
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&buffer);
if (chan == NULL) {
Tcl_SetErrno(errorCode);
if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "couldn't open \"",
+ Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
* Windows and UNIX and the feature is used by Tcl.
*/
- switch (mode & (TCL_RDONLY | TCL_WRONLY | TCL_RDWR)) {
- case TCL_RDWR:
+ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
+ case O_RDWR:
channelPermissions = (TCL_READABLE | TCL_WRITABLE);
macPermision = fsRdWrShPerm;
break;
- case TCL_WRONLY:
+ case O_WRONLY:
/*
* Mac's fsRdPerm permission actually defaults to fsRdWrPerm because
* the Mac OS doesn't realy support write only access. We explicitly
channelPermissions = TCL_WRITABLE;
macPermision = fsRdWrShPerm;
break;
- case TCL_RDONLY:
+ case O_RDONLY:
default:
channelPermissions = TCL_READABLE;
macPermision = fsRdPerm;
return NULL;
}
- if ((err == fnfErr) && (mode & TCL_CREAT)) {
- err = HCreate(fileSpec.vRefNum, fileSpec.parID, fileSpec.name, 'MPW ', 'TEXT');
+ if ((err == fnfErr) && (mode & O_CREAT)) {
+ err = HCreate(fileSpec.vRefNum, fileSpec.parID, fileSpec.name, TCL_FILE_CREATOR, 'TEXT');
if (err != noErr) {
*errorCodePtr = errno = TclMacOSErrorToPosixError(err);
Tcl_SetErrno(errno);
return NULL;
}
- } else if ((mode & TCL_CREAT) && (mode & TCL_EXCL)) {
+ } else if ((mode & O_CREAT) && (mode & O_EXCL)) {
*errorCodePtr = errno = EEXIST;
Tcl_SetErrno(errno);
return NULL;
return NULL;
}
- if (mode & TCL_TRUNC) {
+ if (mode & O_TRUNC) {
SetEOF(fileRef, 0);
}
fileState->fileRef = fileRef;
fileState->pending = 0;
fileState->watchMask = 0;
- if (mode & TCL_ALWAYS_APPEND) {
+ if (mode & O_APPEND) {
fileState->appendMode = true;
} else {
fileState->appendMode = false;
}
- if ((mode & TCL_ALWAYS_APPEND) || (mode & TCL_APPEND)) {
+ if ((mode & O_APPEND) || (mode & O_APPEND)) {
if (Tcl_Seek(chan, 0, SEEK_END) < 0) {
*errorCodePtr = errno = EFAULT;
Tcl_SetErrno(errno);
static int
FileOutput(
ClientData instanceData, /* Unused. */
- char *buffer, /* The data buffer. */
+ CONST char *buffer, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
static int
FileSeek(
ClientData instanceData, /* Unused. */
- long offset, /* Offset to seek to. */
- int mode, /* Relative to where
- * should we seek? */
- int *errorCodePtr) /* To store error code. */
+ long offset, /* Offset to seek to. */
+ int mode, /* Relative to where should we seek? */
+ int *errorCodePtr) /* To store error code. */
{
FileState *fileState = (FileState *) instanceData;
IOParam pb;
}
}
}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * GetOpenMode --
- *
- * Description:
- * Computes a POSIX mode mask from a given string and also sets
- * a flag to indicate whether the caller should seek to EOF during
- * opening of the file.
- *
- * Results:
- * On success, returns mode to pass to "open". If an error occurs, the
- * returns -1 and if interp is not NULL, sets the interp's result to an
- * error message.
- *
- * Side effects:
- * Sets the integer referenced by seekFlagPtr to 1 if the caller
- * should seek to EOF during opening the file.
- *
- * Special note:
- * This code is based on a prototype implementation contributed
- * by Mark Diekhans.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-GetOpenMode(
- Tcl_Interp *interp, /* Interpreter to use for error
- * reporting - may be NULL. */
- CONST char *string) /* Mode string, e.g. "r+" or
- * "RDONLY CREAT". */
-{
- int mode, modeArgc, c, i, gotRW;
- char **modeArgv, *flag;
-
- /*
- * Check for the simpler fopen-like access modes (e.g. "r"). They
- * are distinguished from the POSIX access modes by the presence
- * of a lower-case first letter.
- */
-
- mode = 0;
- /*
- * Guard against international characters before using byte oriented
- * routines.
- */
-
- if (!(string[0] & 0x80)
- && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
- switch (string[0]) {
- case 'r':
- mode = TCL_RDONLY;
- break;
- case 'w':
- mode = TCL_WRONLY|TCL_CREAT|TCL_TRUNC;
- break;
- case 'a':
- mode = TCL_WRONLY|TCL_CREAT|TCL_APPEND;
- break;
- default:
- error:
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp,
- "illegal access mode \"", string, "\"",
- (char *) NULL);
- }
- return -1;
- }
- if (string[1] == '+') {
- mode &= ~(TCL_RDONLY|TCL_WRONLY);
- mode |= TCL_RDWR;
- if (string[2] != 0) {
- goto error;
- }
- } else if (string[1] != 0) {
- goto error;
- }
- return mode;
- }
-
- /*
- * The access modes are specified using a list of POSIX modes
- * such as TCL_CREAT.
- */
-
- if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AddErrorInfo(interp,
- "\n while processing open access modes \"");
- Tcl_AddErrorInfo(interp, string);
- Tcl_AddErrorInfo(interp, "\"");
- }
- return -1;
- }
-
- gotRW = 0;
- for (i = 0; i < modeArgc; i++) {
- flag = modeArgv[i];
- c = flag[0];
- if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
- mode = (mode & ~TCL_RW_MODES) | TCL_RDONLY;
- gotRW = 1;
- } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
- mode = (mode & ~TCL_RW_MODES) | TCL_WRONLY;
- gotRW = 1;
- } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
- mode = (mode & ~TCL_RW_MODES) | TCL_RDWR;
- gotRW = 1;
- } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
- mode |= TCL_ALWAYS_APPEND;
- } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
- mode |= TCL_CREAT;
- } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
- mode |= TCL_EXCL;
- } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
- mode |= TCL_NOCTTY;
- } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
- mode |= TCL_NONBLOCK;
- } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
- mode |= TCL_TRUNC;
- } else {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "invalid access mode \"", flag,
- "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
- " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
- }
- ckfree((char *) modeArgv);
- return -1;
- }
- }
- ckfree((char *) modeArgv);
- if (!gotRW) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "access mode must include either",
- " RDONLY, WRONLY, or RDWR", (char *) NULL);
- }
- return -1;
- }
- return mode;
-}
/*
-* The following defines control the behavior of the Macintosh
-* Universial Headers.
-*/
-
-
-#define SystemSevenOrLater 1
-#define STRICT_CONTROLS 1
-#define STRICT_WINDOWS 1
-
-
-/*
* Define the following symbol if you want
* comprehensive debugging turned on.
*/
#endif
-
/*
-* For a while, we will continue to use the old routine names, so that
-* people with older versions of CodeWarrior will still be able to compile
-* the source (albeit they will have to update the project files themselves).
-*
-* At some point, we will convert over to the new routine names.
+* for Metrowerks Pro 6 MSL
*/
-
-#define OLDROUTINENAMES 1
+#include <UseDLLPrefix.h>
#include <Script.h>
#include <string.h>
#include <Finder.h>
+#include <Aliases.h>
/*
* Callback for the file attributes code.
*/
static int GetFileFinderAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int GetFileReadOnly _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj **readOnlyPtrPtr));
static int SetFileFinderAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr));
static int SetFileReadOnly _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj *readOnlyPtr));
/*
* Global variables for the file attributes code.
*/
-char *tclpFileAttrStrings[] = {"-creator", "-hidden", "-readonly",
+CONST char *tclpFileAttrStrings[] = {"-creator", "-hidden", "-readonly",
"-type", (char *) NULL};
CONST TclFileAttrProcs tclpFileAttrProcs[] = {
{GetFileFinderAttributes, SetFileFinderAttributes},
{GetFileReadOnly, SetFileReadOnly},
{GetFileFinderAttributes, SetFileFinderAttributes}};
+/*
+ * File specific static data
+ */
+
+static long startSeed = 248923489;
/*
* Prototypes for procedure only used in this file
CONST char *dst));
OSErr FSpGetFLockCompat _ANSI_ARGS_((const FSSpec *specPtr,
Boolean *lockedPtr));
-static OSErr GenerateUniqueName _ANSI_ARGS_((short vRefNum,
- long dirID1, long dirID2, Str31 uniqueName));
static OSErr GetFileSpecs _ANSI_ARGS_((CONST char *path,
FSSpec *pathSpecPtr, FSSpec *dirSpecPtr,
Boolean *pathExistsPtr,
/*
*---------------------------------------------------------------------------
*
- * TclpRenameFile, DoRenameFile --
+ * TclpObjRenameFile, DoRenameFile --
*
* Changes the name of an existing file or directory, from src to dst.
* If src and dst refer to the same file or directory, does nothing
*---------------------------------------------------------------------------
*/
-int
-TclpRenameFile(
- CONST char *src, /* Pathname of file or dir to be renamed
- * (UTF-8). */
- CONST char *dst) /* New pathname of file or directory
- * (UTF-8). */
+int
+TclpObjRenameFile(srcPathPtr, destPathPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_UtfToExternalDString(NULL, src, -1, &srcString);
- Tcl_UtfToExternalDString(NULL, dst, -1, &dstString);
- result = DoRenameFile(Tcl_DStringValue(&srcString),
- Tcl_DStringValue(&dstString));
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
+ return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
long srcID, dummy;
Boolean srcIsDirectory, dstIsDirectory, dstExists, dstLocked;
- err = FSpLocationFromPath(strlen(src), src, &srcFileSpec);
+ err = FSpLLocationFromPath(strlen(src), src, &srcFileSpec);
if (err == noErr) {
FSpGetDirectoryID(&srcFileSpec, &srcID, &srcIsDirectory);
}
Str31 tmpName;
FSSpec tmpFileSpec;
- err = GenerateUniqueName(dstFileSpec.vRefNum,
+ err = GenerateUniqueName(dstFileSpec.vRefNum, &startSeed,
dstFileSpec.parID, dstFileSpec.parID, tmpName);
if (err == noErr) {
err = FSpRenameCompat(&dstFileSpec, tmpName);
* dest directory, and rename temp to target.
*/
- err = GenerateUniqueName(srcFileSpecPtr->vRefNum,
+ err = GenerateUniqueName(srcFileSpecPtr->vRefNum, &startSeed,
srcFileSpecPtr->parID, dstID, tmpName);
FSMakeFSSpecCompat(srcFileSpecPtr->vRefNum, srcFileSpecPtr->parID,
tmpName, &tmpSrcFileSpec);
/*
*---------------------------------------------------------------------------
*
- * TclpCopyFile, DoCopyFile --
+ * TclpObjCopyFile, DoCopyFile --
*
* Copy a single file (not a directory). If dst already exists and
* is not a directory, it is removed.
*/
int
-TclpCopyFile(
- CONST char *src, /* Pathname of file to be copied (UTF-8). */
- CONST char *dst) /* Pathname of file to copy to (UTF-8). */
+TclpObjCopyFile(srcPathPtr, destPathPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_UtfToExternalDString(NULL, src, -1, &srcString);
- Tcl_UtfToExternalDString(NULL, dst, -1, &dstString);
- result = DoCopyFile(Tcl_DStringValue(&srcString),
- Tcl_DStringValue(&dstString));
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
+ return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
FSSpec srcFileSpec, dstFileSpec, dstDirSpec, tmpFileSpec;
Str31 tmpName;
- err = FSpLocationFromPath(strlen(src), src, &srcFileSpec);
+ err = FSpLLocationFromPath(strlen(src), src, &srcFileSpec);
if (err == noErr) {
err = GetFileSpecs(dst, &dstFileSpec, &dstDirSpec, &dstExists,
&dstIsDirectory);
* Backup dest file.
*/
- dstErr = GenerateUniqueName(dstFileSpec.vRefNum, dstFileSpec.parID,
+ dstErr = GenerateUniqueName(dstFileSpec.vRefNum, &startSeed, dstFileSpec.parID,
dstFileSpec.parID, tmpName);
if (dstErr == noErr) {
dstErr = FSpRenameCompat(&dstFileSpec, tmpName);
/*
*---------------------------------------------------------------------------
*
- * TclpDeleteFile, DoDeleteFile --
+ * TclpObjDeleteFile, DoDeleteFile --
*
* Removes a single file (not a directory).
*
*---------------------------------------------------------------------------
*/
-int
-TclpDeleteFile(
- CONST char *path) /* Pathname of file to be removed (UTF-8). */
+int
+TclpObjDeleteFile(pathPtr)
+ Tcl_Obj *pathPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_UtfToExternalDString(NULL, path, -1, &pathString);
- result = DoDeleteFile(Tcl_DStringValue(&pathString));
- Tcl_DStringFree(&pathString);
- return result;
+ return DoDeleteFile(Tcl_FSGetNativePath(pathPtr));
}
static int
Boolean isDirectory;
long dirID;
- err = FSpLocationFromPath(strlen(path), path, &fileSpec);
+ err = FSpLLocationFromPath(strlen(path), path, &fileSpec);
if (err == noErr) {
/*
* Since FSpDeleteCompat will delete an empty directory, make sure
/*
*---------------------------------------------------------------------------
*
- * TclpCreateDirectory, DoCreateDirectory --
+ * TclpObjCreateDirectory, DoCreateDirectory --
*
* Creates the specified directory. All parent directories of the
* specified directory must already exist. The directory is
*---------------------------------------------------------------------------
*/
-int
-TclpCreateDirectory(
- CONST char *path) /* Pathname of directory to create (UTF-8). */
+int
+TclpObjCreateDirectory(pathPtr)
+ Tcl_Obj *pathPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_UtfToExternalDString(NULL, path, -1, &pathString);
- result = DoCreateDirectory(Tcl_DStringValue(&pathString));
- Tcl_DStringFree(&pathString);
- return result;
+ return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
/*
*---------------------------------------------------------------------------
*
- * TclpCopyDirectory, DoCopyDirectory --
+ * TclpObjCopyDirectory, DoCopyDirectory --
*
* Recursively copies a directory. The target directory dst must
* not already exist. Note that this function does not merge two
*---------------------------------------------------------------------------
*/
-int
-TclpCopyDirectory(
- CONST char *src, /* Pathname of directory to be copied
- * (UTF-8). */
- CONST char *dst, /* Pathname of target directory (UTF-8). */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+int
+TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
+ Tcl_Obj **errorPtr;
{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_UtfToExternalDString(NULL, src, -1, &srcString);
- Tcl_UtfToExternalDString(NULL, dst, -1, &dstString);
- result = DoCopyDirectory(Tcl_DStringValue(&srcString),
- Tcl_DStringValue(&dstString), errorPtr);
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
+ Tcl_DString ds;
+ int ret;
+ ret = DoCopyDirectory(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr), &ds);
+ if (ret != TCL_OK) {
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_DStringFree(&ds);
+ Tcl_IncrRefCount(*errorPtr);
+ }
+ return ret;
}
static int
DoCopyDirectory(
CONST char *src, /* Pathname of directory to be copied
- * (UTF-8). */
- CONST char *dst, /* Pathname of target directory (UTF-8). */
+ * (Native). */
+ CONST char *dst, /* Pathname of target directory (Native). */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
FSpRstFLockCompat(&srcFileSpec);
}
if (err == noErr) {
- err = GenerateUniqueName(dstFileSpec.vRefNum, dstFileSpec.parID,
+ err = GenerateUniqueName(dstFileSpec.vRefNum, &startSeed, dstFileSpec.parID,
dstFileSpec.parID, tmpName);
}
if (err == noErr) {
err = FSpDirCreateCompat(&tmpDirSpec, smSystemScript, &tmpDirID);
}
if (err == noErr) {
- err = FSpDirectoryCopy(&srcFileSpec, &tmpDirSpec, NULL, 0, true,
+ err = FSpDirectoryCopy(&srcFileSpec, &tmpDirSpec, NULL, NULL, 0, true,
CopyErrHandler);
}
/*
*---------------------------------------------------------------------------
*
- * TclpRemoveDirectory, DoRemoveDirectory --
+ * TclpObjRemoveDirectory, DoRemoveDirectory --
*
* Removes directory (and its contents, if the recursive flag is set).
*
*---------------------------------------------------------------------------
*/
-int
-TclpRemoveDirectory(
- CONST char *path, /* Pathname of directory to be removed
- * (UTF-8). */
- int recursive, /* If non-zero, removes directories that
- * are nonempty. Otherwise, will only remove
- * empty directories. */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+int
+TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
+ Tcl_Obj *pathPtr;
+ int recursive;
+ Tcl_Obj **errorPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_UtfToExternalDString(NULL, path, -1, &pathString);
- result = DoRemoveDirectory(Tcl_DStringValue(&pathString), recursive,
- errorPtr);
- Tcl_DStringFree(&pathString);
-
- return result;
+ Tcl_DString ds;
+ int ret;
+ ret = DoRemoveDirectory(Tcl_FSGetNativePath(pathPtr),recursive, &ds);
+ if (ret != TCL_OK) {
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_DStringFree(&ds);
+ Tcl_IncrRefCount(*errorPtr);
+ }
+ return ret;
}
static int
/*
*---------------------------------------------------------------------------
*
- * GenerateUniqueName --
- *
- * Generate a filename that is not in either of the two specified
- * directories (on the same volume).
- *
- * Results:
- * Standard macintosh error. On success, uniqueName is filled with
- * the name of the temporary file.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-static OSErr
-GenerateUniqueName(
- short vRefNum, /* Volume on which the following directories
- * are located. */
- long dirID1, /* ID of first directory. */
- long dirID2, /* ID of second directory. May be the same
- * as the first. */
- Str31 uniqueName) /* Filled with filename for a file that is
- * not located in either of the above two
- * directories. */
-{
- OSErr err;
- long i;
- CInfoPBRec pb;
- static unsigned char hexStr[16] = "0123456789ABCDEF";
- static long startSeed = 248923489;
-
- pb.hFileInfo.ioVRefNum = vRefNum;
- pb.hFileInfo.ioFDirIndex = 0;
- pb.hFileInfo.ioNamePtr = uniqueName;
-
- while (1) {
- startSeed++;
- pb.hFileInfo.ioNamePtr[0] = 8;
- for (i = 1; i <= 8; i++) {
- pb.hFileInfo.ioNamePtr[i] = hexStr[((startSeed >> ((8-i)*4)) & 0xf)];
- }
- pb.hFileInfo.ioDirID = dirID1;
- err = PBGetCatInfoSync(&pb);
- if (err == fnfErr) {
- if (dirID1 != dirID2) {
- pb.hFileInfo.ioDirID = dirID2;
- err = PBGetCatInfoSync(&pb);
- }
- if (err == fnfErr) {
- return noErr;
- }
- }
- if (err == noErr) {
- continue;
- }
- return err;
- }
-}
-\f
-/*
- *---------------------------------------------------------------------------
- *
* GetFileSpecs --
*
* Gets FSSpecs for the specified path and its parent directory.
Boolean *pathIsDirectoryPtr)/* Set to true if path is itself a directory,
* otherwise false. */
{
- char *dirName;
+ CONST char *dirName;
OSErr err;
int argc;
- char **argv;
+ CONST char **argv;
long d;
Tcl_DString buffer;
GetFileFinderAttributes(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute option. */
- CONST char *fileName, /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
OSErr err;
FSSpec fileSpec;
FInfo finfo;
- Tcl_DString pathString;
+ CONST char *native;
- Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
- err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
- Tcl_DStringValue(&pathString), &fileSpec);
- Tcl_DStringFree(&pathString);
+ native=Tcl_FSGetNativePath(fileName);
+ err = FSpLLocationFromPath(strlen(native),
+ native, &fileSpec);
if (err == noErr) {
err = FSpGetFInfo(&fileSpec, &finfo);
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName, "\": ",
+ "could not read \"", Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
GetFileReadOnly(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **readOnlyPtrPtr) /* A pointer to return the object with. */
{
OSErr err;
FSSpec fileSpec;
CInfoPBRec paramBlock;
- Tcl_DString pathString;
+ CONST char *native;
- Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
- err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
- Tcl_DStringValue(&pathString), &fileSpec);
- Tcl_DStringFree(&pathString);
+ native=Tcl_FSGetNativePath(fileName);
+ err = FSpLLocationFromPath(strlen(native),
+ native, &fileSpec);
if (err == noErr) {
if (err == noErr) {
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName, "\": ",
+ "could not read \"", Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
SetFileFinderAttributes(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The command line object. */
{
OSErr err;
FSSpec fileSpec;
FInfo finfo;
- Tcl_DString pathString;
+ CONST char *native;
- Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
- err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
- Tcl_DStringValue(&pathString), &fileSpec);
- Tcl_DStringFree(&pathString);
+ native=Tcl_FSGetNativePath(fileName);
+ err = FSpLLocationFromPath(strlen(native),
+ native, &fileSpec);
if (err == noErr) {
err = FSpGetFInfo(&fileSpec, &finfo);
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendStringsToObj(resultPtr, "cannot set ",
tclpFileAttrStrings[objIndex], ": \"",
- fileName, "\" is a directory", (char *) NULL);
+ Tcl_GetString(fileName), "\" is a directory", (char *) NULL);
return TCL_ERROR;
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName, "\": ",
+ "could not read \"", Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
SetFileReadOnly(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *readOnlyPtr) /* The command line object. */
{
OSErr err;
FSSpec fileSpec;
HParamBlockRec paramBlock;
int hidden;
- Tcl_DString pathString;
+ CONST char *native;
- Tcl_UtfToExternalDString(NULL, fileName, -1, &pathString);
- err = FSpLocationFromPath(Tcl_DStringLength(&pathString),
- Tcl_DStringValue(&pathString), &fileSpec);
- Tcl_DStringFree(&pathString);
+ native=Tcl_FSGetNativePath(fileName);
+ err = FSpLLocationFromPath(strlen(native),
+ native, &fileSpec);
if (err == noErr) {
if (Tcl_GetBooleanFromObj(interp, readOnlyPtr, &hidden) != TCL_OK) {
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName, "\": ",
+ "could not read \"", Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
- * TclpListVolumes --
+ * TclpObjListVolumes --
*
* Lists the currently mounted volumes
*
* Results:
- * A standard Tcl result. Will always be TCL_OK, since there is no way
- * that this command can fail. Also, the interpreter's result is set to
- * the list of volumes.
+ * The list of volumes.
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
-int
-TclpListVolumes(
- Tcl_Interp *interp) /* Interpreter to which to pass the volume list */
+Tcl_Obj*
+TclpObjListVolumes(void)
{
HParamBlockRec pb;
Str255 name;
break;
}
- Tcl_ExternalToUtfDString(NULL, (char *) &name[1], name[0], &dstr);
+ Tcl_ExternalToUtfDString(NULL, (CONST char *)&name[1], name[0], &dstr);
elemPtr = Tcl_NewStringObj(Tcl_DStringValue(&dstr),
Tcl_DStringLength(&dstr));
Tcl_AppendToObj(elemPtr, ":", 1);
- Tcl_ListObjAppendElement(interp, resultPtr, elemPtr);
+ Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
Tcl_DStringFree(&dstr);
volIndex++;
}
-
- Tcl_SetObjResult(interp, resultPtr);
- return TCL_OK;
+
+ Tcl_IncrRefCount(resultPtr);
+ return resultPtr;
+}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpObjNormalizePath --
+ *
+ * This function scans through a path specification and replaces
+ * it, in place, with a normalized version. On MacOS, this means
+ * resolving all aliases present in the path and replacing the head of
+ * pathPtr with the absolute case-sensitive path to the last file or
+ * directory that could be validated in the path.
+ *
+ * Results:
+ * The new 'nextCheckpoint' value, giving as far as we could
+ * understand in the path.
+ *
+ * Side effects:
+ * The pathPtr string, which must contain a valid path, is
+ * possibly modified in place.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+ int nextCheckpoint;
+{
+ #define MAXMACFILENAMELEN 31 /* assumed to be < sizeof(StrFileName) */
+
+ StrFileName fileName;
+ StringPtr fileNamePtr;
+ int fileNameLen,newPathLen;
+ Handle newPathHandle;
+ OSErr err;
+ short vRefNum;
+ long dirID;
+ Boolean isDirectory;
+ Boolean wasAlias=FALSE;
+ FSSpec fileSpec, lastFileSpec;
+
+ Tcl_DString nativeds;
+
+ char cur;
+ int firstCheckpoint=nextCheckpoint, lastCheckpoint;
+ int origPathLen;
+ char *path = Tcl_GetStringFromObj(pathPtr,&origPathLen);
+
+ {
+ int currDirValid=0;
+ /*
+ * check if substring to first ':' after initial
+ * nextCheckpoint is a valid relative or absolute
+ * path to a directory, if not we return without
+ * normalizing anything
+ */
+
+ while (1) {
+ cur = path[nextCheckpoint];
+ if (cur == ':' || cur == 0) {
+ if (cur == ':') {
+ /* jump over separator */
+ nextCheckpoint++; cur = path[nextCheckpoint];
+ }
+ Tcl_UtfToExternalDString(NULL,path,nextCheckpoint,&nativeds);
+ err = FSpLLocationFromPath(Tcl_DStringLength(&nativeds),
+ Tcl_DStringValue(&nativeds),
+ &fileSpec);
+ Tcl_DStringFree(&nativeds);
+ if (err == noErr) {
+ lastFileSpec=fileSpec;
+ err = ResolveAliasFile(&fileSpec, true, &isDirectory,
+ &wasAlias);
+ if (err == noErr) {
+ err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory);
+ currDirValid = ((err == noErr) && isDirectory);
+ vRefNum = fileSpec.vRefNum;
+ }
+ }
+ break;
+ }
+ nextCheckpoint++;
+ }
+
+ if(!currDirValid) {
+ /* can't determine root dir, bail out */
+ return firstCheckpoint;
+ }
+ }
+
+ /*
+ * Now vRefNum and dirID point to a valid
+ * directory, so walk the rest of the path
+ * ( code adapted from FSpLocationFromPath() )
+ */
+
+ lastCheckpoint=nextCheckpoint;
+ while (1) {
+ cur = path[nextCheckpoint];
+ if (cur == ':' || cur == 0) {
+ fileNameLen=nextCheckpoint-lastCheckpoint;
+ fileNamePtr=fileName;
+ if(fileNameLen==0) {
+ if (cur == ':') {
+ /*
+ * special case for empty dirname i.e. encountered
+ * a '::' path component: get parent dir of currDir
+ */
+ fileName[0]=2;
+ strcpy((char *) fileName + 1, "::");
+ lastCheckpoint--;
+ } else {
+ /*
+ * empty filename, i.e. want FSSpec for currDir
+ */
+ fileNamePtr=NULL;
+ }
+ } else {
+ Tcl_UtfToExternalDString(NULL,&path[lastCheckpoint],
+ fileNameLen,&nativeds);
+ fileNameLen=Tcl_DStringLength(&nativeds);
+ if(fileNameLen > MAXMACFILENAMELEN) {
+ err = bdNamErr;
+ } else {
+ fileName[0]=fileNameLen;
+ strncpy((char *) fileName + 1, Tcl_DStringValue(&nativeds),
+ fileNameLen);
+ }
+ Tcl_DStringFree(&nativeds);
+ }
+ if(err == noErr)
+ err=FSMakeFSSpecCompat(vRefNum, dirID, fileNamePtr, &fileSpec);
+ if(err != noErr) {
+ if(err != fnfErr) {
+ /*
+ * this can occur if trying to get parent of a root
+ * volume via '::' or when using an illegal
+ * filename; revert to last checkpoint and stop
+ * processing path further
+ */
+ err=FSMakeFSSpecCompat(vRefNum, dirID, NULL, &fileSpec);
+ if(err != noErr) {
+ /* should never happen, bail out */
+ return firstCheckpoint;
+ }
+ nextCheckpoint=lastCheckpoint;
+ cur = path[lastCheckpoint];
+ }
+ break; /* arrived at nonexistent file or dir */
+ } else {
+ /* fileSpec could point to an alias, resolve it */
+ lastFileSpec=fileSpec;
+ err = ResolveAliasFile(&fileSpec, true, &isDirectory,
+ &wasAlias);
+ if (err != noErr || !isDirectory) {
+ break; /* fileSpec doesn't point to a dir */
+ }
+ }
+ if (cur == 0) break; /* arrived at end of path */
+
+ /* fileSpec points to possibly nonexisting subdirectory; validate */
+ err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory);
+ if (err != noErr || !isDirectory) {
+ break; /* fileSpec doesn't point to existing dir */
+ }
+ vRefNum = fileSpec.vRefNum;
+
+ /* found a new valid subdir in path, continue processing path */
+ lastCheckpoint=nextCheckpoint+1;
+ }
+ wasAlias=FALSE;
+ nextCheckpoint++;
+ }
+
+ if (wasAlias)
+ fileSpec=lastFileSpec;
+
+ /*
+ * fileSpec now points to a possibly nonexisting file or dir
+ * inside a valid dir; get full path name to it
+ */
+
+ err=FSpPathFromLocation(&fileSpec, &newPathLen, &newPathHandle);
+ if(err != noErr) {
+ return firstCheckpoint; /* should not see any errors here, bail out */
+ }
+
+ HLock(newPathHandle);
+ Tcl_ExternalToUtfDString(NULL,*newPathHandle,newPathLen,&nativeds);
+ if (cur != 0) {
+ /* not at end, append remaining path */
+ if ( newPathLen==0 || (*(*newPathHandle+(newPathLen-1))!=':' && path[nextCheckpoint] !=':')) {
+ Tcl_DStringAppend(&nativeds, ":" , 1);
+ }
+ Tcl_DStringAppend(&nativeds, &path[nextCheckpoint],
+ strlen(&path[nextCheckpoint]));
+ }
+ DisposeHandle(newPathHandle);
+
+ fileNameLen=Tcl_DStringLength(&nativeds);
+ Tcl_SetStringObj(pathPtr,Tcl_DStringValue(&nativeds),fileNameLen);
+ Tcl_DStringFree(&nativeds);
+
+ return nextCheckpoint+(fileNameLen-origPathLen);
}
#include <MoreFilesExtras.h>
#include <FSpCompat.h>
-/*
- * Static variables used by the TclpStat function.
- */
-static int initialized = false;
-static long gmt_offset;
-TCL_DECLARE_MUTEX(gmtMutex)
+static int NativeMatchType(Tcl_Obj *tempName, Tcl_GlobTypeData *types,
+ HFileInfo fileInfo, OSType okType, OSType okCreator);
+static OSErr FspLocationFromFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ FSSpec* specPtr));
+static OSErr FspLLocationFromFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ FSSpec* specPtr));
+
+static OSErr
+FspLocationFromFsPath(pathPtr, specPtr)
+ Tcl_Obj *pathPtr;
+ FSSpec* specPtr;
+{
+ CONST char *native = Tcl_FSGetNativePath(pathPtr);
+ return FSpLocationFromPath(strlen(native), native, specPtr);
+}
+
+static OSErr
+FspLLocationFromFsPath(pathPtr, specPtr)
+ Tcl_Obj *pathPtr;
+ FSSpec* specPtr;
+{
+ CONST char *native = Tcl_FSGetNativePath(pathPtr);
+ return FSpLLocationFromPath(strlen(native), native, specPtr);
+}
\f
/*
/*
*----------------------------------------------------------------------
*
- * TclpMatchFilesTypes --
+ * TclpMatchInDirectory --
*
* This routine is used by the globbing code to search a
* directory for all files which match a given pattern.
*
* Results:
- * If the tail argument is NULL, then the matching files are
- * added to the the interp's result. Otherwise, TclDoGlob is called
- * recursively for each matching subdirectory. The return value
- * is a standard Tcl result indicating whether an error occurred
- * in globbing.
+ *
+ * The return value is a standard Tcl result indicating whether an
+ * error occurred in globbing. Errors are left in interp, good
+ * results are lappended to resultPtr (which must be a valid object)
*
* Side effects:
* None.
*---------------------------------------------------------------------- */
int
-TclpMatchFilesTypes(
- Tcl_Interp *interp, /* Interpreter to receive results. */
- char *separators, /* Directory separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr, /* Contains path to directory to search. */
- char *pattern, /* Pattern to match against. */
- char *tail, /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static.*/
- GlobTypeData *types) /* Object containing list of acceptable types.
- * May be NULL. */
+TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
+ Tcl_Interp *interp; /* Interpreter to receive errors. */
+ Tcl_Obj *resultPtr; /* List object to lappend results. */
+ Tcl_Obj *pathPtr; /* Contains path to directory to search. */
+ CONST char *pattern; /* Pattern to match against. NULL or empty
+ * means pathPtr is actually a single file
+ * to check. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. In particular the directory
+ * flag is very important. */
{
- char *fname, *patternEnd = tail;
- char savedChar;
- int fnameLen, result = TCL_OK;
- int baseLength = Tcl_DStringLength(dirPtr);
- CInfoPBRec pb;
- OSErr err;
- FSSpec dirSpec;
- Boolean isDirectory;
- long dirID;
- short itemIndex;
- Str255 fileName;
- Tcl_DString fileString;
- Tcl_Obj *resultPtr;
OSType okType = 0;
OSType okCreator = 0;
+ Tcl_Obj *fileNamePtr;
- /*
- * Make sure that the directory part of the name really is a
- * directory.
- */
-
- Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(dirPtr),
- Tcl_DStringLength(dirPtr), &fileString);
-
- FSpLocationFromPath(fileString.length, fileString.string, &dirSpec);
- Tcl_DStringFree(&fileString);
-
- err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
- if ((err != noErr) || !isDirectory) {
- return TCL_OK;
- }
-
- /*
- * Now open the directory for reading and iterate over the contents.
- */
-
- pb.hFileInfo.ioVRefNum = dirSpec.vRefNum;
- pb.hFileInfo.ioDirID = dirID;
- pb.hFileInfo.ioNamePtr = (StringPtr) fileName;
- pb.hFileInfo.ioFDirIndex = itemIndex = 1;
-
- /*
- * Clean up the end of the pattern and the tail pointer. Leave
- * the tail pointing to the first character after the path separator
- * following the pattern, or NULL. Also, ensure that the pattern
- * is null-terminated.
- */
-
- if (*tail == '\\') {
- tail++;
- }
- if (*tail == '\0') {
- tail = NULL;
- } else {
- tail++;
+ fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (fileNamePtr == NULL) {
+ return TCL_ERROR;
}
- savedChar = *patternEnd;
- *patternEnd = '\0';
-
- resultPtr = Tcl_GetObjResult(interp);
+
if (types != NULL) {
if (types->macType != NULL) {
Tcl_GetOSTypeFromObj(NULL, types->macType, &okType);
}
}
- while (1) {
- pb.hFileInfo.ioFDirIndex = itemIndex;
- pb.hFileInfo.ioDirID = dirID;
- err = PBGetCatInfoSync(&pb);
- if (err != noErr) {
- break;
+ if (pattern == NULL || (*pattern == '\0')) {
+ /* Match a single file directly */
+ Tcl_StatBuf buf;
+ CInfoPBRec paramBlock;
+ FSSpec fileSpec;
+
+ if (TclpObjLstat(fileNamePtr, &buf) != 0) {
+ /* File doesn't exist */
+ return TCL_OK;
+ }
+
+ if (FspLLocationFromFsPath(fileNamePtr, &fileSpec) == noErr) {
+ paramBlock.hFileInfo.ioCompletion = NULL;
+ paramBlock.hFileInfo.ioNamePtr = fileSpec.name;
+ paramBlock.hFileInfo.ioVRefNum = fileSpec.vRefNum;
+ paramBlock.hFileInfo.ioFDirIndex = 0;
+ paramBlock.hFileInfo.ioDirID = fileSpec.parID;
+
+ PBGetCatInfo(¶mBlock, 0);
}
+ if (NativeMatchType(fileNamePtr, types, paramBlock.hFileInfo,
+ okType, okCreator)) {
+ int fnameLen;
+ char *fname = Tcl_GetStringFromObj(pathPtr,&fnameLen);
+ if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname+1, fnameLen-1));
+ } else {
+ Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
+ }
+ }
+ return TCL_OK;
+ } else {
+ char *fname;
+ int fnameLen, result = TCL_OK;
+ int baseLength;
+ CInfoPBRec pb;
+ OSErr err;
+ FSSpec dirSpec;
+ Boolean isDirectory;
+ long dirID;
+ short itemIndex;
+ Str255 fileName;
+ Tcl_DString fileString;
+ Tcl_DString dsOrig;
+
+ Tcl_DStringInit(&dsOrig);
+ Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
+ baseLength = Tcl_DStringLength(&dsOrig);
+
/*
- * Now check to see if the file matches. If there are more
- * characters to be processed, then ensure matching files are
- * directories before calling TclDoGlob. Otherwise, just add
- * the file to the result.
+ * Make sure that the directory part of the name really is a
+ * directory.
*/
-
- Tcl_ExternalToUtfDString(NULL, (char *) fileName + 1, fileName[0],
- &fileString);
- if (Tcl_StringMatch(Tcl_DStringValue(&fileString), pattern)) {
- Tcl_DStringSetLength(dirPtr, baseLength);
- Tcl_DStringAppend(dirPtr, Tcl_DStringValue(&fileString), -1);
- fname = Tcl_DStringValue(dirPtr);
- fnameLen = Tcl_DStringLength(dirPtr);
- if (tail == NULL) {
- int typeOk = 1;
- if (types != NULL) {
- if (types->perm != 0) {
- if (
- ((types->perm & TCL_GLOB_PERM_RONLY) &&
- !(pb.hFileInfo.ioFlAttrib & 1)) ||
- ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
- !(pb.hFileInfo.ioFlFndrInfo.fdFlags &
- kIsInvisible)) ||
- ((types->perm & TCL_GLOB_PERM_R) &&
- (TclpAccess(fname, R_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_W) &&
- (TclpAccess(fname, W_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_X) &&
- (TclpAccess(fname, X_OK) != 0))
- ) {
- typeOk = 0;
- }
- }
- if (typeOk == 1 && types->type != 0) {
- struct stat buf;
- /*
- * We must match at least one flag to be listed
- */
- typeOk = 0;
- if (TclpLstat(fname, &buf) >= 0) {
- /*
- * In order bcdpfls as in 'find -t'
- */
- if (
- ((types->type & TCL_GLOB_TYPE_BLOCK) &&
- S_ISBLK(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_CHAR) &&
- S_ISCHR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_DIR) &&
- S_ISDIR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_PIPE) &&
- S_ISFIFO(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_FILE) &&
- S_ISREG(buf.st_mode))
-#ifdef S_ISLNK
- || ((types->type & TCL_GLOB_TYPE_LINK) &&
- S_ISLNK(buf.st_mode))
-#endif
-#ifdef S_ISSOCK
- || ((types->type & TCL_GLOB_TYPE_SOCK) &&
- S_ISSOCK(buf.st_mode))
-#endif
- ) {
- typeOk = 1;
- }
- } else {
- /* Posix error occurred */
- }
- }
- if (typeOk && (
- ((okType != 0) && (okType !=
- pb.hFileInfo.ioFlFndrInfo.fdType)) ||
- ((okCreator != 0) && (okCreator !=
- pb.hFileInfo.ioFlFndrInfo.fdCreator)))) {
- typeOk = 0;
- }
- }
- if (typeOk) {
+
+ Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig),
+ Tcl_DStringLength(&dsOrig), &fileString);
+
+ err = FSpLocationFromPath(Tcl_DStringLength(&fileString),
+ Tcl_DStringValue(&fileString), &dirSpec);
+ Tcl_DStringFree(&fileString);
+ if (err == noErr) {
+ err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
+ }
+
+ if ((err != noErr) || !isDirectory) {
+ /*
+ * Check if we had a relative path (unix style relative path
+ * compatibility for glob)
+ */
+ Tcl_DStringFree(&dsOrig);
+ Tcl_DStringAppend(&dsOrig, ":", 1);
+ Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
+ baseLength = Tcl_DStringLength(&dsOrig);
+
+ Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&dsOrig),
+ Tcl_DStringLength(&dsOrig), &fileString);
+
+ err = FSpLocationFromPath(Tcl_DStringLength(&fileString),
+ Tcl_DStringValue(&fileString), &dirSpec);
+ Tcl_DStringFree(&fileString);
+ if (err == noErr) {
+ err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
+ }
+
+ if ((err != noErr) || !isDirectory) {
+ Tcl_DStringFree(&dsOrig);
+ return TCL_OK;
+ }
+ }
+
+ /* Make sure we have a trailing directory delimiter */
+ if (Tcl_DStringValue(&dsOrig)[baseLength-1] != ':') {
+ Tcl_DStringAppend(&dsOrig, ":", 1);
+ baseLength++;
+ }
+
+ /*
+ * Now open the directory for reading and iterate over the contents.
+ */
+
+ pb.hFileInfo.ioVRefNum = dirSpec.vRefNum;
+ pb.hFileInfo.ioDirID = dirID;
+ pb.hFileInfo.ioNamePtr = (StringPtr) fileName;
+ pb.hFileInfo.ioFDirIndex = itemIndex = 1;
+
+ while (1) {
+ pb.hFileInfo.ioFDirIndex = itemIndex;
+ pb.hFileInfo.ioDirID = dirID;
+ err = PBGetCatInfoSync(&pb);
+ if (err != noErr) {
+ break;
+ }
+
+ /*
+ * Now check to see if the file matches.
+ */
+
+ Tcl_ExternalToUtfDString(NULL, (char *) fileName + 1, fileName[0],
+ &fileString);
+ if (Tcl_StringMatch(Tcl_DStringValue(&fileString), pattern)) {
+ Tcl_Obj *tempName;
+ Tcl_DStringSetLength(&dsOrig, baseLength);
+ Tcl_DStringAppend(&dsOrig, Tcl_DStringValue(&fileString), -1);
+ fname = Tcl_DStringValue(&dsOrig);
+ fnameLen = Tcl_DStringLength(&dsOrig);
+
+ /*
+ * We use this tempName in calls to check the file's
+ * type below. We may also use it for the result.
+ */
+ tempName = Tcl_NewStringObj(fname, fnameLen);
+ Tcl_IncrRefCount(tempName);
+
+ /* Is the type acceptable? */
+ if (NativeMatchType(tempName, types, pb.hFileInfo,
+ okType, okCreator)) {
if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) {
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(fname+1, fnameLen-1));
} else {
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname, fnameLen));
+ Tcl_ListObjAppendElement(interp, resultPtr, tempName);
}
}
- } else if ((pb.hFileInfo.ioFlAttrib & ioDirMask) != 0) {
- Tcl_DStringAppend(dirPtr, ":", 1);
- result = TclDoGlob(interp, separators, dirPtr, tail, types);
- if (result != TCL_OK) {
- Tcl_DStringFree(&fileString);
- break;
- }
+ /*
+ * This will free the object, unless it was inserted in
+ * the result list above.
+ */
+ Tcl_DecrRefCount(tempName);
}
+ Tcl_DStringFree(&fileString);
+ itemIndex++;
}
- Tcl_DStringFree(&fileString);
- itemIndex++;
- }
- *patternEnd = savedChar;
- return result;
+ Tcl_DStringFree(&dsOrig);
+ return result;
+ }
}
-\f
-/*
- * TclpMatchFiles --
- *
- * This function is now obsolete. Call the above function
- * 'TclpMatchFilesTypes' instead.
- */
-int
-TclpMatchFiles(
- Tcl_Interp *interp, /* Interpreter to receive results. */
- char *separators, /* Directory separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr, /* Contains path to directory to search. */
- char *pattern, /* Pattern to match against. */
- char *tail) /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static.*/
+
+static int
+NativeMatchType(
+ Tcl_Obj *tempName, /* Path to check */
+ Tcl_GlobTypeData *types, /* Type description to match against */
+ HFileInfo fileInfo, /* MacOS file info */
+ OSType okType, /* Acceptable MacOS type, or zero */
+ OSType okCreator) /* Acceptable MacOS creator, or zero */
{
- return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
+ if (types == NULL) {
+ /* If invisible, don't return the file */
+ if (fileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) {
+ return 0;
+ }
+ } else {
+ Tcl_StatBuf buf;
+
+ if (fileInfo.ioFlFndrInfo.fdFlags & kIsInvisible) {
+ /* If invisible */
+ if ((types->perm == 0) ||
+ !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
+ return 0;
+ }
+ } else {
+ /* Visible */
+ if (types->perm & TCL_GLOB_PERM_HIDDEN) {
+ return 0;
+ }
+ }
+ if (types->perm != 0) {
+ if (
+ ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ !(fileInfo.ioFlAttrib & 1)) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (TclpObjAccess(tempName, R_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (TclpObjAccess(tempName, W_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (TclpObjAccess(tempName, X_OK) != 0))
+ ) {
+ return 0;
+ }
+ }
+ if (types->type != 0) {
+ if (TclpObjStat(tempName, &buf) != 0) {
+ /* Posix error occurred */
+ return 0;
+ }
+ /*
+ * In order bcdpfls as in 'find -t'
+ */
+ if (
+ ((types->type & TCL_GLOB_TYPE_BLOCK) &&
+ S_ISBLK(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_CHAR) &&
+ S_ISCHR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_DIR) &&
+ S_ISDIR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_PIPE) &&
+ S_ISFIFO(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_FILE) &&
+ S_ISREG(buf.st_mode))
+#ifdef S_ISSOCK
+ || ((types->type & TCL_GLOB_TYPE_SOCK) &&
+ S_ISSOCK(buf.st_mode))
+#endif
+ ) {
+ /* Do nothing -- this file is ok */
+ } else {
+ int typeOk = 0;
+#ifdef S_ISLNK
+ if (types->type & TCL_GLOB_TYPE_LINK) {
+ if (TclpObjLstat(tempName, &buf) == 0) {
+ if (S_ISLNK(buf.st_mode)) {
+ typeOk = 1;
+ }
+ }
+ }
+#endif
+ if (typeOk == 0) {
+ return 0;
+ }
+ }
+ }
+ if (((okType != 0) && (okType !=
+ fileInfo.ioFlFndrInfo.fdType)) ||
+ ((okCreator != 0) && (okCreator !=
+ fileInfo.ioFlFndrInfo.fdCreator))) {
+ return 0;
+ }
+ }
+ return 1;
}
+
\f
/*
*----------------------------------------------------------------------
*
- * TclpAccess --
+ * TclpObjAccess --
*
* This function replaces the library version of access().
*
*----------------------------------------------------------------------
*/
-int
-TclpAccess(
- CONST char *path, /* Path of file to access (UTF-8). */
- int mode) /* Permission setting. */
+int
+TclpObjAccess(pathPtr, mode)
+ Tcl_Obj *pathPtr;
+ int mode;
{
HFileInfo fpb;
HVolumeParam vpb;
FSSpec fileSpec;
Boolean isDirectory;
long dirID;
- Tcl_DString ds;
- char *native;
int full_mode = 0;
- native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
- err = FSpLocationFromPath(Tcl_DStringLength(&ds), native, &fileSpec);
- Tcl_DStringFree(&ds);
+ err = FspLLocationFromFsPath(pathPtr, &fileSpec);
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
* files of type 'APPL' are executable.
*/
if (!(fpb.ioFlAttrib & 0x10) && (mode & X_OK)
- && (fpb.ioFlFndrInfo.fdType != 'APPL')) {
+ && (fpb.ioFlFndrInfo.fdType != 'APPL')) {
return -1;
}
}
/*
*----------------------------------------------------------------------
*
- * TclpChdir --
+ * TclpObjChdir --
*
* This function replaces the library version of chdir().
*
*
* Side effects:
* See chdir() documentation. Also the cache maintained used by
- * TclGetCwd() is deallocated and set to NULL.
+ * Tcl_FSGetCwd() is deallocated and set to NULL.
*
*----------------------------------------------------------------------
*/
-int
-TclpChdir(
- CONST char *dirName) /* Path to new working directory (UTF-8). */
+int
+TclpObjChdir(pathPtr)
+ Tcl_Obj *pathPtr;
{
FSSpec spec;
OSErr err;
Boolean isFolder;
long dirID;
- Tcl_DString ds;
- char *native;
- native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
- err = FSpLocationFromPath(Tcl_DStringLength(&ds), native, &spec);
- Tcl_DStringFree(&ds);
+ err = FspLocationFromFsPath(pathPtr, &spec);
if (err != noErr) {
errno = ENOENT;
/*
*----------------------------------------------------------------------
*
- * TclpGetCwd --
+ * TclpObjGetCwd --
*
* This function replaces the library version of getcwd().
*
*----------------------------------------------------------------------
*/
-char *
+Tcl_Obj*
+TclpObjGetCwd(interp)
+ Tcl_Interp *interp;
+{
+ Tcl_DString ds;
+ if (TclpGetCwd(interp, &ds) != NULL) {
+ Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_IncrRefCount(cwdPtr);
+ Tcl_DStringFree(&ds);
+ return cwdPtr;
+ } else {
+ return NULL;
+ }
+}
+
+CONST char *
TclpGetCwd(
Tcl_Interp *interp, /* If non-NULL, used for error reporting. */
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled
Handle theString = NULL;
int pathSize;
Tcl_DString ds;
- char *native;
- native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
+ Tcl_UtfToExternalDString(NULL, path, -1, &ds);
/*
* Remove ending colons if they exist.
*/
- while ((strlen(native) != 0) && (path[strlen(native) - 1] == ':')) {
- native[strlen(native) - 1] = NULL;
+ while ((Tcl_DStringLength(&ds) != 0)
+ && (Tcl_DStringValue(&ds)[Tcl_DStringLength(&ds) - 1] == ':')) {
+ Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 1);
}
- if (strchr(native, ':') == NULL) {
- strcpy(fileName + 1, native);
- native = NULL;
+ end = strrchr(Tcl_DStringValue(&ds), ':');
+ if (end == NULL ) {
+ strcpy(fileName + 1, Tcl_DStringValue(&ds));
} else {
- end = strrchr(native, ':') + 1;
- strcpy(fileName + 1, end);
- *end = NULL;
+ strcpy(fileName + 1, end + 1);
+ Tcl_DStringSetLength(&ds, end + 1 - Tcl_DStringValue(&ds));
}
fileName[0] = (char) strlen(fileName + 1);
* we want to look at.
*/
- if (native != NULL) {
- err = FSpLocationFromPath(strlen(native), native, &fileSpec);
+ if (end != NULL) {
+ err = FSpLocationFromPath(Tcl_DStringLength(&ds),
+ Tcl_DStringValue(&ds), &fileSpec);
if (err != noErr) {
Tcl_DStringFree(&ds);
errno = EINVAL;
return Tcl_DStringValue(linkPtr);
}
+
+static int
+TclpObjStatAlias _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *bufPtr,
+ Boolean resolveLink));
+
\f
/*
*----------------------------------------------------------------------
*
- * TclpLstat --
+ * TclpObjLstat --
*
* This function replaces the library version of lstat().
*
* Results:
- * See stat() documentation.
+ * See lstat() documentation.
*
* Side effects:
- * See stat() documentation.
+ * See lstat() documentation.
*
*----------------------------------------------------------------------
*/
-int
-TclpLstat(
- CONST char *path, /* Path of file to stat (in UTF-8). */
- struct stat *bufPtr) /* Filled with results of stat call. */
+int
+TclpObjLstat(pathPtr, buf)
+ Tcl_Obj *pathPtr;
+ Tcl_StatBuf *buf;
{
- /*
- * FIXME: Emulate TclpLstat
- */
-
- return TclpStat(path, bufPtr);
+ return TclpObjStatAlias(pathPtr, buf, FALSE);
}
\f
/*
*----------------------------------------------------------------------
*
- * TclpStat --
+ * TclpObjStat --
*
* This function replaces the library version of stat().
*
*----------------------------------------------------------------------
*/
-int
-TclpStat(
- CONST char *path, /* Path of file to stat (in UTF-8). */
- struct stat *bufPtr) /* Filled with results of stat call. */
+int
+TclpObjStat(pathPtr, bufPtr)
+ Tcl_Obj *pathPtr;
+ Tcl_StatBuf *bufPtr;
+{
+ return TclpObjStatAlias(pathPtr, bufPtr, TRUE);
+}
+\f
+
+static int
+TclpObjStatAlias (Tcl_Obj *pathPtr, Tcl_StatBuf *bufPtr, Boolean resolveLink)
{
HFileInfo fpb;
HVolumeParam vpb;
FSSpec fileSpec;
Boolean isDirectory;
long dirID;
- Tcl_DString ds;
- path = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
- err = FSpLocationFromPath(Tcl_DStringLength(&ds), path, &fileSpec);
- Tcl_DStringFree(&ds);
+ if (resolveLink)
+ err = FspLocationFromFsPath(pathPtr, &fileSpec);
+ else
+ err = FspLLocationFromFsPath(pathPtr, &fileSpec);
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
}
}
if ((fpb.ioFlAttrib & 0x10) || (fpb.ioFlFndrInfo.fdType == 'APPL')) {
- /*
- * Directories and applications are executable by everyone.
- */
-
- bufPtr->st_mode |= S_IXUSR | S_IXGRP | S_IXOTH;
+ /*
+ * Directories and applications are executable by everyone.
+ */
+
+ bufPtr->st_mode |= S_IXUSR | S_IXGRP | S_IXOTH;
}
if ((fpb.ioFlAttrib & 0x01) == 0){
- /*
- * If not locked, then everyone has write acces.
- */
-
- bufPtr->st_mode |= S_IWUSR | S_IWGRP | S_IWOTH;
+ /*
+ * If not locked, then everyone has write acces.
+ */
+
+ bufPtr->st_mode |= S_IWUSR | S_IWGRP | S_IWOTH;
}
bufPtr->st_ino = fpb.ioDirID;
bufPtr->st_dev = fpb.ioVRefNum;
/*
* The times returned by the Mac file system are in the
* local time zone. We convert them to GMT so that the
- * epoch starts from GMT. This is also consistant with
+ * epoch starts from GMT. This is also consistent with
* what is returned from "clock seconds".
*/
- Tcl_MutexLock(&gmtMutex);
- if (initialized == false) {
- MachineLocation loc;
-
- ReadLocation(&loc);
- gmt_offset = loc.u.gmtDelta & 0x00ffffff;
- if (gmt_offset & 0x00800000) {
- gmt_offset = gmt_offset | 0xff000000;
- }
- initialized = true;
- }
- Tcl_MutexUnlock(&gmtMutex);
-
- bufPtr->st_atime = bufPtr->st_mtime = fpb.ioFlMdDat - gmt_offset;
- bufPtr->st_ctime = fpb.ioFlCrDat - gmt_offset;
+ bufPtr->st_atime = bufPtr->st_mtime = fpb.ioFlMdDat
+ - TclpGetGMTOffset() + tcl_mac_epoch_offset;
+ bufPtr->st_ctime = fpb.ioFlCrDat - TclpGetGMTOffset()
+ + tcl_mac_epoch_offset;
}
}
int size;
FILE * f;
- err = FSpLocationFromPath(strlen(path), (char *) path, &fileSpec);
+ err = FSpLocationFromPath(strlen(path), path, &fileSpec);
if ((err != noErr) && (err != fnfErr)) {
return NULL;
}
return EINVAL;
}
}
+
int
TclMacChmod(
- char *path,
+ CONST char *path,
int mode)
{
HParamBlockRec hpb;
OSErr err;
-
- c2pstr(path);
- hpb.fileParam.ioNamePtr = (unsigned char *) path;
+ Str255 pathName;
+ strcpy((char *) pathName + 1, path);
+ pathName[0] = strlen(path);
+ hpb.fileParam.ioNamePtr = pathName;
hpb.fileParam.ioVRefNum = 0;
hpb.fileParam.ioDirID = 0;
} else {
err = PBHSetFLockSync(&hpb);
}
- p2cstr((unsigned char *) path);
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
return 0;
}
+
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpTempFileName --
+ *
+ * This function returns a unique filename.
+ *
+ * Results:
+ * Returns a valid Tcl_Obj* with refCount 0, or NULL on failure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclpTempFileName()
+{
+ char fileName[L_tmpnam];
+
+ if (tmpnam(fileName) == NULL) { /* INTL: Native. */
+ return NULL;
+ }
+
+ return TclpNativeToNormalized((ClientData) fileName);
+}
+
+#ifdef S_IFLNK
+
+Tcl_Obj*
+TclpObjLink(pathPtr, toPtr, linkAction)
+ Tcl_Obj *pathPtr;
+ Tcl_Obj *toPtr;
+ int linkAction;
+{
+ Tcl_Obj* link = NULL;
+
+ if (toPtr != NULL) {
+ if (TclpObjAccess(pathPtr, F_OK) != -1) {
+ /* src exists */
+ errno = EEXIST;
+ return NULL;
+ }
+ if (TclpObjAccess(toPtr, F_OK) == -1) {
+ /* target doesn't exist */
+ errno = ENOENT;
+ return NULL;
+ }
+
+ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ /* Needs to create a new link */
+ FSSpec spec;
+ FSSpec linkSpec;
+ OSErr err;
+ CONST char *path;
+ AliasHandle alias;
+
+ err = FspLocationFromFsPath(toPtr, &spec);
+ if (err != noErr) {
+ errno = ENOENT;
+ return NULL;
+ }
+
+ path = Tcl_FSGetNativePath(pathPtr);
+ err = FSpLocationFromPath(strlen(path), path, &linkSpec);
+ if (err == noErr) {
+ err = dupFNErr; /* EEXIST. */
+ } else {
+ err = NewAlias(&spec, &linkSpec, &alias);
+ }
+ if (err != noErr) {
+ errno = TclMacOSErrorToPosixError(err);
+ return NULL;
+ }
+ return toPtr;
+ } else {
+ errno = ENODEV;
+ return NULL;
+ }
+ } else {
+ Tcl_DString ds;
+ Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
+ if (transPtr == NULL) {
+ return NULL;
+ }
+ if (TclpReadlink(Tcl_GetString(transPtr), &ds) != NULL) {
+ link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_IncrRefCount(link);
+ Tcl_DStringFree(&ds);
+ }
+ }
+ return link;
+}
+
+#endif
+
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpFilesystemPathType --
+ *
+ * This function is part of the native filesystem support, and
+ * returns the path type of the given path. Right now it simply
+ * returns NULL. In the future it could return specific path
+ * types, like 'HFS', 'HFS+', 'nfs', 'samba', 'FAT32', etc.
+ *
+ * Results:
+ * NULL at present.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+TclpFilesystemPathType(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ /* All native paths are of the same type */
+ return NULL;
+}
#include "tclInt.h"
#include "tclMacInt.h"
#include "tclPort.h"
+#include "tclInitScript.h"
/*
* The following string is the startup script executed in new
* init.tcl script does all of the real work of initialization.
*/
-static char initCmd[] = "\
+static char initCmd[] = "if {[info proc tclInit]==\"\"} {\n\
+proc tclInit {} {\n\
+global tcl_pkgPath env\n\
proc sourcePath {file} {\n\
- set dirs {}\n\
foreach i $::auto_path {\n\
set init [file join $i $file.tcl]\n\
if {[catch {uplevel #0 [list source $init]}] == 0} {\n\
return\n\
}\n\
rename sourcePath {}\n\
- set msg \"can't find $file resource or a usable $file.tcl file\n\"\n\
- append msg \"in the following directories:\n\"\n\
- append msg \" $::auto_path\n\"\n\
- append msg \" perhaps you need to install Tcl or set your \n\"\n\
- append msg \"TCL_LIBRARY environment variable?\"\n\
+ set msg \"Can't find $file resource or a usable $file.tcl file\"\n\
+ append msg \" in the following directories:\"\n\
+ append msg \" $::auto_path\"\n\
+ append msg \" perhaps you need to install Tcl or set your\"\n\
+ append msg \" TCL_LIBRARY environment variable?\"\n\
error $msg\n\
}\n\
if {[info exists env(EXT_FOLDER)]} {\n\
- lappend tcl_pkgPath [file join $env(EXT_FOLDER) {:Tool Command Language}]\n\
+ lappend tcl_pkgPath [file join $env(EXT_FOLDER) {Tool Command Language}]\n\
}\n\
if {[info exists tcl_pkgPath] == 0} {\n\
set tcl_pkgPath {no extension folder}\n\
}\n\
-sourcePath Init\n\
-sourcePath Auto\n\
-sourcePath Package\n\
-sourcePath History\n\
-sourcePath Word\n\
-rename sourcePath {}";
+sourcePath init\n\
+sourcePath auto\n\
+sourcePath package\n\
+sourcePath history\n\
+sourcePath word\n\
+sourcePath parray\n\
+rename sourcePath {}\n\
+} }\n\
+tclInit";
/*
* The following structures are used to map the script/language codes of a
static int GetFinderFont(int *finderID);
+/* Used to store the encoding used for binary files */
+static Tcl_Encoding binaryEncoding = NULL;
+/* Has the basic library path encoding issue been fixed */
+static int libraryPathEncodingFixed = 0;
+
\f
/*
*----------------------------------------------------------------------
* by querying the module handle. */
{
Tcl_Obj *objPtr, *pathPtr;
- char *str;
+ CONST char *str;
Tcl_DString ds;
TclMacCreateEnv();
pathPtr = Tcl_NewObj();
+ /*
+ * Look for the library relative to default encoding dir.
+ */
+
+ str = Tcl_GetDefaultEncodingDir();
+ if ((str != NULL) && (str[0] != '\0')) {
+ objPtr = Tcl_NewStringObj(str, -1);
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+ }
+
str = TclGetEnv("TCL_LIBRARY", &ds);
if ((str != NULL) && (str[0] != '\0')) {
/*
* If TCL_LIBRARY is set, search there.
*/
- objPtr = Tcl_NewStringObj(str, -1);
+ objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
/*
* lappend path [file join $env(EXT_FOLDER) \
- * ":Tool Command Language:tcl[info version]"
+ * "Tool Command Language" "tcl[info version]"
*/
str = TclGetEnv("EXT_FOLDER", &ds);
if ((str != NULL) && (str[0] != '\0')) {
- objPtr = Tcl_NewStringObj(str, -1);
- if (str[strlen(str) - 1] != ':') {
- Tcl_AppendToObj(objPtr, ":", 1);
- }
- Tcl_AppendToObj(objPtr, "Tool Command Language:tcl" TCL_VERSION, -1);
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- Tcl_DStringFree(&ds);
+ Tcl_DString libPath, path;
+ CONST char *argv[3];
+
+ argv[0] = str;
+ argv[1] = "Tool Command Language";
+ Tcl_DStringInit(&libPath);
+ Tcl_DStringAppend(&libPath, "tcl", -1);
+ argv[2] = Tcl_DStringAppend(&libPath, TCL_VERSION, -1);
+ Tcl_DStringInit(&path);
+ str = Tcl_JoinPath(3, argv, &path);
+ objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&path));
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&libPath);
+ Tcl_DStringFree(&path);
}
TclSetLibraryPath(pathPtr);
}
* Based on the locale, determine the encoding of the operating
* system and the default encoding for newly opened files.
*
- * Called at process initialization time.
+ * Called at process initialization time, and part way through
+ * startup, we verify that the initial encodings were correctly
+ * setup. Depending on Tcl's environment, there may not have been
+ * enough information first time through (above).
*
* Results:
* None.
*
* Side effects:
- * The Tcl library path is converted from native encoding to UTF-8.
+ * The Tcl library path is converted from native encoding to UTF-8,
+ * on the first call, and the encodings may be changed on first or
+ * second call.
*
*---------------------------------------------------------------------------
*/
{
CONST char *encoding;
Tcl_Obj *pathPtr;
- int fontId;
+ int fontId, err;
fontId = 0;
GetFinderFont(&fontId);
encoding = "macRoman";
}
- Tcl_SetSystemEncoding(NULL, encoding);
-
+ err = Tcl_SetSystemEncoding(NULL, encoding);
+
+ if (err == TCL_OK && libraryPathEncodingFixed == 0) {
+
/*
* Until the system encoding was actually set, the library path was
* actually in the native multi-byte encoding, and not really UTF-8
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
}
+ Tcl_InvalidateStringRep(pathPtr);
+ }
+ libraryPathEncodingFixed = 1;
+ }
+
+ /* This is only ever called from the startup thread */
+ if (binaryEncoding == NULL) {
+ /*
+ * Keep the iso8859-1 encoding preloaded. The IO package uses
+ * it for gets on a binary channel.
+ */
+ binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
}
-
- /*
- * Keep the iso8859-1 encoding preloaded. The IO package uses it for
- * gets on a binary channel.
- */
-
- Tcl_GetEncoding(NULL, "iso8859-1");
}
\f
/*
int minor, major, objc;
Tcl_Obj **objv;
char versStr[2 * TCL_INTEGER_SPACE];
- char *str;
+ CONST char *str;
Tcl_Obj *pathPtr;
Tcl_DString ds;
{
Tcl_Obj *pathPtr;
+ if (tclPreInitScript != NULL) {
+ if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
+ return (TCL_ERROR);
+ };
+ }
+
/*
* For Macintosh applications the Init function may be contained in
* the application resources. If it exists we use it - otherwise we
Tcl_Interp *interp) /* Interpreter to source rc file into. */
{
Tcl_DString temp;
- char *fileName;
+ CONST char *fileName;
Tcl_Channel errChannel;
Handle h;
if (fileName != NULL) {
Tcl_Channel c;
- char *fullName;
+ CONST char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
fileName = Tcl_GetVar(interp, "tcl_rcRsrcName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
- c2pstr(fileName);
- h = GetNamedResource('TEXT', (StringPtr) fileName);
- p2cstr((StringPtr) fileName);
+ Str255 rezName;
+ Tcl_DString ds;
+ Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
+ rezName[0] = (unsigned) Tcl_DStringLength(&ds);
+ h = GetNamedResource('TEXT', rezName);
+ Tcl_DStringFree(&ds);
if (h != NULL) {
if (Tcl_MacEvalResource(interp, fileName, 0, NULL) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
#ifndef _TCLMACINT
#define _TCLMACINT
-#ifndef _TCL
-# include "tcl.h"
+#ifndef _TCLINT
+#include "tclInt.h"
#endif
-#ifndef _TCLMAC
-# include "tclMac.h"
+#ifndef _TCLPORT
+#include "tclPort.h"
#endif
#include <Events.h>
#include <Files.h>
-#pragma export on
-
/*
* Defines to control stack behavior.
*
#define TCL_MAC_STACK_THRESHOLD 16384
+#ifdef BUILD_tcl
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
/*
* This flag is passed to TclMacRegisterResourceFork
* by a file (usually a library) whose resource fork
*/
EXTERN char * TclMacGetFontEncoding _ANSI_ARGS_((int fontId));
-EXTERN int TclMacHaveThreads(void);
+EXTERN int TclMacHaveThreads _ANSI_ARGS_((void));
+EXTERN long TclpGetGMTOffset _ANSI_ARGS_((void));
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
-#include "tclPort.h"
-#include "tclPlatDecls.h"
#include "tclIntPlatDecls.h"
-#pragma export reset
-
#endif /* _TCLMACINT */
#include <Strings.h>
#include "tclMacInt.h"
+#if defined(TCL_REGISTER_LIBRARY) && defined(USE_TCL_STUBS)
+#error "Can't use TCL_REGISTER_LIBRARY and USE_TCL_STUBS at the same time!"
+/*
+ * Can't register a library with Tcl when using stubs in the current
+ * implementation, since Tcl_InitStubs hasn't been called yet
+ * when OpenLibraryResource is executing.
+ */
+#endif
+
/*
* These function are not currently defined in any header file. The
* only place they should be used is in the Initialization and
* the version string for Tcl.
*/
-#define RESOURCE_INCLUDED
+#define RC_INVOKED
#include "tcl.h"
#if (TCL_RELEASE_LEVEL == 0)
#if (TCL_RELEASE_LEVEL == 2)
# define MINOR_VERSION (TCL_MINOR_VERSION * 16) + TCL_RELEASE_SERIAL
+# define RELEASE_CODE 0x00
#else
# define MINOR_VERSION TCL_MINOR_VERSION * 16
+# define RELEASE_CODE TCL_RELEASE_SERIAL
#endif
resource 'vers' (1) {
TCL_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
+ RELEASE_LEVEL, RELEASE_CODE, verUS,
TCL_PATCH_LEVEL,
- TCL_PATCH_LEVEL ", by Ray Johnson & Jim Ingham © Scriptics Inc."
+ TCL_PATCH_LEVEL ", by Ray Johnson & Jim Ingham" "\n" "© 2001 Tcl Core Team"
};
resource 'vers' (2) {
TCL_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
+ RELEASE_LEVEL, RELEASE_CODE, verUS,
TCL_PATCH_LEVEL,
- "Tcl Library " TCL_PATCH_LEVEL " © 1996-1997 Sun Microsystems, 1998-1999 Scriptics Inc."
+ "Tcl Library " TCL_PATCH_LEVEL " © 1993-2001"
};
/*
type TCL_CREATOR as 'STR ';
resource TCL_CREATOR (0, purgeable) {
- "Tcl Library " TCL_PATCH_LEVEL " © 1996-1999"
+ "Tcl Library " TCL_PATCH_LEVEL " © 1993-2001"
};
/*
resource 'STR ' (-16397, purgeable) {
"Tcl Library\n\n"
"This is the core library needed to run Tool Command Language programs. "
- "To work properly, it should be placed in the ÔTool Command LanguageÕ folder "
+ "To work properly, it should be placed in the \8cTool Command Language¹ folder "
"within the Extensions folder."
};
-/*
- * The mechanisim below loads Tcl source into the resource fork of the
- * application. The example below creates a TEXT resource named
- * "Init" from the file "init.tcl". This allows applications to use
- * Tcl to define the behavior of the application without having to
- * require some predetermined file structure - all needed Tcl "files"
- * are located within the application. To source a file for the
- * resource fork the source command has been modified to support
- * sourcing from resources. In the below case "source -rsrc {Init}"
- * will load the TEXT resource named "Init".
- */
-
-#include "tclMacTclCode.r"
-
/*
* The following are icons for the shared library.
*/
Str255 name; /* This is actually variable sized. */
};
typedef struct CfrgItem CfrgItem;
+
+/*
+ * On MacOS, old shared libraries which contain many code fragments
+ * cannot, it seems, be loaded in one go. We need to look provide
+ * the name of a code fragment while we load. Since with the
+ * separation of the 'load' and 'findsymbol' be do not necessarily
+ * know a symbol name at load time, we have to store some further
+ * information in a structure like this so we can ensure we load
+ * properly in 'findsymbol' if the first attempts didn't work.
+ */
+typedef struct TclMacLoadInfo {
+ int loaded;
+ CFragConnectionID connID;
+ FSSpec fileSpec;
+} TclMacLoadInfo;
+
+static int TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo, Tcl_Obj *pathPtr,
+ CONST char *sym /* native */);
+
\f
/*
*----------------------------------------------------------------------
*
- * TclLoadFile --
+ * TclpDlopen --
*
* This procedure is called to carry out dynamic loading of binary
* code for the Macintosh. This implementation is based on the
*/
int
-TclpLoadFile(
- Tcl_Interp *interp, /* Used for error reporting. */
- char *fileName, /* Name of the file containing the desired
- * code. */
- char *sym1, char *sym2, /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr,
- Tcl_PackageInitProc **proc2Ptr,
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr) /* Filled with token for dynamically loaded
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
- CFragConnectionID connID;
- Ptr dummy;
OSErr err;
- CFragSymbolClass symClass;
FSSpec fileSpec;
- short fragFileRef, saveFileRef;
- Handle fragResource;
- UInt32 offset = 0;
- UInt32 length = kCFragGoesToEOF;
- char packageName[255];
- Str255 errName;
- Tcl_DString ds;
- char *native;
-
- /*
- * First thing we must do is infer the package name from the sym1
- * variable. This is kind of dumb since the caller actually knows
- * this value, it just doesn't give it to us.
- */
- strcpy(packageName, sym1);
- Tcl_UtfToLower(packageName);
- *(Tcl_UtfAtIndex(packageName, Tcl_NumUtfChars(packageName, -1) - 5)) = 0;
+ CONST char *native;
+ TclMacLoadInfo *loadInfo;
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ native = Tcl_FSGetNativePath(pathPtr);
err = FSpLocationFromPath(strlen(native), native, &fileSpec);
- Tcl_DStringFree(&ds);
if (err != noErr) {
Tcl_SetResult(interp, "could not locate shared library", TCL_STATIC);
return TCL_ERROR;
}
+ loadInfo = (TclMacLoadInfo *) ckalloc(sizeof(TclMacLoadInfo));
+ loadInfo->loaded = 0;
+ loadInfo->fileSpec = fileSpec;
+ loadInfo->connID = NULL;
+
+ if (TryToLoad(interp, loadInfo, pathPtr, NULL) != TCL_OK) {
+ ckfree((char*) loadInfo);
+ return TCL_ERROR;
+ }
+
+ *loadHandle = (Tcl_LoadHandle)loadInfo;
+ *unloadProcPtr = &TclpUnloadFile;
+ return TCL_OK;
+}
+\f
+/*
+ * See the comments about 'struct TclMacLoadInfo' above. This
+ * function ensures the appropriate library or symbol is
+ * loaded.
+ */
+static int
+TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo, Tcl_Obj *pathPtr,
+ CONST char *sym /* native */)
+{
+ OSErr err;
+ CFragConnectionID connID;
+ Ptr dummy;
+ short fragFileRef, saveFileRef;
+ Handle fragResource;
+ UInt32 offset = 0;
+ UInt32 length = kCFragGoesToEOF;
+ Str255 errName;
+ StringPtr fragName=NULL;
+
+ if (loadInfo->loaded == 1) {
+ return TCL_OK;
+ }
+
/*
* See if this fragment has a 'cfrg' resource. It will tell us where
* to look for the fragment in the file. If it doesn't exist we will
saveFileRef = CurResFile();
SetResLoad(false);
- fragFileRef = FSpOpenResFile(&fileSpec, fsRdPerm);
+ fragFileRef = FSpOpenResFile(&loadInfo->fileSpec, fsRdPerm);
SetResLoad(true);
if (fragFileRef != -1) {
- UseResFile(fragFileRef);
- fragResource = Get1Resource(kCFragResourceType, kCFragResourceID);
- HLock(fragResource);
- if (ResError() == noErr) {
- CfrgItem* srcItem;
- long itemCount, index;
- Ptr itemStart;
+ if (sym != NULL) {
+ UseResFile(fragFileRef);
+ fragResource = Get1Resource(kCFragResourceType, kCFragResourceID);
+ HLock(fragResource);
+ if (ResError() == noErr) {
+ CfrgItem* srcItem;
+ long itemCount, index;
+ Ptr itemStart;
- itemCount = (*(CfrgHeaderPtrHand)fragResource)->itemCount;
- itemStart = &(*(CfrgHeaderPtrHand)fragResource)->arrayStart;
- for (index = 0; index < itemCount;
- index++, itemStart += srcItem->itemSize) {
- srcItem = (CfrgItem*)itemStart;
- if (srcItem->archType != OUR_ARCH_TYPE) continue;
- if (!strncasecmp(packageName, (char *) srcItem->name + 1,
- srcItem->name[0])) {
- offset = srcItem->codeOffset;
- length = srcItem->codeLength;
+ itemCount = (*(CfrgHeaderPtrHand)fragResource)->itemCount;
+ itemStart = &(*(CfrgHeaderPtrHand)fragResource)->arrayStart;
+ for (index = 0; index < itemCount;
+ index++, itemStart += srcItem->itemSize) {
+ srcItem = (CfrgItem*)itemStart;
+ if (srcItem->archType != OUR_ARCH_TYPE) continue;
+ if (!strncasecmp(sym, (char *) srcItem->name + 1,
+ strlen(sym))) {
+ offset = srcItem->codeOffset;
+ length = srcItem->codeLength;
+ fragName=srcItem->name;
+ }
}
}
}
ReleaseResource(fragResource);
CloseResFile(fragFileRef);
UseResFile(saveFileRef);
+ if (sym == NULL) {
+ /* We just return */
+ return TCL_OK;
+ }
}
/*
- * Now we can attempt to load the fragement using the offset & length
+ * Now we can attempt to load the fragment using the offset & length
* obtained from the resource. We don't worry about the main entry point
* as we are going to search for specific entry points passed to us.
*/
- c2pstr(packageName);
- err = GetDiskFragment(&fileSpec, offset, length, (StringPtr) packageName,
+ err = GetDiskFragment(&loadInfo->fileSpec, offset, length, fragName,
kLoadCFrag, &connID, &dummy, errName);
+
if (err != fragNoErr) {
p2cstr(errName);
- Tcl_AppendResult(interp, "couldn't load file \"", fileName,
- "\": ", errName, (char *) NULL);
+ if(pathPtr) {
+ Tcl_AppendResult(interp, "couldn't load file \"",
+ Tcl_GetString(pathPtr),
+ "\": ", errName, (char *) NULL);
+ } else if(sym) {
+ Tcl_AppendResult(interp, "couldn't load library \"",
+ sym,
+ "\": ", errName, (char *) NULL);
+ }
return TCL_ERROR;
}
+
+ loadInfo->connID = connID;
+ loadInfo->loaded = 1;
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ Tcl_DString ds;
+ Tcl_PackageInitProc *proc=NULL;
+ TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;
+ Str255 symbolName;
+ CFragSymbolClass symClass;
+ OSErr err;
+
+ if (loadInfo->loaded == 0) {
+ int res;
+ /*
+ * First thing we must do is infer the package name from the
+ * sym variable. We do this by removing the '_Init'.
+ */
+ Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
+ Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 5);
+ res = TryToLoad(interp, loadInfo, NULL, Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+ if (res != TCL_OK) {
+ return NULL;
+ }
+ }
- c2pstr(sym1);
- err = FindSymbol(connID, (StringPtr) sym1, (Ptr *) proc1Ptr, &symClass);
- p2cstr((StringPtr) sym1);
+ Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
+ strcpy((char *) symbolName + 1, Tcl_DStringValue(&ds));
+ symbolName[0] = (unsigned) Tcl_DStringLength(&ds);
+ err = FindSymbol(loadInfo->connID, symbolName, (Ptr *) &proc, &symClass);
+ Tcl_DStringFree(&ds);
if (err != fragNoErr || symClass == kDataCFragSymbol) {
Tcl_SetResult(interp,
"could not find Initialization routine in library",
TCL_STATIC);
- return TCL_ERROR;
- }
-
- c2pstr(sym2);
- err = FindSymbol(connID, (StringPtr) sym2, (Ptr *) proc2Ptr, &symClass);
- p2cstr((StringPtr) sym2);
- if (err != fragNoErr || symClass == kDataCFragSymbol) {
- *proc2Ptr = NULL;
+ return NULL;
}
-
- *clientDataPtr = (ClientData) connID;
-
- return TCL_OK;
+ return proc;
}
\f
/*
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
+ TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;
+ if (loadInfo->loaded) {
+ CloseConnection((CFragConnectionID*) &(loadInfo->connID));
+ }
+ ckfree((char*)loadInfo);
}
\f
/*
int
TclGuessPackageName(
- char *fileName, /* Name of file containing package (already
+ CONST char *fileName, /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr) /* Initialized empty dstring. Append
* package name to this if possible. */
+++ /dev/null
-/*
- * tclMacMSLPrefix.h --
- *
- * A wrapper for the MSL ansi_prefix.mac.h file. This just turns export on
- * after including the MSL prefix file, so we can export symbols from the MSL
- * and through the Tcl shared libraries
- *
- *
- * Copyright (c) 1997 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id$
- */
-
-#include <ansi_prefix.mac.h>
-/*
- * "export" is a MetroWerks specific pragma. It flags the linker that
- * any symbols that are defined when this pragma is on will be exported
- * to shared libraries that link with this library.
- */
-
-#pragma export on
#endif
#endif
-#if (defined(THINK_C) || defined(__MWERKS__))
+#if (defined(THINK_C))
#pragma export on
double hypotd(double x, double y);
#define hypot hypotd
* system event queue unless we call WaitNextEvent.
*/
- GetGlobalMouse(¤tMouse);
+ GetGlobalMouseTcl(¤tMouse);
if ((notifier.eventProcPtr != NULL) &&
!EqualPt(currentMouse, notifier.lastMousePosition)) {
notifier.lastMousePosition = currentMouse;
*/
while (needsUpdate || (GetEvQHdr()->qHead != NULL)) {
- GetGlobalMouse(¤tMouse);
+ GetGlobalMouseTcl(¤tMouse);
SetRect(&mouseRect, currentMouse.h, currentMouse.v,
currentMouse.h + 1, currentMouse.v + 1);
RectRgn(notifier.utilityRgn, &mouseRect);
* Compute when the timer should fire.
*/
- TclpGetTime(¬ifier.timer);
+ Tcl_GetTime(¬ifier.timer);
notifier.timer.sec += timePtr->sec;
notifier.timer.usec += timePtr->usec;
if (notifier.timer.usec >= 1000000) {
* the current mouse position.
*/
- GetGlobalMouse(¤tMouse);
+ GetGlobalMouseTcl(¤tMouse);
SetRect(&mouseRect, currentMouse.h, currentMouse.v,
currentMouse.h + 1, currentMouse.v + 1);
RectRgn(notifier.utilityRgn, &mouseRect);
static pascal OSErr TclOSAActiveProc _ANSI_ARGS_((long refCon));
static int TclOSACompileCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
- char **argv));
+ CONST char **argv));
static int tclOSADecompileCmd _ANSI_ARGS_((Tcl_Interp * Interp,
tclOSAComponent *OSAComponent, int argc,
- char **argv));
+ CONST char **argv));
static int tclOSADeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
- char **argv));
+ CONST char **argv));
static int tclOSAExecuteCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
- char **argv));
+ CONST char **argv));
static int tclOSAInfoCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
- char **argv));
+ CONST char **argv));
static int tclOSALoadCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
- char **argv));
+ CONST char **argv));
static int tclOSARunCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
- char **argv));
+ CONST char **argv));
static int tclOSAStoreCmd _ANSI_ARGS_((Tcl_Interp *interp,
- tclOSAComponent *OSAComponent, int argc, char
- **argv));
+ tclOSAComponent *OSAComponent, int argc,
+ CONST char **argv));
static void GetRawDataFromDescriptor _ANSI_ARGS_((AEDesc *theDesc,
Ptr destPtr, Size destMaxSize, Size *actSize));
static OSErr GetCStringFromDescriptor _ANSI_ARGS_((
AEDesc *sourceDesc, char *resultStr,
Size resultMaxSize,Size *resultSize));
static int Tcl_OSAComponentCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static void getSortedHashKeys _ANSI_ARGS_((Tcl_HashTable *theTable,
- char *pattern, Tcl_DString *theResult));
+ CONST char *pattern, Tcl_DString *theResult));
static int ASCIICompareProc _ANSI_ARGS_((const void *first,
const void *second));
static int Tcl_OSACmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static void tclOSAClose _ANSI_ARGS_((ClientData clientData));
-static void tclOSACloseAll _ANSI_ARGS_((ClientData clientData));
+/*static void tclOSACloseAll _ANSI_ARGS_((ClientData clientData));*/
static tclOSAComponent *tclOSAMakeNewComponent _ANSI_ARGS_((Tcl_Interp *interp,
char *cmdName, char *languageName,
OSType scriptSubtype, long componentFlags));
-static int prepareScriptData _ANSI_ARGS_((int argc, char **argv,
+static int prepareScriptData _ANSI_ARGS_((int argc, CONST char **argv,
Tcl_DString *scrptData ,AEDesc *scrptDesc));
static void tclOSAResultFromID _ANSI_ARGS_((Tcl_Interp *interp,
ComponentInstance theComponent, OSAID resultID));
static void tclOSAASError _ANSI_ARGS_((Tcl_Interp * interp,
ComponentInstance theComponent, char *scriptSource));
static int tclOSAGetContextID _ANSI_ARGS_((tclOSAComponent *theComponent,
- char *contextName, OSAID *theContext));
+ CONST char *contextName, OSAID *theContext));
static void tclOSAAddContext _ANSI_ARGS_((tclOSAComponent *theComponent,
char *contextName, const OSAID theContext));
static int tclOSAMakeContext _ANSI_ARGS_((tclOSAComponent *theComponent,
- char *contextName, OSAID *theContext));
+ CONST char *contextName, OSAID *theContext));
static int tclOSADeleteContext _ANSI_ARGS_((tclOSAComponent *theComponent,
- char *contextName));
+ CONST char *contextName));
static int tclOSALoad _ANSI_ARGS_((Tcl_Interp *interp,
- tclOSAComponent *theComponent, char *resourceName,
- int resourceNumber, char *fileName,OSAID *resultID));
+ tclOSAComponent *theComponent, CONST char *resourceName,
+ int resourceNumber, CONST char *fileName,OSAID *resultID));
static int tclOSAStore _ANSI_ARGS_((Tcl_Interp *interp,
- tclOSAComponent *theComponent, char *resourceName,
- int resourceNumber, char *fileName,char *scriptName));
+ tclOSAComponent *theComponent, CONST char *resourceName,
+ int resourceNumber, CONST char *scriptName, CONST char *fileName));
static int tclOSAAddScript _ANSI_ARGS_((tclOSAComponent *theComponent,
char *scriptName, long modeFlags, OSAID scriptID));
static int tclOSAGetScriptID _ANSI_ARGS_((tclOSAComponent *theComponent,
- char *scriptName, OSAID *scriptID));
+ CONST char *scriptName, OSAID *scriptID));
static tclOSAScript * tclOSAGetScript _ANSI_ARGS_((tclOSAComponent *theComponent,
- char *scriptName));
+ CONST char *scriptName));
static int tclOSADeleteScript _ANSI_ARGS_((tclOSAComponent *theComponent,
- char *scriptName,char *errMsg));
+ CONST char *scriptName,char *errMsg));
/*
* "export" is a MetroWerks specific pragma. It flags the linker that
ClientData clientData,
Tcl_Interp *interp,
int argc,
- char **argv)
+ CONST char **argv)
{
static unsigned short componentCmdIndex = 0;
char autoName[32];
ClientData clientData,
Tcl_Interp *interp,
int argc,
- char **argv)
+ CONST char **argv)
{
int length;
char c;
Tcl_Interp *interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
int tclError = TCL_OK;
int augment = 1;
}
makeContext = 1;
} else if (c == 'n' && strcmp(argv[0] + 1, "name") == 0) {
- resultName = argv[1];
+ strncpy(autoName, argv[1], 15);
+ autoName[15] = '\0';
+ resultName = autoName;
} else if (c == 'p' && strcmp(argv[0] + 1,"parent") == 0) {
/*
* Since this implies we are compiling into a context,
makeNewContext = true;
} else if (tclOSAGetContextID(OSAComponent,
resultName, &resultID) == TCL_OK) {
- makeNewContext = false;
} else {
makeNewContext = true;
- resultID = kOSANullScript;
}
/*
if (augment && !makeNewContext) {
modeFlags |= kOSAModeAugmentContext;
}
+ } else if (resultName == NULL) {
+ resultName = autoName; /* Auto name the script */
}
/*
Tcl_DStringValue(&scrptData));
tclError = TCL_ERROR;
} else if (osaErr != noErr) {
- sprintf(buffer, "Error #%-6d compiling script", osaErr);
+ sprintf(buffer, "Error #%-6ld compiling script", osaErr);
Tcl_AppendResult(interp, buffer, (char *) NULL);
tclError = TCL_ERROR;
}
Tcl_Interp * interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
AEDesc resultingSourceData = { typeChar, NULL };
OSAID scriptID;
Tcl_Interp *interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
char c,*errMsg = NULL;
int length;
Tcl_Interp *interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
int tclError = TCL_OK, resID = 128;
char c,buffer[32],
Tcl_DStringValue(&scrptData));
tclError = TCL_ERROR;
} else if (osaErr != noErr) {
- sprintf(buffer, "Error #%-6d compiling script", osaErr);
+ sprintf(buffer, "Error #%-6ld compiling script", osaErr);
Tcl_AppendResult(interp, buffer, (char *) NULL);
tclError = TCL_ERROR;
} else {
Tcl_Interp *interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
char c;
int length;
Tcl_Interp *interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
int tclError = TCL_OK, resID = 128;
char c, autoName[24],
- *contextName = NULL, *scriptName = NULL, *resName = NULL;
+ *contextName = NULL, *scriptName = NULL;
+ CONST char *resName = NULL;
Boolean makeNewContext = false, makeContext = false;
AEDesc scrptDesc = { typeNull, NULL };
long modeFlags = kOSAModeCanInteract;
Tcl_Interp *interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
int tclError = TCL_OK,
resID = 128;
parentID = kOSANullScript;
OSAError osaErr = noErr;
OSErr sysErr = noErr;
- char *componentName = argv[0];
+ CONST char *componentName = argv[0];
OSAID scriptID;
if (argc == 2) {
Tcl_Interp *interp,
tclOSAComponent *OSAComponent,
int argc,
- char **argv)
+ CONST char **argv)
{
int tclError = TCL_OK, resID = 128;
- char c, *contextName = NULL, *scriptName = NULL, *resName = NULL;
+ char c, *contextName = NULL, *scriptName = NULL;
+ CONST char *resName = NULL;
Boolean makeNewContext = false, makeContext = false;
AEDesc scrptDesc = { typeNull, NULL };
long modeFlags = kOSAModeCanInteract;
Tcl_InitHashTable(&newComponent->scriptTable, TCL_STRING_KEYS);
if (tclOSAMakeContext(newComponent, global, &globalContext) != TCL_OK) {
- sprintf(buffer, "%-6.6d", globalContext);
+ sprintf(buffer, "%-6.6ld", globalContext);
Tcl_AppendResult(interp, "Error ", buffer, " making ", global,
" context.", (char *) NULL);
goto CleanUp;
/* TODO -- clean up here... */
}
- myActiveProcUPP = NewOSAActiveProc(TclOSAActiveProc);
+ myActiveProcUPP = NewOSAActiveUPP(TclOSAActiveProc);
OSASetActiveProc(newComponent->theComponent,
myActiveProcUPP, (long) newComponent);
return newComponent;
static int
tclOSAGetContextID(
tclOSAComponent *theComponent,
- char *contextName,
+ CONST char *contextName,
OSAID *theContext)
{
Tcl_HashEntry *hashEntry;
static int
tclOSADeleteContext(
tclOSAComponent *theComponent,
- char *contextName)
+ CONST char *contextName)
{
Tcl_HashEntry *hashEntry;
tclOSAContext *contextStruct;
static int
tclOSAMakeContext(
tclOSAComponent *theComponent,
- char *contextName,
+ CONST char *contextName,
OSAID *theContext)
{
AEDesc contextNameDesc = {typeNull, NULL};
AEDisposeDesc(&contextNameDesc);
if (osaErr == noErr) {
- tclOSAAddContext(theComponent, contextName, *theContext);
+ char name[24];
+ strncpy(name, contextName, 23);
+ name[23] = '\0';
+ tclOSAAddContext(theComponent, name, *theContext);
} else {
*theContext = (OSAID) osaErr;
return TCL_ERROR;
tclOSAStore(
Tcl_Interp *interp,
tclOSAComponent *theComponent,
- char *resourceName,
+ CONST char *resourceName,
int resourceNumber,
- char *scriptName,
- char *fileName)
+ CONST char *scriptName,
+ CONST char *fileName)
{
Handle resHandle;
Str255 rezName;
short saveRef, fileRef = -1;
char idStr[16 + TCL_INTEGER_SPACE];
FSSpec fileSpec;
- Tcl_DString buffer;
- char *nativeName;
+ Tcl_DString ds, buffer;
+ CONST char *nativeName;
OSErr myErr = noErr;
OSAID scriptID;
Size scriptSize;
if (fileName != NULL) {
OSErr err;
- Tcl_DStringInit(&buffer);
- nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (nativeName == NULL) {
+ if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
return TCL_ERROR;
}
+ nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
+ Tcl_DStringLength(&buffer), &ds);
err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec);
+ Tcl_DStringFree(&ds);
Tcl_DStringFree(&buffer);
if ((err != noErr) && (err != fnfErr)) {
Tcl_AppendResult(interp,
return TCL_ERROR;
}
- FSpCreateResFileCompat(&fileSpec,
+ FSpCreateResFileCompatTcl(&fileSpec,
'WiSH', 'osas', smSystemScript);
myErr = ResError();
goto rezEvalCleanUp;
}
- fileRef = FSpOpenResFileCompat(&fileSpec, fsRdWrPerm);
+ fileRef = FSpOpenResFileCompatTcl(&fileSpec, fsRdWrPerm);
if (fileRef == -1) {
Tcl_AppendResult(interp, "Error reading the file: \"",
fileName, "\".", NULL);
tclOSALoad(
Tcl_Interp *interp,
tclOSAComponent *theComponent,
- char *resourceName,
+ CONST char *resourceName,
int resourceNumber,
- char *fileName,
+ CONST char *fileName,
OSAID *resultID)
{
Handle sourceData;
short saveRef, fileRef = -1;
char idStr[16 + TCL_INTEGER_SPACE];
FSSpec fileSpec;
- Tcl_DString buffer;
- char *nativeName;
+ Tcl_DString ds, buffer;
+ CONST char *nativeName;
saveRef = CurResFile();
if (fileName != NULL) {
OSErr err;
- Tcl_DStringInit(&buffer);
- nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (nativeName == NULL) {
+ if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
return TCL_ERROR;
}
+ nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
+ Tcl_DStringLength(&buffer), &ds);
err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec);
+ Tcl_DStringFree(&ds);
Tcl_DStringFree(&buffer);
if (err != noErr) {
Tcl_AppendResult(interp, "Error finding the file: \"",
return TCL_ERROR;
}
- fileRef = FSpOpenResFileCompat(&fileSpec, fsRdPerm);
+ fileRef = FSpOpenResFileCompatTcl(&fileSpec, fsRdPerm);
if (fileRef == -1) {
Tcl_AppendResult(interp, "Error reading the file: \"",
fileName, "\".", NULL);
static int
tclOSAGetScriptID(
tclOSAComponent *theComponent,
- char *scriptName,
+ CONST char *scriptName,
OSAID *scriptID)
{
tclOSAScript *theScript;
static tclOSAScript *
tclOSAGetScript(
tclOSAComponent *theComponent,
- char *scriptName)
+ CONST char *scriptName)
{
Tcl_HashEntry *hashEntry;
static int
tclOSADeleteScript(
tclOSAComponent *theComponent,
- char *scriptName,
+ CONST char *scriptName,
char *errMsg)
{
Tcl_HashEntry *hashEntry;
tclOSAComponent *theComponent = (tclOSAComponent *) refCon;
Tcl_DoOneEvent(TCL_DONT_WAIT);
- CallOSAActiveProc(theComponent->defActiveProc, theComponent->defRefCon);
+ InvokeOSAActiveUPP(theComponent->defRefCon, theComponent->defActiveProc);
return noErr;
}
static void
getSortedHashKeys(
Tcl_HashTable *theTable,
- char *pattern,
+ CONST char *pattern,
Tcl_DString *theResult)
{
Tcl_HashSearch search;
static int
prepareScriptData(
int argc,
- char **argv,
+ CONST char **argv,
Tcl_DString *scrptData,
AEDesc *scrptDesc)
{
+++ /dev/null
-Tclapplescript_Init
*/
#define SCRIPT_MAJOR_VERSION 1 /* Major number */
-#define SCRIPT_MINOR_VERSION 0 /* Minor number */
-#define SCRIPT_RELEASE_SERIAL 2 /* Really minor number! */
-#define RELEASE_LEVEL alpha /* alpha, beta, or final */
-#define SCRIPT_VERSION "1.0"
-#define SCRIPT_PATCH_LEVEL "1.0a2"
-#define FINAL 0 /* Change to 1 if final version. */
+#define SCRIPT_MINOR_VERSION 1 /* Minor number */
+#define SCRIPT_RELEASE_SERIAL 0 /* Really minor number! */
+#define RELEASE_LEVEL final /* alpha, beta, or final */
+#define SCRIPT_VERSION "1.1"
+#define SCRIPT_PATCH_LEVEL "1.1.0"
+#define FINAL 1 /* Change to 1 if final version. */
#if FINAL
# define MINOR_VERSION (SCRIPT_MINOR_VERSION * 16) + SCRIPT_RELEASE_SERIAL
+# define RELEASE_CODE 0x00
#else
# define MINOR_VERSION SCRIPT_MINOR_VERSION * 16
+# define RELEASE_CODE SCRIPT_RELEASE_SERIAL
#endif
#define RELEASE_CODE 0x00
resource 'vers' (1) {
SCRIPT_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
+ RELEASE_LEVEL, RELEASE_CODE, verUS,
SCRIPT_PATCH_LEVEL,
- SCRIPT_PATCH_LEVEL ", by Jim Ingham © Cygnus Solutions"
+ SCRIPT_PATCH_LEVEL ", by Jim Ingham © Cygnus Solutions" "\n" "© 2001 Tcl Core Team"
};
resource 'vers' (2) {
SCRIPT_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
+ RELEASE_LEVEL, RELEASE_CODE, verUS,
SCRIPT_PATCH_LEVEL,
- "Tclapplescript " SCRIPT_PATCH_LEVEL " © 1996-1999"
+ "Tclapplescript " SCRIPT_PATCH_LEVEL " © 1996-2001"
};
/*
"TclAppleScript Library\n\n"
"This library provides the ability to run AppleScript "
" commands from Tcl/Tk programs. To work properly, it "
- "should be placed in the ÔTool Command LanguageÕ folder "
+ "should be placed in the \8cTool Command Language¹ folder "
"within the Extensions folder."
};
data 'TEXT' (4000,"pkgIndex",purgeable, preload) {
"# Tcl package index file, version 1.0\n"
- "package ifneeded Tclapplescript 1.0 [list tclPkgSetup $dir Tclapplescript 1.0 {{Tclapplescript"
+ "package ifneeded Tclapplescript 1.1 [list tclPkgSetup $dir Tclapplescript 1.1 {{Tclapplescript"
".shlb load AppleScript}}]\n"
};
/*
* tclMacPanic.c --
*
- * Source code for the "panic" library procedure used in "Simple Shell";
- * other Mac applications will probably override this with a more robust
- * application-specific panic procedure.
+ * Source code for the "Tcl_Panic" library procedure used in "Simple
+ * Shell"; other Mac applications will probably call Tcl_SetPanicProc
+ * to set a more robust application-specific panic procedure.
*
* Copyright (c) 1993-1994 Lockheed Missle & Space Company, AI Center
* Copyright (c) 1995-1996 Sun Microsystems, Inc.
#include <Events.h>
#include <Controls.h>
+#include <ControlDefinitions.h>
#include <Windows.h>
#include <TextEdit.h>
#include <Fonts.h>
#include <stdlib.h>
#include "tclInt.h"
+#include "tclMacInt.h"
/*
* constants for panic dialog
#define ENTERCODE (0x03)
#define RETURNCODE (0x0D)
-/*
- * The panicProc variable contains a pointer to an application
- * specific panic procedure.
- */
-
-void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL;
\f
/*
*----------------------------------------------------------------------
*
- * Tcl_SetPanicProc --
+ * TclpPanic --
*
- * Replace the default panic behavior with the specified functiion.
+ * Displays panic info, then aborts
*
* Results:
* None.
*
* Side effects:
- * Sets the panicProc variable.
+ * The process dies, entering the debugger if possible.
*
*----------------------------------------------------------------------
*/
+ /* VARARGS ARGSUSED */
void
-Tcl_SetPanicProc(proc)
- void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format));
-{
- panicProc = proc;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * MacPanic --
- *
- * Displays panic info..
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets the panicProc variable.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-MacPanic(
- char *msg) /* Text to show in panic dialog. */
+TclpPanic TCL_VARARGS_DEF(CONST char *, format)
{
+ va_list varg;
+ char msg[256];
WindowRef macWinPtr, foundWinPtr;
Rect macRect;
Rect buttonRect = PANIC_BUTTON_RECT;
Handle stopIconHandle;
int part;
Boolean done = false;
-
+
+ va_start(varg, format);
+ vsprintf(msg, format, varg);
+ va_end(varg);
/*
* Put up an alert without using the Resource Manager (there may
part = FindControl(event.where, macWinPtr,
&okButtonHandle);
- if ((inButton == part) &&
+ if ((kControlButtonPart == part) &&
(TrackControl(okButtonHandle,
event.where, NULL))) {
done = true;
if (stopIconHandle != NULL) {
PlotIcon(&iconRect, stopIconHandle);
}
- TextBox(msg, strlen(msg), &textRect, teFlushDefault);
+ TETextBox(msg, strlen(msg), &textRect, teFlushDefault);
DrawControls(macWinPtr);
EndUpdate(macWinPtr);
}
#endif
}
\f
-/*
- *----------------------------------------------------------------------
- *
- * panic --
- *
- * Print an error message and kill the process.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The process dies, entering the debugger if possible.
- *
- *----------------------------------------------------------------------
- */
-
-#pragma ignore_oldstyle on
-void
-panic(char * format, ...)
-{
- va_list varg;
- char errorText[256];
-
- if (panicProc != NULL) {
- va_start(varg, format);
-
- (void) (*panicProc)(format, varg);
-
- va_end(varg);
- } else {
- va_start(varg, format);
-
- vsprintf(errorText, format, varg);
-
- va_end(varg);
-
- MacPanic(errorText);
- }
-
-}
-#pragma ignore_oldstyle reset
*/
#include "tclErrno.h"
+
+#ifndef EOVERFLOW
+# ifdef EFBIG
+# define EOVERFLOW EFBIG /* The object couldn't fit in the datatype */
+# else /* !EFBIG */
+# define EOVERFLOW EINVAL /* Better than nothing! */
+# endif /* EFBIG */
+#endif /* !EOVERFLOW */
+
#include <float.h>
#ifdef THINK_C
# include <time.h>
# include <unistd.h>
# include <utime.h>
-
-/*
- * The following definitions are usually found if fcntl.h.
- * However, MetroWerks has screwed that file up a couple of times
- * and all we need are the defines.
- */
-
-# define O_RDWR 0x0 /* open the file in read/write mode */
-# define O_RDONLY 0x1 /* open the file in read only mode */
-# define O_WRONLY 0x2 /* open the file in write only mode */
-# define O_APPEND 0x0100 /* open the file in append mode */
-# define O_CREAT 0x0200 /* create the file if it doesn't exist */
-# define O_EXCL 0x0400 /* if the file exists don't create it again */
-# define O_TRUNC 0x0800 /* truncate the file after opening it */
-
-/*
- * MetroWerks stat.h file is rather weak. The defines
- * after the include are needed to fill in the missing
- * defines.
- */
-
+# include <fcntl.h>
# include <stat.h>
-# ifndef S_IFIFO
-# define S_IFIFO 0x0100
-# endif
-# ifndef S_IFBLK
-# define S_IFBLK 0x0600
-# endif
-# ifndef S_ISLNK
-# define S_ISLNK(m) (((m)&(S_IFMT)) == (S_IFLNK))
-# endif
-# ifndef S_ISSOCK
-# define S_ISSOCK(m) (((m)&(S_IFMT)) == (S_IFSOCK))
-# endif
-# ifndef S_IRWXU
-# define S_IRWXU 00007 /* read, write, execute: owner */
-# define S_IRUSR 00004 /* read permission: owner */
-# define S_IWUSR 00002 /* write permission: owner */
-# define S_IXUSR 00001 /* execute permission: owner */
-# define S_IRWXG 00007 /* read, write, execute: group */
-# define S_IRGRP 00004 /* read permission: group */
-# define S_IWGRP 00002 /* write permission: group */
-# define S_IXGRP 00001 /* execute permission: group */
-# define S_IRWXO 00007 /* read, write, execute: other */
-# define S_IROTH 00004 /* read permission: other */
-# define S_IWOTH 00002 /* write permission: other */
-# define S_IXOTH 00001 /* execute permission: other */
-# endif
+#if __MSL__ < 0x6000
# define isatty(arg) 1
/*
# define X_OK 0x01 /* test for execute or search permission */
# define W_OK 0x02 /* test for write permission */
# define R_OK 0x04 /* test for read permission */
+#endif
#endif /* __MWERKS__ */
#define WTERMSIG(status) (1)
#define WSTOPSIG(status) (1)
+#ifdef BUILD_tcl
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
/*
* Make sure that MAXPATHLEN is defined.
*/
#define TCL_SHLIB_EXT ".shlb"
/*
- * The following define is bogus and needs to be fixed. It claims that
+ * The following define is defined as a workaround on the mac. It claims that
* struct tm has the timezone string in it, which is not true. However,
* the code that works around this fact does not compile on the Mac, since
* it relies on the fact that time.h has a "timezone" variable, which the
* Metrowerks time.h does not have...
*
- * The Mac timezone stuff never worked (clock format 0 -format %Z returns "Z")
- * so this just keeps the status quo. The real answer is to not use the
- * MSL strftime, and provide the needed compat functions...
+ * The Mac timezone stuff is implemented via the TclpGetTZName() routine in
+ * tclMacTime.c
*
*/
#define HAVE_TM_ZONE
+
+/*
+ * If we're using the Metrowerks MSL, we need to convert time_t values from
+ * the mac epoch to the msl epoch (== unix epoch) by adding the offset from
+ * <time.mac.h> to mac time_t values, as MSL is using its epoch for file
+ * access routines such as stat or utime
+ */
+
+#ifdef __MSL__
+#include <time.mac.h>
+#ifdef _mac_msl_epoch_offset_
+#define tcl_mac_epoch_offset _mac_msl_epoch_offset_
+#define TCL_MAC_USE_MSL_EPOCH /* flag for TclDate.c */
+#else
+#define tcl_mac_epoch_offset 0L
+#endif
+#else
+#define tcl_mac_epoch_offset 0L
+#endif
+
/*
* The following macros have trivial definitions, allowing generic code to
* address platform-specific issues.
*/
-#define TclpAsyncMark(async)
#define TclpGetPid(pid) ((unsigned long) (pid))
#define TclSetSystemEnv(a,b)
#define tzset()
-/*
- * The following defines replace the Macintosh version of the POSIX
- * functions "stat" and "access". The various compilier vendors
- * don't implement this function well nor consistantly.
- */
-/* int TclpStat(const char *path, struct stat *bufPtr); */
-int TclpLstat(const char *path, struct stat *bufPtr);
-
char *TclpFindExecutable(const char *argv0);
int TclpFindVariable(CONST char *name, int *lengthPtr);
#endif /* TCL_THREADS */
typedef pascal void (*ExitToShellProcPtr)(void);
-#include "tclMac.h"
-#include "tclMacInt.h"
-/* #include "tclPlatDecls.h"
- #include "tclIntPlatDecls.h" */
+
+#include "tclMac.h" // contains #include "tclPlatDecls.h"
+#include "tclIntPlatDecls.h"
+
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _MACPORT */
(This file must be converted with BinHex 4.0)
-:"h4ME#jcC@%!39"36'&eFh3J!*!$U[S!!C82!846G(9QCNPd)#KM+6%j16FY-6N
-j1#""E'&NC'PZ)&0jFh4PEA-X)%PZBbiX)'KdG(!k,bphN!-ZB@aKC'4TER0jFbj
-MEfd[8h4eCQC*G#m0#KS!"4!!!+Vk!*!$FJ!"!*!$FVZT$D@P8Q9cCA*fC@5PT3#
-PN!3"!!!c!%#d(A&cYA@&T`#3$318HJ#3!mN!#QN8!!#U-3!&G'0X!!"plJ"p!"!
-"f3(!!q!!N!-"!`Irq2r``d!!!)!!N!HPN!3"!!"!!!#dSEb`YA@&QJ#3!h)!!"l
-l!*!$FJ!3p(`!!Gq)!!!GcJ#3"!m!3Np"Ae4ME&0SC@aXFbl2J!!!Pla069"b3eG
-*43%!N!q!!*!(3X(8l2p5hM-$&C9ribC2'j,ULBN*qKDqd#'1YLX&QfqFP)&&aU1
-`bJbB$#pqB6Z,dNYIZ&M+&rKa+M(Z[NphH%[fj#J529$lZ82SQ*hD8*h%!aT3kpS
-j5-Pq*b&LiZFM2AVQ%85qik!QZSAd%"0B!Da(*4!lBQmadjIRR0MNc-@1a43-Bf0
-R#rR$[F$ZN!"e,*iqp[I`UMble)lKD5AN@LCXcI0b*b[8D9)cdE@DN9TKdKS#H4!
-[(66X3D59CGDBmrE6dDq0,`"*'d%'(3i$!r1V#+&JU5P&C8PrXq"T`8bBjjGe%8L
-kKl'aa')@MQlj9Cp))PZCM)b,EX&cKJYH-d%eScP@)MhmM40bq6@6Q3"SIB%0I8k
-`dKmMbl&5)PeQqE(3$"!3UBJ`"NhF!+[re)Tq96+qLH'"LmG*m6BT-XYaY!f-k9q
-qRkLD+K4N-S$%U!,XBEKZPSjd4#EFV4q0`-EB,3[fp-&BTX`8)Jb$6`'4X(6j#BD
-0'J2@B`+3!)$4Y9cD3em!iVf*@&$,#kE)Kc-hRK)k,$@l(8'[leU`i"UP2$Gp6FN
-fEr9iIKV[Yhbl)@,8H$kM(&@ZqTQ$##J3rZ"9[U$b4qKZH[N,9ZldAqp#X*k"HL)
-QE#2+ZRDr'VG8[S&%dX62Gc4!XJVfEU@0'3[9+9RRfDYNhApb&[UXDc2b+64)-1V
-ZY1-amDKqY,aYC-f"6YQU4S#)fdBP(U#2EdKRD1K"XM9V%bS$*`*2$%GfA[D*&QH
-#8#MCNkK",CPC@1JrI"FC"IIj,(H[9D"mJlb)p3Yr(1NJ39AiVHq![K+Rlem1F(Q
-1m+1LKR+de+d+8aL9j$q[e'Gq4&meFp2[+kS)D8i[)&8jR69YVLrZ-*`!,5")kdp
-Dir1QSi6,h#H"1@5hIe9L)BLRaGbX-+ahh0m4qXrCdV8A3,@5ICdT`U,`,bNLGEb
-SeF`UY-624'H4-)dU-cVPb$+IlYABlkF[!#mj!de3MZVPDPNjja,5+qcR1J-ZS&&
-P"a'@1rp58h2VKkfEh9T8+q`4(hb`qH``[c0F,j+&FM6)2AcRad9PkrhNYKMX*da
-A5hB6p&3+(%8S5Aq9YJ@MhPpP`8p&iF!I3)UCR$ei(*4[U1&YcpU60)'2GN4cqLS
-Yfa6"'h0P0Dd@TmPY@$Y0"MFVY,0F39'T6UQ%['428dZC2`MSr'k6aKZ6d#3(GDQ
-UScLm!)K`SK9-2[$jiJADf3"VrXe"iaa+5TrMmNa)H6X,iZf8@4A8S$mSbF#*df&
-FGK*fehqPEC!!q@IaSlrMlb-i-VX8H%mM-V#05-Ga@G!45#ISlkhEHpeF&S+"pkD
-lqf!E,40,$'a@)0V&R4Rci5Mi,$+[-&G3"ZAPdY)-6#96EVV`mHPd)%I'H@c+,8M
-hU+CU[%8dL#AZUZ*c!'(kd2cqXPcjXB$XD(aJa%TZ5Hd([h[mb`%l1D,NiY5Ac-,
-Pj&EBhPhHRSj6"Q0$jaf0$F,e,$K1m!a6qrk@UDc'ZlXaTmD4Y!eQD"q(AVq'%0)
-kkRkX)ZC8$CXpX[,EEAF"LBTe'AR+leqpj6*-SZ'-Fd+Fb!IK%HKY+Se!jNde6R8
-lQ,M5)(TEBkIc&h4ekhTrS`%V3*0S&qd"EL4M15EPimTP90l'fi$60)M9jB5TC,i
-FL(FcZ&X#&S$eJQIVJMc(Ga*c`Ep+$SQCG0[1309C9Z'1Yfa-LJ1&K([rq6XJ+AL
--lI)NeA!G,b19Rib6T)DD&Ea[TJc&#RBAGHL8ibITA@$P+-Ii1XXM,j+V"VZJAc,
-[!+9(HcYFGJ(aH'T%F9'MM)lTKA`&FiUE0m6kE$01%8#KcaB2(e$S*cFi+mT`-`L
-3!%GACdJ%ic@EJUH&ZZNBTX)6+BcMf'BHUdA+$LNGCM+f%ZRYNA1!j5`DL`$mh1[
-pA#6c$I*CiP3BZBI+h`%Mlj3L2G%65RBS@6KBc6D$$9LBD0#Ppa%`HC6FAV-J,e!
-G$hIP-DP#cY+f'd,BR6f@@0*%1c'r+kra`cE&Mq`$D2mq4'EEC@$G!,)Z%IJ(QHr
-A'a@0QmFqS6,qKSBjZ5e$I#$P@[dE1*2F@NAGhaJ@m3VPKS+DZbfZI4Jk-q15[AU
-1fQ5LVdc,ed"Z+`PR!9c9f"E#B-[Vp8bZ)A'@82Zh'ffKRG5kJV8f2R'25)QEkhI
-Bm,j64@Xe&C-lVL9CGNhc$9qXScZFF)m$"S9"C9c1K8TX)bC!h#$5c80(8ALBakU
-SbViMhll3JpHCr$pqa&l&2YZ8M'hVHbr8k&%Nl%K1Jq0)h"`q#I+3!#-(GHYjH#1
-`&13'BDl!6(V#`[+iY[F,`Pbm+frfN9MGLe&FakGS)'4'rGddIZhDr-l88-$NES#
-FY(1iXPA'P&EU"&'@elHH0ZqqqlGjTYaV*KDSJrdfYJ!$3HH[@C5XCdXB5!XUI)M
-rJjETV+q"4Hh1#&TT6p*e3NN[@(U$1ZUb4mUh&'0(LVSRI,r8J9j#6K)be5)VXA#
-f,YmcmT!!jLqj,GA*)L0)UMqa*bmMeV(i2FP,CZ@lXqSE2"cP-QbNim1KNq(QK"#
-leJ0i1c3VjM-`IHkF3#m)4Nc02Abp"!1pTCM2fjTRLF4X%qB3PaCGUBrq0Y(3qMk
-ZHM&4i`2eX#i@DP39eHCDb5f-ZhN&V,#8VVIYAj@82NYGKZ6fN6&*Q"HQc`FjKLY
-#Vc1KE)!)3HAA9[IL2,U%'XeB+HhS2HT#Tkr4Pp%eI0-9PSrIX#%`aS%2a6L05q-
-*)"XPL-fCG%0XbSM&0SFlm,,IV5-(XKUjhQE4eZU&CH-58"8*&N,ilIfiL6JbhL#
-!&1-JQJ@4N!#VQ*k1VF2*3Dd56aZ1jc+VH&RSfRJjYI2IT*)'IE2EEj58H43XHpR
-PeeFliM6FM%1)S9N#j!rb%D+9*4ah59hH"#,DD"3IThPX6'bUS""dC0(pSY9fCDN
-8[dfpQI&Q'-aEIEHh6eKT&G1G,Dm[8'4S&#ZQIiXPS5e'Y0%JTJ$QI6,[A+BCB3j
-VF1PPNeq62)4VpGfEI#38Z"AhZXPKB5h[$5'mDEB4'h,j$H'P@a&%+kpJ@9kIeH*
-p'F#`N!#kqCZ[EX3F+@2hG(!QE4&YdVR)1FekDAa4N41HhXfimr3'IpD,"5,hEA[
-"PRFmS"hLBCk3!%$"r3-@E$r0mZ+,+(*F0U"Q,5mbKS-lHJGD10!cVXFFklUiL,*
-(5KLJ*e8i`Jh2iBB+'KCeM2'#j%N*4[+EmIlSVV2&**LX)8%b2N#E'-X%LlcETRU
-QfhmcD[fmrIiS9Eq"PaBaja$+H$iEL"([#ih*q*Vm`A,JFC%ImEqMqC*A-l[dK2B
-lR5l%$5fH4R#i0[ETZFc0JXrJ#)TN!@"+mCh1E#dGRUfdlflK!CR%lZAJ@hVPfI4
-%(rN#G55&#C9X8CC+"X),-rj-#V*S4$@-BKX2h5"T)I)iJF#@jCTTDP2*EFJKL5U
-UAJ+eEaQBRaXSfc3DD0dZ96K0@hPcb1Rbe89c*Gda,2L%&9R3[Dp1$CKb$cm$4KH
-fK8k`aH+L4*IeI[fQGDpY[N@j8jTX&*rQFB'0c'1I%8)E-VSYb0E5H)@3!%I)m*3
-m9,YfTe@a6q4(P,dh6S$HKK`599HQR-Xp#(DdJJq0*b(jKT1lqp1T)NYYNGrQFS6
-9),DR9@%-GA"$'PRlGj`+3Z)kP6pB8Vrk4C!!K1pkl-Gci`)&Q!aNTJIQaZ+Uq6H
-h-L$aD0d"'JVkc@eSPSf!&IJh$`V)GSiTA+M-H!r0!3KK"K29XHm1Q!eMZpl"`S$
-NSXdhmQKae@)EifJH"4Z-U1f!BNhPNN!)9'X5ffjGJJPSA"P4lfm-a$ZL$6e!)6F
-N&`M#QVPT"QSpB5XerJDH5&KKTrLk99Y@UJD@"JRfe&"a*UNNJ1fGQZDZ+V,PL1D
-cTUhlmT(9B94l%*cKL4DDRcN!Xda#KIHk*FM1XfkSa2f!P*L$Vq)$XGkNCTLK(5[
-VPcb5U&"!Zif8QM!GiX!A#M8rV4*0jZE%jeEH9m-q+a-!@`!aM(k9YM3bGmlc&c5
-M'GdFfrZpLCJ336qhJdPLk0erl&P%D+L-IVT#fI2ECMUb9,"[S![aVLGl(c3-iJS
-`cf*DRmUr@@dr!8dND!IPVMPeLZRkGINNak+d[LZ1X!C4HVAjr9+-pVdiq"9VGjq
-E+pq0F'RA51YelD5RaVFN+2`qaPK44"8IAeSU,5*T6R6E%Q#85mCI'V"N!3ee*ZZ
--)&AE!b`k,,T!p9hmYDC"qQqhA$q6Y8JLCDP%)MB&qh[CZ",E%IBQ1Q9eP$GNji"
-UT"K)L@aLb-0"ETCRhe)fVL9SL%kN2lQh1*aMH(JKXl`$i*8abj8[*f)K*%ITU#@
-EYV,NPj-3[-Cer-Pbi*p+++LNB$$h8JeD59a8!-ZUJM+dVA#9D+U5)PC`IT[5U"9
-AMFb5japbi)*`8UUCK3,eHLT1I&i8r60bkA'E8`q8De#li441*4H3!-[T2h6SBF%
-X!TcU5Kb4Gb#KR)$J4b6[Y#Y-A)*'JX-++p0LGhFiQB,&69SJr&2I+'9*@GfpMZj
-0EMSZbfIf"3L+lEcLcQk*P1Z[j1SH1"VrZiQ&('1#MFJN9iXpp+JN3iR%DE@hS"A
-AMP1H!GEC3Tc8VH$(A!J,TaUR&(hTZ'Xh0f2D#R6@eG[,jFDl5dcqfBipBL8,I2)
--GGe%Vj!!2I22H*!!&@0D6X2Cd[SBqdE9i#0IRQ8Lci9$DVZ*hpLl!#@5)4p`C2(
-[PJp)Ei4IG1k,2-B@T5krfC5p$$TH%4AqdK%X"ABR+Y3K[$flD"#B2E-f"C(aqA*
-!(3&jLHjLESjdG4S*E2a)HHEHS3P+5KJDAfkh#QDL6Z+"rc4am&h6bQK8X4K-+&2
-F`a#QH"K1mPD&$,FcNi[",&3-4-6rI"El9C+QX-iQB$TlAbU03#9N6ea%NcEbeEJ
-"jZFK9G`b1LjYe[5lR9NS-%+LJD-q&V-dEQ,#90kFBUeHRlPT4(apRrT*hH-(B"%
-SB*!!C124K89d0IK-2-)JE`Dc+!)YJMqcd15!''&,X$#8"kQpBhK"4fdiBQM$'2'
-Nd1[eI8liX5pBCZ1hQAa8LS)!"5,#[N0I"#PcF3"Zkk8fEAQ0h-&@`$h[`LhmRA-
-&V&(&'`'0$dT-q[*YV2jKfb2[p1KJT8&%li3FNPEI[r$f`p9d!C,IUKN+`Y)c`6N
-3PQdqFI9MSl'MMlA8`-5*EMXX2XFED%)frES+b$H)6F)fE8J*T[rTI2J#m8fYk1Z
-feNP%A1k%,b(BBK@D1a*6-EKKHB'p62RK'#Zr1kl1IdQ40(*@qrZ'p!XQrjDjBY5
-2X$&@6PdeK!#@YY#%(MpPQiP[29lM!eFQiG3ee$miTjA`G*!!)%*TH4R4PLBK4kA
-ZhC!!R15d0a*#(M4%k''GMTNbbTr-X2Y2Gh31`c8E3$r"L*r98XiePFSQBZphI[5
-aEQFrqEMCVeq0*8C(lX2I0kH8l'V+PI'11YVD(H,Q1eU'c,QV,V"m5j'0SX!(Fml
-8"A#`lh189f(E3EV"rpKk@L1b@EDIhclE)HMUF-0dc)H$cacqR([a!P"$"'5N#VS
-!ZGVa&4X)p2ce$Ak8IA"6LcKl-dM#9%46f4T5RMj'%,MeX)`0qX$GRX'SF#PA2Fh
-0Fr&AB%r21lK#kV',ebP-*3dT)61fMf$`$Ah8bMS!i$1N&Im#[9JN*dUepN5#a'Z
-L4NG0-CNPYThMiG60!T6f9C5RVrc3Mc-p%(9'aJ)Vr[S[%!*r*0a[LKFHXkM5&N,
-85&kBGLC0i6-U2YYCmL(cL%cYjXV,iS2&ll"!H#Ra!#cqP!i9)r-B$R08F)p221$
-U`"FqRaMVSKX%d)#CHGc3GGb"#AIQ5U%TDhd1C'J+CmBq+"4%`%Id*%GFDZ*kjja
-32JjDSCV--9EYhq%FSR3'%PH+feCichkYJ$2HXcAN$kHki!fk[S'*GRiSlMb4-1F
-@e56qKjV#4Mkk8Q+a4bQ@1S,b)9f$!VRp*j*'!3bZD9*61h,c9&,[94$GN@L+%)p
-6miCX-@%&+TNf#HhRa6GSekfiXcMYb2(e"DRcc,LBKCEkeI+`N!#l558VHee)5`9
-R*H[,3BlL-CH+68-UR&-F*-PhTfI'JfXlpRDV9YITdVD4i6K(i9E)kpSa(`5,E$Q
-Q8&b2rH8Pbm!#$R*0S-pBrXc[YI(dNB64Cp&bK+,@qbjbeH#D2bZfaNINJmHR0-C
-,bi@h2FiLX#9RCk&0%'R'*mje0H#Rp9"Y!XHEqe3JU3b[Zk`IGr!YhRj$8AAR"5G
-HG*['#jQ*"+Md*5p*#+Z#T@N%Tlq9F6L@NNr'qUGq9KN8d"YeQiJY*iI#`1,k[i&
-FMkeb6[-Lpp#hGfiAY5rVlR9jc(%f2U8P82EA[`2DC,AV2m'SB[X'-%r(6[hG!RM
-6eUC6XV*bFjdX3%LL6A3**R#Q`G4A#)%pPJAlrhU6dJR!IBhJ!EllI("ZQ)Br@UH
-Ql-dB#Gp3$rI@34J(D#JDV$qqh+hJ`f&EkYJ"&Y'VbM4mchd-S0iN(35NeVp[P`N
-9D8q"R3[8[Ed3HZRUHc-*dMfiXN!56RBiHa*2H6AqM0d0aIK#$CJfFa[8HYJr8la
-(35k[fi@!`e+MVXU[APD'kV3),'m#F1QRH9J%5'kSd13peQab"6K&2SE"#cRNCrJ
-,a2Q2j3`$[`pRb%$l-iIY,+0mi8,qkAa(j(&!A53!c8E-CJ'!LpKCqVj+[GjR23R
-)Qh8l*6$('k@,2b2c#&2rc#D-hiEV%V0DY1EaP-jFU#cVZc,@YeF!,X14@8B13EM
-2l"ca%Dm@`kFE'0GK(@klH-9re'jp&+d@S@q3!1@3!1`U*3%%fDbYEdpE43a2QjX
-2bQ0"lYNK(5-NVeHcj1LlI1,ZbAr3)*jHC3X204%A)@Lj9&ZNa6)qHe1R[eq$-Er
-V[!34E,4@-#apF*Nr-9Uc2"L3!'Hl*(B`LBeVe%8rZ[dX4AcL`qGVZ9h+cNN5K@P
-m`fHereF1'NK0ed#"q@Vj(GZG,BP$bk50DLB8UI2'peqbBh9Vf(XbZ"Ci5Fc"[91
-CmUMre'+DqS$q($P@c(Y&1(e-qCA9PQ(Fqe9i(N(eH#q4iIKeBfaK`QHJfYM98F1
-2(0m!*YEN`RZI&`SEh*%d%9DjBR6plT9)-5hdG+h1cCj*[(pLFj59-ab'i2cT,D`
-MTP2KV3r0h'l"!eCUFlP)pA)TFQDcD%6pJ@`-[r0YAJU3!([J,LMD!!aTd@*X-'a
-+Na%bT4PkUb'ZSP9,Q,2)+ZpE'B(P*PrLFB(8Yh2`GEJ9Fbp[k*9T5T`-@i8Bh2Z
-0P4+hhaI6Xe*H4RFc'#[q"Pe!`%PSZ1&QjHKAF1rdq#XL(1I9)!Ha6C1@NjFYk*!
-!2Rbh9l[%rZSGFTa-fI@dIf!8fb83a&iV6X-'d0KUm`8)9KM+Db14k8eXKIXe`BS
-Q2`6JcpiNm4XS*r'+&3SB'$pV)bh446)*VXc5Va"cMbldQ4fGBqHHJ4LkbRKaA`B
-Me9lYk)%NYV91HGLSbqhKe-!aEYF+HEq2#f4VS[&ATMTDeL%Q0R-8CSYZb*)Ehd&
-FP0jmeI5KIRSLNZPjPr%1D4S4dlbe[4+dAB'NGG-1TS!D94UE6EbVYa)kc-l,(Fm
-+Xib3!%`Z1aQDe&VpjB"Y-3qRS0Z&4[T566LNaJ)1em6FmkEhEH&DLb#9339"))4
-f@*m`ZU(rh*ILmbhIdVTZBJ0ULIrF)3("rYN95$Sd-qc`fd%q9m+S`MaXRKf!p91
-$@qhiV*pKSN4B#VJbb)ecAd#DjNcJ&hjKNYh$qdYD5eP,CI"*3f`k,YN2![a[fVc
-chk5T'(%Z&HHBR5$Jj(V40Zd1r3pIbfFLDilQbHfEr%3D,H'pe($*Q[#k#c05FH4
-L9b42(UfP2HarfQRf5VN@@PhEaY+((5H4S`M`4q)Xr1JqXp1e$'4)RP5Ypc*-5S,
-h[L,YL4)Cdh15$hh,X`*Ma(D5Q*i-L(62CENM62LSYJ&Gq'Xddf3%1a,d)S0CfQA
-ATGr@hbZFNVfLPBY6&ji[Sm&YK`b[qJUARa$Hb*aPhkQ'h5[K-QFj5R9F*AaU$f@
-R"C'5hE)VCEaDR2P@+E+BI3,AI)CFN!#Hd)LE4'@RMS!BTJGYb)ZJ`'TmchRPU'+
-jhqGpLaJ!ml(LlD0R1QRa,ir(LYahAUmSVMLfEFfUFX26r"I&eX(!94lPM&FZP85
-$1QqZ)[Q#K@*SF9V$P(R'Z,cT9j+Ad6SFPfFL1hpFe[[9T8C[3)rRUX(['1UDa,f
--E[Ba1H3*(E-@$f"A13kIU[JNQ-IpGqK1C46"A9hAGjZdVLB6V#+`$k(,eBH1!k2
-cE(6cFG5Hl#I8-043`$3&c+DllHPc"hhNHUb1b#RT`l1%`SMB+B[jU+rePFb93Uk
-4T2hKlq3(,qaSq(E2!r6a*V9UVNUrbjrDFM1#KhaCV2FA,P$`Q$4YIb)pm4mC)Sc
-lbI%8J3EfP(AG9Ek6f3r'2Xq3!,Ni#%E#e)MB@SJLqF2A[,GLjR-imTYEfPL%@3%
-i(T%5bSJ@ARq4#((G8@Ll@2&''Tb+Sf9X$NTqr*'(X@B'"bV&Xk95mcfdi%8Xh8T
-R!`@QPj3lURIQK$B-@H[HEV'05Z$lSh2AiGZ)Tp2H"4SKjGe1IE69CpGcNa,43Z@
-M!dHSQ2"([A$kG0c@VSY#Pq(Z#!QFf[F@&*Rl9m01kSI[b1P$T`Lcj4XjF-b89Lf
-5$mc0mVhr[%IG&E!)eKfr#h#F+m#UU&)Lq`1C$J&'8CdfL-8H5)d,j9f0*%%i(kJ
-q1)bm0Jk8jY@F+pC5SPX%mNZ$mF%+kJ#FGZ8eG#BD@DM-U!bJ68!R*ibqmcUa,HH
-f%I21)M-r")%Z"1dFKe-1#%$QY2Fqa15H$G&J!["FBNJPq$$,2CMI3i01XII0PcT
-Z4jRTq`0%)adhZ[P`!N954KYIj$d*6$8-VEpUL5lk5)RK+Ce+a!*&4r*+FkRK#QG
-BMM1STL@cd5Kp&1&,)Ze$dd"ep[*G,TS@`29Cqifcr*I04j561Aa1F)d'h54ejlG
-2AB#AN6@`V-$j3hRi2dJ,F9TVPclA!"FR5!#qQIlRPrm,G3IUPGYTcl-)`bTc)R@
-3!&1Yh2H1MIfm"k-j%*0U35B,r4c[#"lV2159K"lT1K8GRGe3cedfSMricXB45)V
-8q`Hi+SmDhhf"$XEID[`1,F!46aqcZF"qJ8N6*[M4ZHlQAI)KS68`XMkc9Jp-d!Q
-IfZ#Mq![C)I$KAC!$M%cJIa"LiaFAq&GJP63d(C2`+V60N!"aXpl$Y[),"I4TXNP
-06-jm4RirqJE8XLEj$+,C1$(jQJ,i(V)[TCj(qcE6[KhT3f+mNYCr#Z9lKTAXq$$
-A(cC#8dB$M2Y"Y2%GqBd!APq&ZX4rG(#Re&+fC"!%RIL`L%8U'b4#620[YIQZE6$
-R9Ri*HHXiN!"DrIDA1jB2EF0Q!Z`Vida2C`YeQHYYh'6cI#PJ(0jMZB5%a0PqFA`
-bFNk5I9El3+QQ%#UQZreh[MlZNeY!fF9CZKJdC%[*GUIR5Sj"T1&+C"3lLM6bK`+
-M%*0i1BQP@(+'pU&hR!h#l0!R[i)KEc#63Ziih&!3Ecd!6A1!T(NlE$ip-6*X&N1
-%5-#bIhE$0"9E(@3e-[p5ZReRV5P6F*bfBZk[Uiq$Z,bbT@lP@BHFc1KN,1#eIdH
-ZDdBABBKDLI#f4decqY53!'H&9YN&[j%Kl(YYX2#,kmaL9!TF`pqY%r6lCA`0(DA
-2#0#ULG3l$Y8b&R`V$p,#J3N[6X-h`A*"R(G8$`AbYR'cGl&i&aX`NSRKSjjFFMe
-X[I8Idi-QhGVbAEEH(d[d5ZMdL+p#1G`ej-J2K-cFadSE&`KIVNMK9i$Ba"h&R(U
-HA%kl%4A)eERr+EaTH+L!E(KYLa(iFJTPFJjEP!!V#@6H*M8klB[cFXd6IKelR96
-KYNcFJ+)3)R%hfBJD(MAl`#c'%jUSV-8SR1,6QX-Y#Y2Lm$5`'F4-TGfY8&@GQ#i
-@99p[JQLVEUiNdB+mSGD+NFJU#K9Y8%6MhKFS(-28a9V)+-&EUTE#-(R$fZcX&Uq
-3!+QC%f&[l`$UAe#1!G3jiTFiG*LK*D`(9Gd'NQ&q#a4*i&V!Bm0!U634lm'0[b,
-Id1C(ehIf0K*dT!!9l#")%VU2UGHG(-&BeUF2A"Bh&!UH)3I')X[QB"j[)-HiAMc
-Zl6l'1G!!)hmVpjp2*H6N`Y60h[2AAcHQbfcKNJA@[9HI+eHFTS#PN!3"!!!p!!#
-dSD%rYA@&Q`#3!mN!!$@q!*!$FJ!0c"8!!2Q-!!!@BJ#3"!m!6@&M9'0X)%e66#l
-2J!!!Pla069"b3eG*43%!N!q!!*!(3X(8U2d5FX-%RaJS2$#I![1[jq-`QFq6`ea
-SNFV9'KiZ3PRUH1$XZPlZXMY#AQadC2S%D'#b@LJMBJ&U@6,A4&`!D,e5(RJd,3V
-$f3FjLH40PAh(VGfVkZHc9e$Dj!K9DYAmXm21*-T6R!hYY6bqqF1('`C9peXG9QA
-%hU5f(m`&#ApChjcKc8epBR&U4)Vr3XBljUQFm`GEPU,G`ec,,2c6%!`IZ2QU@NN
-#XE3bC(K`@0TqUNl+Z*(rHR$ij&mrrBN2e(`*Z4b1`Tl5)5``p32"KXlR"5Khic'
-N1f&pKDLZGE)"-b2+RESe*+dHai-%MD("LMk3!'$"c*h,T+50PJ&jd9MreT5i-PL
-1FKUZiB"CEZ-B5E8P2aF&*pSGZ"SkPTjiMNjZ2TrjF452'D"!4'lm!-JYjedS0QP
-$NmC-ZMZ*BS8KRE@*dZVjSDTXJi,P*8SIl4$0&$G2X6JChUB@$efkrffSZG)9hIe
-*9L+f)hD)U&(LdqbhP*!!NemL'a+He[eH"aX09b%*#IfZ2HE'P+*cE+JE-#NrPH4
-2(q*@$V6a34DiJ`qHaXPSC-Ce%#%CK)3PIGT4'qSILH6Qfar11RENaFX89`0L-0)
-23'"qcP1iRR5MP'B+KJD*F"9mPMbaa$3K-#"0hIk`l'&P5J%S%*Gl@$qmX80jTjk
-Q#S,C(hcPieYSm(4!!RK0d[U5FDpI0ia&LQ)HeShKNVkL"3[Fp*-j1-iLe,K32PD
-9q-[Ce9caYE69#abKJ,5(BL#-GfU+q"5"-UE(+@K*mGr&(UT6(*16SH#@0qUL[c4
-5D`p+8IMP5E5K8e*bF22ADkNN@f[I`2hUd#k,#IZZ-Y"alb"V,4EKaT9bSDPVEUc
-Qe31GTSF!aKjcA9i,p3D@HH"Yik1%`8`Xbr)K%X3E)*hbbkLre@k$YjKD9%$p$M#
-!14V(A28@+4jT('Fd#ZJI6HV0ZJ$S15`+b!rLYImE1)V-1a@1@ae+3ih'ECI5rpI
--U$2FCF2NGrP+H$cK`IcKJX()&ES2Kl@*1HICNU`8Y*LJ2fJ[cYRD[[%JIDjDKjd
-Y,Y6K`HUB-(+"-I0E@B%aJ"4$G'rH'NVJeZ[N'(dV1c1*b),ZPl&*2i3@XcG4%I9
-p%aYrIKR96apXh5jL$*JS%X)5ID"0c)EU*3D!"F'2*"RQc23"q*!!"kNK3Q*`Y(b
-5MamCkrC$8A8-J8j`AD0`UDEh@k5qr#6Q4[%U`FYCBJJ1MaQ#Ajj2RQ)%L2SEE$i
-i9$LD-MBd)HXHa`PF!iCRbA[5FLZjUbY8ZlXm13kb%Sf@M(l%L%G2#H"AISd1JQ$
-q6k3&l45(pAA@N!#XKaGS*(!1T[LXVY2RHAfk,HJGJ'D-NC[QaU`-TRmVV0frI-Q
-#2Xi+JpcrI0dl[,KS*iN2MAiLS%pZ5Dka1RhlIIS6G@keaVrDDr+$"0Y$a4'kPr(
-l2L)pRilVP!11H,[V!p@m(6JC3)m(*GpMU#V06HKl'Bl2LFjBJVFdm"#8mI@UaLR
-Ll-0-Q"+&4Y1R`KcNPU$Neb4dVqI8ZEL#Ef+C`-3HX#,G&-m['aQGqFNEdPHF[[Z
-iBmMPpI5Qp%!q"ZR$8"bUQR4`h(C@e3m,Y[86IRJM(p%bEdc+GT+lb!ZKLcC$cIR
-8dc0MGmbPVKrVm&bHM8keac2hdVT,lbjjaH8+*Eeqb&P)%-li+QaCUbSceH$[TKm
-)0TJSrS0E[31&KqGfVei9`bA8PXL%2-Iqm%qDBJf1,LHS5kAG31!P%+T3Qb#pZIr
-&G(E!m!KCVi0+be2iMG)9'3,b-J$9e9pqZccp(Hqjm[1SrUP"[jP"QKMYE-9VNRM
-arRGRPSeai+bL9K%EL-USiAl-iI9CS$c6XQHdT$ET""iK`$NAJVraGLFqRf02aDB
-ZF$0D6M!L@X9XD8",*&lm189*Zj%53$0e@H5F+$32ad-&S9S1-YL%dka0!V")Rfq
-p$3i0&9`SPIpjl*4PA1d0lYK@1eG%#[aJUlQdic$i%`Li-X`GpB+'brPUc#EKbDf
-8YfC1Hf"+BffchYJQ(H*#F+S(Fhr@Q9p&-B+pmk(SIm%eHe%L-4pplD62p*0([LZ
-[0+IT&`eeNL(C6&&"Xi2kcBqiAe0*Vi+5i8jY(drpHSAYAS-FTI8li[HaIHjhmll
-c+TBN0%+(I-9+9SL)0S"%-PE[l"LDB3N4He`*#(J[R%YY@Hh2mB8N'&,5V`0PmY4
-03k5kf*m,J(Q"R$l6k(0DEc'Cp,(&XqaZj,XL(3qUD'MGf'fA)&(b'+a+%E6H8T3
-U4(h@PF[8R!`*FGb@Km!c5+ReXb-GEfQL)$$"ZSqH*-G1+NM)(+DLd%%0Lc&L*)V
-BPk)GQYK-k(hqJ"0`pcjE5N"HV@)PK+*PMRDAaMZe2(MIR`2"dDJ8Ki3*+''VhV`
-r4[SN3kCXEIJLF[S"XTE4c#%Mb1c'dG2eIk3(XSjZqI6-RKY"TFD%N!$fa"%-MUk
-KEkN#+NcHIGX!VHRKQq-"(L#i$1G)(`5MCT'r6)@")LlT8R&VaJRD(C!!Lj)0(NA
-&c&85eURMjDfK0fZfdh@Nam)+MfQqXDNMkGX@'28ST,%dm-X&KQ2p)fGS&"Y%&6G
-L1EF8k822hVlqmN2i1U+T'kIl6bVeY4rd,m'P%,e',$jYU3kB*9VaK(alaEQ(6rm
-q)q(3A$hp[Q1BXMII,D#3!&bXG($ih`mV#JhQ#TVZ[qI*`55q,Cm@r`a*6%YlHEc
--Ff`[`MJa#ZlX-pN(*jT+rH!0)2*jqrQ2rH[kfr`'*l$68kF'3'c$[jIB'-3!)EC
-bKm'aT"6dPSPCaBYJepLFBm&J+jE(Y'1N%Ck90YmpcMcbIIi4[1PS[2Pb`jjN"%F
-m!TAMBcjPp4-`,LH"G0FC`pApi9'ePFMU3h"@"A)Xr4"'q4p-"B*HqQ-UlikaH"!
-5R-Q6C3EGY`N4k"Ki%K3K2d%AT#XK02M1a"!&0,a11VCcm1V2mB'""TcV9)&*@k*
-Xb'af)Qf9N!#'lmKk5&je8eQhM%5lTGC#c')N)V$0JrTkT##,R)A`5S%3fCYr`XC
-Z"@N6B6CVEP1F@S(f"P%AI2d-CR!ZYXP`2PjDQ-ZKESYlq`q%5NhUYeEDUmRlr!k
-5j[04TpK3Ddl%RMBe`,aVUrNeT3GB'p-r@2[B[X,m5LTYqVqGS6#$cJZ)ZTRJd+U
-TSH-NK81E[DICTd,G&!KM3Nbj39eYP+')PlPRqMA8iZe+I-r@EL,fAkhQU""@mdd
-DL[FPTeQ62qa0Tb(+c2IB**ZbHXRiaCNdPlB4pcVXr&9fDUD9&'2S#!F`X8ljbPV
-3P-,AX8`jaN1$S)pdCmircAE4&FHqSDTcKr6Db#0djJNSJ`HJP9MiQrapJe%&m-m
-Xp"Z"3fkQS9Tj6'aVPQbkU,RAh`!Gjm[P[braGY4NkKq4+aQRR68cQ-Z#4f6pC+$
-2%)&(L%k$ZSCN4+dTf@4f#TSB24Yr)p4jK-B2$3#ahdc9Zlj$1E@"$[@T2X`#--A
-+!H)MBlX6efJa0T'e!qbXf+[N8`8k%Ea,4+J"ESJb4hfRpjre@kE(ZLh+(G,crGp
-ba)l@X+%ZdjY9GDFB#haT304RN!$eK)Pb`SRIBk)rjkeJ(A'Pdl$ZX&0eP%,RS"Q
-QKlXMj&'LUXaZJ5`USTP4r'-2,bKKiYLbFiAqR4MZfZN,X*cX8Q$&-T!!b2SVc#l
--jAR*Y@m6mV)9N!$320b*q5G1j,Na6m4YIkMBGjCBXk-[hc&0r+CjC0V2r@XhQB2
-&DTC)QKbClB+c!NTb4,JP1H(PUJDeQ%r2*&4%!BkphpkBR[[-TUfQ3kYLpiq%m"'
-p*c4@al%R3ba-d4Tlr(AY)!R3fXjBAk$%9K-TIdV*,Y`rAaUUpJD-Zq9b+4k8caY
-9@U5&0hAYBS(1k(`@m8M!RiEQrQFVrqc265`'!C'"@XmQA-J2e*F$Gp8`P"Ml5Hh
-pUB%1FkQ"AJX!k)KS+*l0(0'fQF`%020V%eAmjbZbVeU&ra%(0qMFp4C0iD![NPI
-0Z00PMY6@r*H#cqHLAX+Bbkq(m'e3h@2J4-C2'KNaNGVlp1YG*SjE2k1`**`hB)+
-i"243MAck6q&Ybr-YS91!YQ&S8Ze5f@rqZhir-Q[#$j'@5%&VC89N`e)p"'Xmi&'
-FNcQDG0HdRR3G,NKe[M'$QU%&+h1DP,LlC!$-10C6,)irG8!qIbj0H'`dl6'lc+Y
-NUTYM!LFLqdYJm2cG9fd(##I%a#CqRF4,QlHHB"ZQ&ND-183E*6rR,M%XV4F@'L8
-m*VhH@Z5ELA`0f&F@[+2*$&d,bCe)Hbk1@hdGUG9b($,E-q-rfma!QpYAq!Q+,0@
-I&p4ab!XiAe&X1q,i&N)rP$br3NUiQXP5%ASSK3EF,"Bq&c#K4e+0pX+k`[0Ke"4
-3eAR#"U1,(LY+B4MN'A8bDq*5kl5kMfAGM0I)RB"S*lX35XA3iR5R!mN,KZf#YeJ
-JP#b)(V-6DmKF3Q6qSeXiGqA%-@8)P,PNCVDb4Zc1cl1SdM,h!QSfHkp5YNU2r@c
-C@Q`!-&0D[@F&Aq5([2AcCGj%)qiB86))YJp*FJY4B3H0BZmhjQlD1%C2`B1Z4,M
-)l1(#PEd-[fNCRShPJ`rES*'+c2"XSSI(['0`q)dj8i@Ck*p`dGD0Y'b!K*AJM9#
-+l`6)h+#m"rN*I)Vj6hT&kL,cr(KFBVZq2)C$ZFFID61bS!58*q[@UL%9cf'iCU@
-"[M"Fh'!@ST,3a4-Bqeej[8f$K,E0$Rh,3mZ+F2[#f)fDlTC)AZ["Y%VD5QK@J%d
-MR!#+bST&"fc3CXKj%A%@+9Q(mTfj4&@UJq#@@e"5"%cSFIJmXFL"B[R'M9IaZJ,
--SB#ThPVC&20UCd1B3`r[cpfq(QJalXl5@e`QC5FD+9r33cTFq+k!edFp%AIIF@C
-1X*&0G1ap5ka(APR-KAVGa$24EAMU%#BA3,VXKT9k(8YQ-1TmZRMrL`M['N`'YPN
-r+PJ(`)bY0Sde!IRZc%*V8M(!d)G,6bq$TC@0irL"2EYTJpB*"98mrU4#"Y"l8C@
-@Vd@q(AIjPPc'1b'@)lb-B6)'aXK@G)ZB38pXII*+6rXUPC!!$3&+h8K#3c4'QZk
-&pb-i(jI`B%AlRYI!S)i1'Yp'DFrNrPCEfQdVkd+Nm+(2SaBX"0e2[QKB*K+@X)k
-T'D@QDAk%C`1rJc(,RUkM98,12L*eQRGYGKl%+d@-aFCYNX5Xi@)ClPe,&Vm(Um8
-*eiVccHQ-SVPeU#Fa4TRDmK3MAFcVcmchdI-5`K'KCUA8plGJYN[UBR%"c#XP!Xp
-4&eU@A*rrfFK&qaVpGk5+EPFqlG[UiaKcNDVDf*!!`4FRiifd8",cm'@3!-1XB0e
-I$U-2[)6RJM3`C!kk8GEd1SajaLlS-LM[k'!QkCdTE&!r5[)&b@[!hLqC8aVNKPr
-B8LqV1Ja[q8,-S49#dbFB)hh94NYfk,Y"[k`@C%2Q-G*U)#,%R@+i$Ek#AjaC`!*
-rkiTelMHTk#QK$JN&[aj@[f#BY6H%i3K@ebcN3640f4'@+pKffeEf(#G[2+%Z3dk
-+B)RAQ0,XIe6%"X'Qi2HUVhFG+F%bBI2k5ai`!k5maXAX9NA1kXV*qR2,85[E8Nb
-Z,dH&E)f+lfb4H@cM#,RXecJ4)j5cA%CRI8ac4V0)JKL!G4$(khX@[B#*DlH,UH)
-Bk&!amJ'VV'A)J404UV4)YFNLfYXPl++MfQl'#lL-SEcEmZ9p#I1'qB#N%'6f#pJ
-`h,&-De+MYdiK#&K2jkYN@cUC*G4P9U,9S#@8iZZ`Qm9J896I`IB,hh)eDD,9V`C
-)a6Naa9!9f`92jFEAC%ShkHChbEjeKk"qkESXqASNcVQIXl-HA0TSSf'ILMpPm4C
-3+VMUcJZ,4`9@$6(fqAmC6@#EQ0MN%dF-&FL"hjB@dA1i*J&pPdA&bK1ZQXlJmEB
-%F@CFL8%eBC4DaD1Dqk"-08Db&AC$lLIL!Ir@!#Q3!#dRafRGhQc61Kb'p9Cm4`F
-'LaQ'fG%*"[FH$L,#pDP86(G#HV0!aLG(M$#4T'cL1LQK5*%RaKV,0bG#J['a(3N
-XL0-f5Y$4iH+UADXHkBMj14q1mK)d9GP*G`)l0XQFQ$Lr0m(Xe!5(6,V+#P,B,Y3
-e(1dlk3q!0NC&3PFIDPPL3i%16GLT'$ZCpK82((94Dp'[JiMakm-``PVPB1XYb!)
-im[X2)Thr@P#4DpKk'@FS+*(Jd5B,`qSNZ6lFXUiLMh"FRm@X)9L*TfTc%@!Z*eX
-*,4BeBZpY6&hZLB2ZAkL#5Y!54iG8rdE1Zj8kB+VK5QI`bGCYTRc"Smd'QXK4-pX
-&@I%#H,m%+@9RDUc%i4UImAUj"CT!%FM`%T)p*`cPIZRG$4K&qG0d)rj"P#FUkdi
-0e5P-N6S#SG'S)AJ[-I$-0L[2)QPHqhc9clGdh0HrQci2+adaU`FpEH2IrE#d(,-
-mC&&p!)+j"3R&lUFXk6ZhE9)k@HPaEq@P9X(mUHJ)E&XdhAR``If2FdNRhSekS@m
-dP)bK6A&kHQDNDkYM')p"Z1CbXcG`JJT648)I!lSGQlfBS)2fXK1GiHQK#ES'QB8
-X656Ua&+fA-JZ3,+hlH'KD816PD&Y)2c,m9PGC"D6JaErpa)JU@)+k+B6N!#C!FZ
-CA1KbM21i1bmIH&N6,Ra%T4DiX9NcMKHV,aB$#)0AUkApHcQDQB)$1EDYB-)C9e`
-mZ'5#p2HMB+"'5TbRA5hlaaQZ%+qI840LIp-L9,Rb"*FP,@Ypp1f8"(ACYEk6MSA
-%PAMahXY`D`mEJGER[FI,SpLQ)QNq'bASej8ZFId%0&+Z4cbE$$r315&!Yl9eGfd
-Ra[NhZCc#Xrl2Q#TARiL2q5RCTif&"(@eAT0ai[kkPJJTT@%6BLC0m+&)JmY+QaN
-pdqDARFDL,A)!iKk'Z[ZQ9Qk@%e`IA[hYjJLidLQ)-9S-4HGC-pYFX,6DkSdURAp
-I4q(2@%"GjY%F+cE4VQM',M6Rjm6qIf3[CZ,84E5cKTPZq19G8EpbAr5ZE@l`L`l
-(@dkEr"5-b8DrmU2V4b1Dk(Mk''D[9H*KF%aRBbermpC`k+GLTa$%+8[KFGj9qrR
-$kI[02#5+SG,ap8&lUDbqVk3KBm[,A!'NVH#&S4I&rImF[*cM,J-N[Cec`49e5Xk
-RQ)UqUp*Nab*adj-+PU%ZVPEJqdIJ(h!$GXV3+R[U#-d*a5mB,40%r-X0S'4kL#X
-UG0-DlFEHhZQ5T#C0JqImjTHlBB*JCrJ+(CBK#V9If1QLm@#UR$K)@rX[BKhb8YL
-1+MbmHRF&2i-Qhm9C@IkfC1[,Jl"5C)`B`mNcUlHd*jDLC2U@,Dd&`p+1UaY`GFS
-pr`GchQ1K-G12YY2IMF&al5-8U8**X!SlaLHZZAarTLE,(hj[(HAP*+S5*ScLHBI
-P5pX%a@YDNL&e&2*a1Sfq[5LJdr([lViJ5N8L4P*fc"m3(a6q,cG@!U!3SU5(KGC
-C*hE$e5Qp@Jk!ZZaqiKCUATkpT-DJ@08R1V%,@#EQ*qP4R,3bF@X*e"F+ARJqb!F
-a#mR(&YDiK(J0(-I*86hlGb@$%#I0q3[8b!r"8p#P!"GdMjmdM'E-$[966E4&#K'
-*eB*mZC!!5TfD5d,cJNbXHJ6Ki"Ni6j@)`#6jlQ!BT+h#h5TPT(FZU`D05f)S*j*
-%F3YDJl6XVJ#PN!3"!!""!!#dSDNkYA@&L!!!([X!!%k-!*!$FJ!4UCN!!@3N!!!
-BD3#3"!m!9'0XBA"`E'9cBh*TF(3Zci!!!*Hm68e3FN0A588"!*!2J!#3"d,"e+p
-l1d1Njj!!@,!Ie3q,(Cc0pVijaaUp,Sa8D%lRR8"5#X"PVHC*dC)N*,kVP0feT3#
-,Z&M&)cpiKKaI'U)LURRTV0ZS[j+!Q,*q#[&*HED'b0`f)CqhAJ,Q#jd&mCRaSGB
-5J*b0T5V&@MlM)D1,!YF,R2(BNrkE6JTI"kd&G1Y,(Q-E3#0NjUe-[R(!4`lC#Ud
-FHjFTBIjXCCH([[5IG@B90L*G"FdkbT@N[%-)CRCP5jP6%SR9M@F,"ra+Z)q-Mq6
-!*2F5I``dIIPY6C4edJXU,3aD5IX(IU'F+5#'83hblS83DZ96e%*2d$Li4SUDT3#
-AmmqA"Ee&4c+8PLhA`a`i+@`6[1#+2)9HB$+1q(i,K&9%kLj0P)+E'GPkNYFbi)i
-EN@(5hK1E*hP-6,ZmR9`+JCfGl2V9#PK+%h)J%iZVQi5@P#**p%-PQD4UrbC2MZT
-+$D)*0SVj6%Ca5m)T!R-er@1Ir,-B+659h,a@@(X$K*G(lGD*,KZDS8AYNk9#2jR
-il1PNIhdqRh$S@K%G2b3mLAj#cqKBZE!Yh'ElA'NhErkj&pcS3LpKjX&1c3qDRSC
--)PP0Bl5QEdlJ+G90Vr[lM4@(9"@l$dJ1Bbk"f'KJIeFkl+a$'-2$3%)R8VKEB2,
-8qd*d6&f23E6q1f!3-CMH%JV%1"$B+5E*JGA*['UqlKM-eI`Gd$P8-ZY(rlq5MV%
-MDQUSqS29prHVD(R'Y,Dm,6kb8dE+f+'&-[2P"U@%Im-8qLdlf%Mm9NZ$qq9q4r`
-#2rId4`J'YRTRa-$)1qN+a-%FJ$#+",BK2dZ22m36,9pZ1[9p`VRYm@RqdV!c"4U
-XrNYU@pUK12R3Ic*(QDEHE98iB1MPGP,ql&8``9Mk38ml-%D"`0qJK59%'f%*GYp
-Pm8LbK'8*"bFFq"GR#j&cdr-`q%3TmGjeI&IB%GV693MLiJ'H@P%)Vj`Q9PjU1N[
-LeFHM-T(`C*!!9p"AmVY$ihH6,'*K2S)#L&kJ@#-PT(+a&"keL15'(IM-a#C'%3b
-PHf$l"'$,F[CT1!ST()N26"j%TrGR(E*89Fp$-*18cE+QJS'8#h5,*LZ9Ir@)A[U
-ND)h(bPFJ+*UNfAe9$&ReXS[+mANX%V@RGSrcdqqLB3ilC,QQq'+DdYAPR*ALRAY
-mL&mXp&+mVcDG3EX6m2&FAHqP$HXpJ[9Zqdjc9H5hZZUY421J5`aL)!$kr)'S*r9
-TXp(N"HhARC58CI+j`iZmNq6*#4R*cNc%IEpRpqeeYY()iZ4@j!(RIPRA3SFRM%Z
-""%l'R)JVF%L4fdHYQ[,@UeRbFR@ch&&YTN@i2(hZ,'I!f$bGUUI!8XUa4VBZj&*
-RCR)R4,3@Bh$*Hrq18$bkQf[r%3i3"YEa@h`@T6-`cZQ)2`9BB&QC0KQLR[&[&4F
-%GBh`c&pR(N8REM4R#$%TPrX,&-JkJSc[68'fX[GATJGFN!!LpiI$q@i)88J%&CA
-SK5A-Lb$%1c-UR$QaV3-E&PR5E4dcd%(h8HGiJT`Ne3,S3cl,QFr#!+#C#pm[H[p
-bF-BXXbZqZ@qHNcBfhcS$r#&TL3jbIqrQVQ`F)@',Rd@0Fb&mDjZX&()`39Q@'j3
-GPLcVPK5acLmH)(ZhK6dm9F-(RIfB6LXcTDFLrDjN&@V`H$&Gec$+Ch8YBmiSX@h
-S#)Kqk#-#arK$)*XmJ[4lERMqZA@5CQ0S'3i-9,@TNGYE,EK2r(E3C8(`Mq&A*#)
-9BPB+%C8D*8Md66lCrX56!8'EqV0L'#i1h,3DH%M'I6XDlaI1E21dIiGPD8pMlL[
-NhNjZZGXNM%[iap0R,"*Y#5m*Qk*cTYaM[R)4*pr*NDDA,"acCfpAhr%9cq0e4$m
-T(*MH,('2*f+Z#B3Q&Bl&`4ii,'dBE2V1c6"rGRe-qFkC8NSVc(DZ@ADSjGBlqp@
-$+AAhCe9jfPrKV23)PeI4G2P&YaYGQYPL@D#8VVU3!,+afN)Jm3ej59K!q8U-Chh
-ZD9J2L4#kG1Y'&k6rHZ$ea,6P1XM`q&pYfM4i40c2@9L6ejf'b(3BV6Z49E2#SdS
-EUdKa15`HQ%LR`hVD5p`2"%CH8NqZMT1),km1kX39aJX9EP8T!@YjAD,"$YNZ0)T
-UTNfI2XVqhAJMVY2h`l6+-NTH$U$Z,LVdpNNA6`1$m*0'(XecB-HVBPb+r-4RLBd
-4L)9bh%*`$NIZX+B-M!,pI!0895)dd8#9pdjfJLJJ5b*)BS)KBQXQ45$rR!)M46Q
-YqqTcMqMkHeZCYdjV35aqYXY5$U23k[H6S,GJTYMLk9j'VC+@i5U($8j!Eqfb"0p
-*V9EpPHRDYLYSKR8L%QmhGkUrk49aiUF2TcBT(mV'"UqlFlP&a-+ZZ"N[e)#h-Sc
-`B`3!mUE+N!""aN41,ddb3I"KCi-`PBm*#bj%q2Qeec*,X+FLZ59V+[NP*ZNL$3'
-RPFFhb0N-*Di8r5I1FQ(h)QlHDYhdHqFX$aQ%,!2+&E+f'Nd(BJ,Fi$05ji3cdCR
-hS1SA@,jbHZ2f"VMi9,Mj[iUa,eME(H2kP')Er9@T$SpKflh0aYCm'M)"m2hJ@9k
-p0EC-FiE)"qeU'K`lqZ3PjiTYJ[jh2)$NhDk(R4$MVNV1*hBHlQ'3!0+*#T&NcDq
-#LPCF&@pfYka6qAhc984Bj#ieIqr2qZVS&GL-%D(*jj+,jUdra)p$HmT22$6IN!#
-Nf(N,%G)LGP3j4,lZQIFPL(KR&hT-Ip(qF+*kk$a&FdkI@MbBJrX%T4DkAIAb6Zr
-X(pLbbZ32&JX#PQ(DSkb6NFSK+%i-0[)"JHK$GkrD0CblH,F$jEA3D0X$cqKdH,X
-G3LhVVN,I#mXY0#++Hc-iARq"h(4ci)52aDS`)K[""Aa4RjJUJ6HM&phfcII'C65
-F'G9&(2G[E'aPEm!fF#`GX0V,aSE4pmiN*D6Nk-mr4ceXl+KG*6PPfmiAR)VNAF@
-Yl)Jid,CHDd@f-M8`&jTIqdP6Ulef9N`"S5&dcj[HB'Yek$kkFMNk'3cPUB2`UL0
-53$dPbq$-Z([4Vpl+qBldbq6"'ih85r#YacaR"fU&VP#f6qm#[BlpJ&iBIT%8NZ8
-p0SMHD6LfH2VUp(,I"L5Y*NqE#q`KXBJP[ZR[m%KMG3iAR"TXaX-QKEG@'-ljk30
-a#Z'!ilESMD"-CrdY@K8X2"GKGkAV5Ej%`TJZebNIZXR$fQE[CP2m3658QY#3!%S
-c'29rL40NY3DCi3NFYKRb-B4Se`J4,J+r&kM[2V6$L'(#5#[HIZRmE-Z&BklHK8Z
-0(rAJ9AjSeb6deMef6QC'fG33Ii-J$'8$HP248,@*)rBi5$6)!`2HS#H5&9qpCef
-*$i0+,DqSM[%9$k*3HReS`p*-(Cqr*#-qrk5+(ZH"E1Ie6h+bc0AfH4BRr4,`$D'
-%2951`X1ETITVB0E-26FrL6B62M3NSG42KD%H3f2Z9-+1F##r[EBpTmU0F2)Z`rM
-pall$jNcA0rH5eA++SepARQBMfB!VQ"rI'XHYbM+L0*5T*@&JEjK*j38KV#9fFC1
-JXa'83L@CU-IP-"VNJ[5,[ZLCI-jq9cjLjH4#H`&$(!P`l@dH3hG21U"X1NBJHdm
-#q&Nr#RQ[&bec40fSQ("prEh8KXm2J$B%i*Rq`2r%cSKNLZb8p(5kM3qKH#hEi#L
-UB%V$kplJV1Kp5RIFH-eN-FSpAPC#)&Ym["1[F3LKP95UZV!"dr&D9+F'cQffEk6
-LC-PXSTPce9)@[[IfmXarT5&ihU'pK"mAF9H@QfbAJZe"cj!!hRrMJm9(#QeN"kB
-Hh&)*@Y%qU'#4,#lKV*X3$M[`+TX2%fL"cYi*YKR1kpY(V)PUX0"5cPf6GJF%h`L
-Eh,Bc9Pk2l*br2f,G)[5Prq8kDL'&fDRpKZh$B+AlrXXTc&jkJI*Jb$aEir%JI2H
-H9QMap)8FK5%k93*-2EkcbIVKNGSCU(kV0ImQ1fU9S!-ha098mZZZr0b8MG3hF)e
-PGhBa@R4@`H&EMB0Ki9Rec*qc6N`L'BkZ,+kBK)1pm-NT9TY)ZFaa@+Z(5TY0UhZ
-#fM$T'J1kV9NbRM8*G*[C,Y)q"A#+`iKf''j3dhL@Z)mSlMCH'B9%U%VV8&Z'`Ic
-bm(`N,,NR[@0d-bdAE+3U82P9FPIapUGjkT2*m6fVM,8cd!"-B*lKKX(m3UNBbKH
-mKe5c1j6TJG@e*304R!Llq%VEY#P*2,[4ilKJ'G5qU5fHaV%f+ci-XlTQe@f5pZF
-'G$4$EP56XpGdj)a+1Y2EpNh@8`jq9kDkfYE[Y0UIj25mjp0eGq@FPFZ&*&lpP8d
-J%l1&`I"Yd4F5aC5X3'Ui2c51LIr"!M[cBYc5-p*-#RHcAVa&(MY!UrdCIB*LaG,
-e$rH5(HE3TQC`+ec6*+blSk!NCZlpeC(4cY-MI9N(Y!h$(,N6G15RF[MG@'ZjPB[
--f"l9Z$EpPRkXr4c"10"k!8qYEF#QMJ1N,)T#,i@M'&C[mGe#4`!5Kj+rF*&jEP1
-a*q6c+IQEciPQCUp2EpeTNdN`Ujfq'-RX5XpJP(leX%)l8+q&[G&fmkkKhlZ6&AE
-3K#(Mp!"0Z#Z`lQEc3IHZD&Lk8[6`m*!!4'Q`qLrDQ+AX#`[H(9+!BV5XU8[ZdcI
-SC4P`jk2B4XG+2ql598h892j1U)RY4ZclMh'Nm94%8iHlPCQPeKA('UcmFKK429h
-c)',3J`)VGAaM!+kS65,SUIFh8I+ikmiNAI10)$Xj3MF[GLkKX%*NJF9+CNY2!r*
-cLVS%YP,$&S3F$5UIk#M2G#,3HJjB6(ia*!5AUVcMr"&Q*fB401pC$dbk[l%m*-"
-c#A1[BFPLI"LK@+qDMRF%P*l"d-3(92D`[DcYRjI!I@eTe6@50'6b[lpP8r4plf(
-@U&*k3IBP#9jjTD3E#H0NF[Uf%E&5qT%p*Dq3!*CXXFNi&@i-rA-GcC[c6&414SB
-AHk!h!'(06C(e2R+QchReU944dJjJ!e5kcCEdB!XKGl-i$&Ad1R0bBj1aj%94hmm
-kCiKI$H+L,Hcc4)bMcG3jaD9I(TTAe!P)qTr1a#)TPZESQXp*N!$E*+Q[DB38F$2
-h3q[h,X*K1HDa[hP&8GDbX+rL-*0AV+0-fLIm*$FM[#BKGKdU1S!D+$k)E2[*`MY
-A4,4pM"bjeZr&Jfk'i#cmfEbmDE0Q&Q*[MX+0j`eZk"1TXKIp$fSQ0a#1,6kkdQ2
-d&iDiVHJdF5*i3-3hiVQ0b2SmAmAVN3fj2plZh*!!!GSTYZ&mVBIQ3hQTmIFqZ2N
-&kPH`@!KqF'0Gd9@RS%9e,bUcZ0*JYNZBSipIjH`'lcaIM1q+3GmiN[THVpQiH$q
-&$'"9+,HDbT!!1&S`)jRf0ƜJ5lSiZ@jIBrEBE6!NCNRb`ki@[DiYBiYeq$Be
-a@r62ap&FIZXFjH0-%GFC+YhP@lTVqmddRHiP4HV`8106(IB*+IAXDh9PqN%`ePZ
-G91"&AEkmT2a)Y@IaFk3SQqa6%BU8"[F([*%L%h#Pf9!iB8k43IM2XB3p@ph8E!M
-b'-A4bC1+&)EU)Nb[59@S5C6(keG8M&,5+e5jDP@lJlHdEdM,JUPNUASZkSZ1Ia-
-PF"T2FEVY!fIa[e0@2'hiLF#qBTPI9q)Z4efHHR6E(6jLQ,[Ve2l[fABm$+[0T1[
-D0X,qpM[r2!'T'Z!3@pXapCG$b5*5EM*l@cbeT9m[RY1P#6Q14JF[S`&4(U-9DKI
-'i'a3[`a+ES-V"F#TI6I%NMPY,jacA$EqB2JA(Ddj8r*04Y)IBlH2#!XQp9a&L*2
-b2(@1LQq)FAk%EK(8V6iBiG-Sa$DmVGlKeaIqHaA!"4Smbc2MeP%ILFIK*#0Z$'f
-CaIA,J1brBhA,V9K4XA5(dh"fjF[MlBc(+l1@'')qZjMbV`R1@jjep0S2h*95"e*
-RF!kfZ&6A$qDIYA059bpb)9,AqK1r3Z63A#EC-`[Y(J(-e+CD[CUEf25BBEBYl02
-MMV6FbPbB!ZTI[4LG%bhZf9cqU@mke96AEih*kY(Cp)-`RJX$ap[EHaQA!mbN%3R
-r$MPLZBpN@Sbl-Z0RBdm5aK3U3aI8[h"XHN`l#kIZXp%r5HTZcYekrNe,8MX1MN4
-j`GGDBZeD4QcpfT('aGHB!QH3!0@4XUpaLNjaBZaVYL*[aBmDIk"D`aEXmLEpSB'
-+GrE01'Mdqf4QiJGQjpX2"DM(h-!G3(9BP*Ke#FP6bQ-DcL"+Ka3AYHkE2Ze@T`'
-c'I&YHrTr-4ci@X`U,)5hIhKKH,#,21YR-"Q549T&SHK)X%p-"#XYhrD%,f%m2('
-r",iLeXPG,jJKp!(A@H'BDIbVR%GMV3e&Kk[H5Q+#N!$J1KAmS$,9ZD9HV&,lEB1
-p)+c*HF4+&FUM3U$LSkT$r)5cTa,B(l@+@4iV[8(mKI'(8N,lNJ4T*pfk8,XhP*Z
-[(dp6mLIf`+kU[GV-llLQT+G(,IbAB-9("+X+`H4Ir6bFF!Tr1ZXU*A1GE(EAYSj
-Ybr)r'%"&5iKLD"2SD#R8X+B$5)Q@qQk&h`HacSbe,XVi,BlXrJlaM8C"i,BX#1K
-,[Nm@l4VJ&YiQkYCCk5a[1*,UXI%ZHJ@TNN-fU"lXFFr0Y@lj0*&l'1TF1$FHf[M
-cEp"K!F'H+%D*jffL&S9ej1ZD!%6S2b9KKJYpM@AGG`2CI`a$j*5S$4b6$kkp#ED
-$[GIRiF@5(*plia@FG`-FAm1SeGMPDp@pe19'ZXM(*,,EF[cqS'!Dl9%&)NmV(iD
-`*X"2Zid2GF!%*!(#L)Y4e#HC1!L13fcT,J(p-Fp0N!$2L-LN0fb!iQcDU$cldr[
-p"Jk+'8rLmDMk(8ce$Aa'M,AL#TYLI+8Y4qBl&I0ImaJh5Sm5rT+,5p04316C5[5
-$8ZZ8d+S,)PbBD9p'e(L*6l*fZYZcA1cDL,N-1VeJB&T`TDZ8QFB6*"4Zq@9MRPd
-EEAPY*m&h@N$H!*!!ILE@a*Ep3epF,,*Ae,VpMU9RYIa,Q`L@aJhM*aTq*)"`dpP
-0Y$1qTrADXb(#*IT$G[(cc2ac"J6plrE6bKVcKdL*Df9fDa!3-`bEYa)[&m+Ib5#
-%N!#*,5M&-C!!%!-5he1TBYm&RG[m[YTcTGY*P(MqiN-'0J9Bb(XVbPQq&pYMl4b
-LXB0[b8P-VVE(Y6BjbDARB9H-dkkq2MNAJQSNG1JjCm@amcX4#-0V0l$F#9I9%d#
-pph&-l&'(m-9%T@V,Q(kM6FjU8U)-jlX*C!HLPc1KS)T-*&V5PV)-REN@J"S3Pk%
-`P)mSq!lhbC!!YefK64qmU+#!1c"[TaNDQN3bU9D&SD!qJ3`Fd-!h(MJXBQ-Q+9"
-D5f&DDUBTEpb4%CYmSapmHER*Xl5H%E'2'8!U&N@4A`m-S-+`D@%-)hqm%hbYILm
-2bL`L",XY1T2@E+AL3`l'SFaY%Em$G'Pa%(H)CjQ%4pQqKm-V0MPPUkEIL#fRRSI
-!Zc%(pLl4V@pI!-AlL8PfQ99)kF(hT2R&QkU@Ci06qq,([RbM+1Irk`(#!9Xif#V
-h3$LP@rBq,K'JK%M#&Ffd`0EH#EH*D,&316S9N8Sm%YEIic()EkbeKpqNPhrI5Y'
-%Fl`RUlRNI2NNP")33'44ed'$4k@qfEA)[2ZR4fcUTR`@-*`Ue'JccJZJR*%0N!$
-2qqk5Gbhqd%3,-C6MX!('cXa%Y-,KCCEXdmP1#2T#3e-r`q+M&J*D$%B`p*C+a!5
-8LQ&kJSN5D6-&#Dq[qL%Ae@!)2cDX2VGCBlA9PSY)GF%'b$(#8+Qa`8iZr"@XQ5S
-jpE+L0&F@c`bXI9+aCNm6QQS4V!DEdSUVLN*Em0A!2k*@Fc#!Jad+$LVHIaK!U",
-'1E[YC65-1XC0-J2MR%#L6'06DeJMh)#[369H['3mRD-$DZJ#GdKEdl3NQ$"FDqe
-P!Im55*M5)JKB$6SSm(,BrMf$8Pb19EAkHBq3!#+"&r&[3lbR3aLG3ib%(@T-&aQ
-3!-FTS&E3eZUKNR$GI4jL5RSZGU$eIe%d8r%GUUR-E1+`E%)GEdMTV2cMA4-lL6k
--2r$"LjC-)bqMELfb(Gce%!ifq*!!Pi6T1IHQIpCDcmeld-#hPl(fAlA8S$3XkL#
-SV'XD$0r-U$3qP8YQi%&F4IK-cXcm$d8)bSJ-@jISrj-jL%))ML%TF@6&b4Lrr+F
-ZecAk-&U8cMqGETeH5%,B6$Q"R[R2GX(`)BD5MiQ!JJD-a4BAd@Ll1Z2(X4MYPCD
-k0dE$!'CPl99C)qpBQ%*+#%AJT8*V2T!!aFd[CZmbl1(-2SfLbQPSN!"0+4Q!G6(
-6%Hl+P5ZmBGpZT!YQZq0U`iZJa!jN+ANj)q)Li`RaY!Db[Nk`k9RV,1DNTeJc4G'
-HYR5b5(%,hd[F,$3G1P#NkYm%ZlZhThVF2rj)5[r&!+@3"!%!!$m!!,5KSlDeGB@
-E!!!e[J!!Jm8!N!0b!!p(MJ!$HBm!!$6@!*!%$`"8Bfa-D@*bBA*TCA-Zci!!!*H
-m68e3FN0A588"!*!2J!#3"d,"e4`CE$lla)K&BDBbZk2[FITLL&CcR+epC%hYGe(
-hM`#1qe$mAR92H%jj-)qQiLIZ)RdVR5FcjBB94`6["IYD40CSqi'-h*8TfI'HlaR
-pUL!hZ)+ra6*F"9RYDZ+8cl)`f'AGBlJCh#'Gjim)HZXJ-!11lemC[$UPq)bD$S%
-%#Q@DUb'-XSN"%cXL)Tp[$I[%ZaJAK+lJAKb0h&UC)Xk$DqB2K0LNK$YMAR41ej!
-!XbK8bPMT$,0)0I'd#A@PQARB0`-mbG2qj@ZL"G+FF6e5X`q,p%Ih5V!VEP3Vl@-
-@cZc'Yb@l%'R&!XijkKqkaYM,J`#'`*q,c#hYqBX["26MpjmpIX`,G%1L3*L+kVq
-S&(0UY%)G#-ip"B[5f2hpl1TfXUVe-2KPL[2T89YMK4dQEp+K8,F-D02(45Z8RNi
-11A6r'rBLE$224#BR,Hkl1I-1e"33pF6F6!ejb-!CfRJ5P"(mfe3UBlk,a6%+rmF
-FF(IM&HEe%S5LLEL#[Ua)U++c-qHh(iD*KE`d*1lIMLCqXDlD0G@MF`VT[&$iPXQ
-T-"i)"ja4F9X$UdK0SNpVaLZ9`LNCh`C*H4PPC3&La2%2,#6-,mEPRcff624GpSb
-"42eFc"eI,p[BlVjQl6SJFipb%N1dZZ2MkZ[5VmDj5qjp#8A8BK!GrZ`(i3aYS5+
-mreIq0L%[cKTmJRFj+@h1+!!8h--5bX@LVAj`3XL(im16T6UTk-!EY(ec1lhjG!K
-$U4`A2`[lc6+JL0Krdi4H03RIi@"SLDMF,6j',U#pNEX1#GUHAEQeiAC"DY)[j0c
-3J6,H$[DF&@SDJhVMk@GE@GREYXBq+eDYp%h*VlPVGe9+*q,GAMRk44VQp%ZI(V6
-0`VIU'TK)aVcfmCZ05dV50HN2E!b$@e!kaY9"&f5jC[5qI2DLIXep[X["eDr9P+U
-3!)@BiC90lM1ILGKBbA+)Sl85@m,IrdJZ1V$lYG&MFN[3PRT0pD(e$H&&6DAie&V
-N`5RHMMZ9b2RCq3[9M)R&Pa3q#@IHYFAa5h@[$$`0eFXD*T(HDCHLbLkTHdR2q6"
-Gr#24,9N&6LHdA1Va*$k@R5j!phS&HYfJ@aaf+R&KUc%YjhH)(!jF9C!!-)FN1C)
-,rMjG6qKRfhCVF%i4LP@3!"'Q!h#BM,dHCEY0lXDa9,9EJ!2VHereGqHH2)X#TI1
-,'$ZR(P2p$EFH+ZmmN!!jY'Nke-Spla*p@9kFX3LEA'U$1cIH3R(*hjq(c4H`paX
-TQ"-SR6i*Xa8)e6-U'`HXBh!iSjQ$em@$dhV66lS19epVVl`cpl4XeGLAlZpi23)
-!N8,+M9e,je3HjpPpkT0aMcGH0qDDBQ1&U"302Ea-QK![@"#"B+D9VA#c*),AJ!`
-R4c'jVjlKhj&p,D[jI$B*b!,CZpe,Y0la-iCCLP@JjeaVDL1-3b*!(F"mmL,316,
-1D1$(lB0BQBSceT0*FUDkRPAljK&Up@Cq'PJ2lZQYeHijKp-24qJfMKaT--#Za0b
-LXkB*6+Y+6fLG0Pk@e!SIFAl98@JkkH5iL2FkmZpm&MREA+8UC$d#84r,`qJT+Z3
-rGe+Y4VFDI!j'@18Re9(QR"IGp64c&`cMDK-HjXV)QS4j#hli84'0m,CZ"VE*j(M
-(URjAMqGD93er8qf[q!`UYrBCF`,hjjVZC`JYEH6,lCL+jQC`hfq#,V[LqrG,dq@
-AHJ9a,kQ0m)hh*jU9m+1EMqBD+MiTif['m#`I[`R1h#NUBDD9B$2d`e*h6pFNiB*
-a)p1K+'rTD)bB1eIdq2#0k%2MR2@I[lAXf*TiRHHriV+lb`5)jd'h'B"YXickcL6
-pB`LfKTqEA"UR,b1j2LG5JFNQL)(RBakd3L$!k6M6aCL6EfZ93@d$#-8a1$Ya*mS
-iC0AIEjpF!YK%VS8rQb9KpSU2PX-DZD%3)[T&cA%Vb)5Y5H+XY9*9,+'MRhqlG"$
-4@CB)0bc*@KMN0JHa2iG4SQIbZZ+lUbI-mU"2k*KMi'%EG+a1&!kPF$hV`5a*Ef1
-4dlb-a%!rFc'TKKSeEFZ3!&%*BB8i%34D+N,BiQKPQHVZVqcpF!`PNPBB3fpF"0f
-4T(bSPVd',e`QG+2j'$h3Eq[%e`T0F,4`YSm6J4cV*f,9dliX4mmM&,q-A!Y`Qhm
-er,NRFpF`)3FFe@TMcB)SfGSkIp9Xie,9)q+JMQ"eY[qBT!$C[F3`$aT"5#I*T5&
-Y#T!!q6'2Y&i'`J#0q6HleI@Yr(1MYL-1NeJaLLYIDB&Z,8T%a5PD([[b+QQV(Jh
-3b`5THQ%QB(HUT-j0Y2p8cX[-9'P6rckHf4m&Hm6rU(Y6m%3DaT%%!IUF5`p'53T
-M$SeF&p!ddGepCiBejJSQ[cKirTSVGV'%"66jNi(iKq#8RHaklp!@8PhQ!paqd"Z
-S0pX'RJPYX"KZKK#mY`CL0G+U(93l'#[2)NTlYJ5ZdZ3C34pN#iX4Lr-D'aGb)YU
-2N!#)*[Emq%cY&lTrX+Gk`'aQJDl3dHb83l1``0Z+f"rZpJi@%!ZaK!`6hGNhHFE
-3Z"`6JG9,)iSC1*NJC$(l%QRRE!'#FCTiD51,KI`1KCNmTJ0`bYLSkI+PZ3h4aSP
-V8lH*+dT4'p"@1)3((Car*"iS5M,1C5emXPiYp$lT'-riXi(qcS9Zb5'6hFRhJ52
-Z-4qFNhqS3dFdaeE+Q+ZJ4"jCUcDKGbK9L5edl'H$RL4MkKlqjBAC(H)GD&frNM1
-Xm1A0U['99hak@mAIam!mA[@YmqGkT)+2F1`S"+q5@46--8ed@e8Dm4Ld,*hf5$m
-IKeXN)IJ9p2M[SI(f*@T`li$G2Sa9PclVjq3,i(CVIqf'REpii8)Ye[k#F5"YN!#
-(F-,B!L&69rM4XA1$mfDCd@VE(0El2l(YkYMKYRjKmj,U-43SUb'$"+h@ke@qc!'
-(p6H536YB-GC9b2Rh"pp9`'K4!j+Y,%kMk(S*r1miNcNT2#-Ulp%keFk@l+GhP$M
-c%@VT%AYQEb6AIp(T!396MM&akL!Iefe'TGaZ!lfHr,i"l32mqeI1U6@eecKceXC
--*eXGT9AIlj6A1G``p%F&Q82*T3qS2F4Y@%a#+h!ldN2PX'58+brlLM*DDK)%(DK
-!%3VfkL6Z9cI#Bp6#FB,GeQ9aja-qiCKmHTc,d(5UYU%B,B@M%SPJ)4pL'XRJ5@p
-90KkrqH-bf9e!BQf"Dp+TGPA-3(Y*8d$52YG$35%%@m&r`KAK$H2GYKKlJTBee%b
--brj1!Bi2Pq)-GHr@JESNpV,Ah`PV`-UV`*JqJhbXbq()54@&T@%$BP""DkVkjSk
-3!$fl[NT+5)-AkJ0)fh`l#f0pF52K62lM6++0CmKX)BbQDf6@M24"mh0-e&Xc8Y8
-PRJUAK"di)MHEJ`LEQ*Q!,%+$[jpcE6$9Ik!Skfh9HkbY0'NY@BBAid3i$lbY*V4
-)5UHl&k0J*`UX-GhiU2plGq)ZJa5rh%3i18EYMXGLeQ32)U)4GR'5'NCJe5"2LH`
-GDhE@a1fJD*L1!T!!2i[qXL3BAVPrP*5&)+`%a1aCZ1"Vl0$dEUlG+$pL`M@!bcj
-ST`f[pD4#2"QX3UZjAH[&DI&qc3!3Ir'F0ZY%+LFB-i&QH,@42Ub'F4`ABeU3!&9
-(2eGGA8m-PDNkGk[I*D1+cZ(NRQ+KiGB&p396p1U+ZqITYbLNb*AmP%J3CYBcl&'
-TcT6MqJGMbX9VESHSE`6G'Z5H2a3YIk*ViJU+j0L1$(aK"N#15`,GZi[lJ+pR)`[
-hV,d&YiUQACV5[Xq#LRD6ilV`Y5EC!'qJ2,e-i3jT5,m3+BNX$TAj$ck0`l3B2bS
-LY@HCXQmVLXl!(KVCITFCEGl@0DfY#RNZiBc$'S,`lAr'NG[E(,d2Le9@$d2E1`V
-ZrR1DS[3N,d,6m'SkCDN'!Ma$l@eBTFiRqY1cRU!-`r3jeHKbhl3elT3+YX@Y*U8
-,i,VC$SGmYX9Q%mp-[b[T0Ue[f3$'A$VA&$T8$k[XLkU!+AY"M%(iI4!T3S)H&c6
-`h!)MabF1G6S#`,MUL"U)3)1#[JPEG8HS`&kl`hFRL-%*-lP%K,)!Q-D02bd!XC!
-!p1pFfaUeN!$(PSekqI"GeBC4%!',"Fh[Gdm%L+j@AE-TA!@Xj-I+VZc1Rjlc5XU
-Nm+($Ak6BPk0NjGbMm#i4UE1X`X4!ca1&CF+@%0T5I'JjcD["MCZ#GT!!3(0!&(2
-J'!SeCk*BI5[cQZ@4$98q)0QdL5T#VE&Z5i4mfh(0q$*$hKBPU+c[-Y-&dXL'e1B
-(pN*5JQBS#'(H+,lPA*@!PpcE0D(kXHj3[0H-*hKqcQ3X,ArU@VQ4eD-SK889h(M
-N!ZC!m62)Um5QM#2kC*X$NqU0KJaH@4-L4ck0CAfIm3"rp"K8PQJ)L!*Hbjp*K!I
-LGPiHT+N$a9DD(qD'j4[-I-jYj`Ri2)B#Iaa+q,25D5$@*mckkG20M-`Uc%q`c*P
-#XCCHBP"+3lq#XqC@PQlGL&[iRdeeFSS,08Cc&M`jFf5$EClRX5XbrA[fbc59Hk2
-5"2KTpTq8,(N(V$)jHK@BA[fi5%V2`"!ea'U*(&XF'#)C8lL!p%e%MU5dq%9lNaP
-,F+YpCZifCiDCfD)G-9A8l#80SjCl-h)K`hlMaJBUbmcC9kK8-BelTShDQ'3*H[U
-Pl,A`l0C$[GmG*q6c@[Mb,8Gh'C`rDmaC8CT0HKF#c,Y`GkS$X&fN#NlFN!!P2"B
-`E$cimC[ppT%C)T[*m4h,ENl'FJ6ZKTA[NbVD9+8#*aeGJfVU9XDFL[*l-)&&(lp
-9B(i[`hjG#-8#De#+)Rbh-()'NMB$fiSfEP,%8KA9Zr$R#Vd&A#hlC0ajL,(ZY9D
-l'pdQ'RZd1Z2$Zei!lY&ka0-2G`J[B1XE%X9$H8fj$QL!(bNV9F-D3#aBjVlA9CZ
-9e0bkDL%1Rj)2655I+6Li*'Ma*99ZJ,Gj1DjDVG-@X*Hm`H66,T!!iFR+NXP"QGq
-pea`T61T3pXdlFeaN*Tmd&lN"%(06"%pKci3rC#+rbp2IeQ&VBEV9`6'E[2rUTf@
-Ze4Kp)ejTpM&)ek5k6l"cUPq6BL'#9&ZNTkRLV8LT[-j*Zc8RB(pNZqbZ4eKkf2m
-3GZkK[B$Ch+'#T*%&VZ$ACdk#9'i"[ZBZb-DP5p-3Be-YjLccA"42fJAXH@h6XAG
-&jL,GGBCh(["ij"5K&R,1QfRSJKMeLYa,klfU'`P9P*XBR3DLciG)'#L'KrC(p(I
-VTmVm5K+HB,PaiFTr3J"#TY+Y0E)Em-4i!G!#h1mCbILT#Ndkej-jrKC(kFa`6Lf
-h`L%(Ek8kai0VfHC8N!"S3R-kim`6$b+U!llDa@+SkCSM4hY,SNHh`[,'hd$$KZ2
-R[UElHam[fHd)fE3H(11&Y9,)0d1!+G0M+!*SK1eX5IBqERGS@e5%b1eMX(rY2AD
-kR8Lrb3GlYqpXc0Xr'ZbicBE)mm9%NG+5DB4c+J'$8I8Z9'5'@l0-K$GK`MV(XP[
-QJ%V"$8Gq6HPUm4$3)1j,'B!G5$)%frYFJcGbr64'Z01bQBa+*,+eRdcKk93mDa[
-JSd1FKhTUL2i,r**D*Rqqam+3!+6JdX'iQ5dj6&[UVa#%466miQMQIf2La*TE6(T
-XrdY-!aZf6)4@)4@qGeGJpHVU`NIp3MKZAVeE6Qd+d3!`'lQ6@YJD8G$0[MqISPl
-HYR-pa-j@Yk@2(C&[pZ2QYCUTQ0-kYE([F"R2JcaF!Tp*0hcVjj0pGjBSbEL)f+b
-@h#QKcp2(-QmbU&"FaYB#H-QfMNDQBkPHJ*28FSc&B&akQ+i3!l*ppS9FCGTl&K-
-!q'qd#8raHMce*LIe$*ej5Fq@pGcb,"bQ4M(MZ),1M4NB5MUNq4S`MqJUU4BZ#Cb
-9-'C+l2fF&AZ8lhPLY5JZkH+q1p4!f1(aZ3m#4mrmQP*P1d$f"ppI(c1lqMB6"Z1
-*F@KV3p6(Th4BbRP[Q,Qbm3$"FqfC)rM6i)C4(l8VK)NAeDS0JMd`Fahk$lKU%@E
-j@h-@)f!qjEDUM4pTJUKiXJ)28E95KL6HS&MfQhIfk0)!f%RFq4M&YKQTkNJH&Jp
-`N!"RZb!H2hc8L-k8bB"%K9X2$VebHV(FN!$TeS0LicR!Fj(D"I5,i(GiJ))%+4'
-bM9Rr!'G'FXQ6H51LM-Q9,cm#cJZrpFHbqTS!j9P+pNlhTI+"I-i'5k+4&k$dP1b
-GpSZje#AfI)Vl[E20a+lJ`A`bAdB,N3`p9ArAbY0-fX+Kc@MaL%qJM%20,$@3!&C
-)9aGL!IEVUAB0KR#mI[`X%2Um5@@'CAGHUM"KFmD!pPbc,ZU*YPSiKhF)HCK3TBr
-4d%ec*!PRQ2(J!SUTL@A,M"IClQK*rlQ4c@0@!MJiR"q,3&"mIA$9c%qcC!h,b`G
-!XPV%19&XKYeX,(ZY&0Q%IcYF!hmmdX8,5Lq9KG153hf-LJ19+NcJ2PIGRj,%LIr
-ee`ad3"b,1XUP,*(p6RC%jm-S[-dKdiVGrYN9@c)qd2Q$,Hd$LN1J@Qm#CNCQ4)S
-&r(ZADd%*X*dYYP+9K&l)$j,!eVicJ)rB"QThNIVda'ah$&28-HUE1jNZ1[DS(c1
-V@[T8lJb4"$VT3CDB&*DN"rbF"3,P!p2@9pi#e%C@P9S+GC93K"FFD(4G5YeRqbC
-h[2H3!'A!G!Fq+USID,pjGi(p"$S8STY8)0K!CU@p&`9cIKkE`@8[&@&eUD0X%)d
-6ES9+e!HjF@8lDrY&#Lh&FM@Q,@XMdiQE1N,YRZ!5[0`,2&)#N!!HJ-YN5(DHifj
-[Y@PUcc)h%NDUaMr&Iccd5NdD5`fpTP%Q1Sd,6G9BU%em)5SI[)S@0T0c,)cFTZj
-MQp[!M#HPZ#bJaRHY61"(iTqI"qER2LQbDl!#TpP6P0jNd,+VTTY+*fGLY`5h5i!
-fR01qYCQB1[&q,Ji%6kd[384#l$QkCqj9HH3dPNa8bIlV6-0236G&!KH(GDQUl[@
-6I1&*Hr4&eNTl-PBGYc8V32Q054aj3`L,8!4'KqY,RrGKCe89dkf2,UUJTD8p'fH
-EjBr`kkVLIlTZZ5+bLI,V%'mPp2Zl&+R@YaAV,[JTL9`jk5$cE**X1$lGr)J2p0p
-4QR0#@(ik%Z'Qj,Ee2+S-00IK6EDNAa+cFC3"49P+M5`haNH)F-L"YkddCA[mPRH
-R6P)Il@1)AaIF3r-heJiRCP'E@PmM)-l2j6h[aVeQ32BU)Nd2LQhhNS[l[9S'UE0
-[&hG,`$dLjFYrbK6,QTr)Pi@c8$RIM40a'ClTbHeTRm(YCmNq!0`"BB`mF3"QkS[
-1G$#2V1BqI-K`GF65Ea@)*JdV(c[+%(&&3BkpX$A0p9p`ql@2bkrMclKF0KVD*X(
-*J"!rUhm,cSe2MBe+2Q4#QhK'X-$NM2%DKfGEGT32Pk8AYS0rA!d[mdm%q@LBFU%
-Q,Z@Q2$3)Pler@rKR-9JQ!HX@3bGE##2iGhGVZ%KJQ#61MeD`J[ac2J40UH8ZXX[
-(DZfH5kGJ1dm9Tf@Y(UREB$rkYUCQHpm-Pap(bF8G-GjXhTql4A+@%i*D,mlmB5E
-96[`C$($F5)lA)h1G!!L(m5%GdSRbD1X"$`j2K,VHa,8#&K9`NR1NrjM&00e%AD'
-'eMm-'b91P-FZ+#M6GPT(39TX!J"p21pqmdpILD`GEE%BBGEb`pDQjrbAFX59QlF
-!mj%c#dJq6i+E-#I)J"[1kYQViQqcF'fVM0BJD@G2+U&Z!SiKd6re!ZpReHfTmGS
-+hc90T$6-8qH6pLcUYJDTYM9DCbLbl-UI+Hj&D&IATU+9ShCZKU$'i*HU"ppKPYI
-%pcCB%R15kC3UP)))RjAC&VFr2Y1i`[BQU$95#q%$[r-jG)[,3"9AVN2XM2Kicd9
-RkKqN15kJ)"RN&N!TDFSJAaH*U2-IqiAJLSlJ`Yqd6kHf(JIrmPQP"MHm1rG4+UD
-kHmN2PNd$cEVe&U-1b&m*rYP@S3k2+4)PcL,0`T90r*X[rLl6hm0$*CEDA$fJ$NN
-)lS"'%13r2iLGT,Qf!Q,*!+HM@(ac&SGX3pECUkU*!rBX48-CaleRd2VrjImP**m
-'bDVV)E%1NAEH2JhReU)qJjJR@K#"HkM1,UBQ,A[![b[9XP1SQDkhid6JcallFmF
-SHbA35EGl9e)LfbKUU,IP#I"a36hI14RLF9Hd6l1SK2$XShB#&aq#"ikDMr500de
-e'c0fqG9F(85(rFd63$&[GB(U&0+Z&6@CmVZ,%LBU8c-BDbYr`k#SrqrK%#4bFAV
-[NC+3!)JN!H#S&3,I!8H"ZYGf2EYY2dpU3$XE)JGi()CHdm#ke$l2``)%D-TJV5'
-'qLBKE)dm+lV3`$NHBF&l&SX!h-5L&X4a,m"IkA-SdR"02qMDpp`!)I[%3IV(iJc
-eV3h2lF0$b)4-XY@Y(b"(&J)KQ3X1S"EXXKI*BYPM`*YAA)BVJ$!HXB#1ITcV#&1
-9!mG%#!dXrkV@(ZGhpbFcES!$$P4[Y9BNVB"!jK#HGl'X,RHrrFrNp`qqp-T-VN9
-N*4F1)ELfQ0'TL604'GC&AZ*k)aQ((j!!cp[Qc%2)b&(cdXRZJSG,TCTLI,*52*J
-DqY('RmpaLcK8Fh@'b2*KG(@1D62e,@X"S)YTrZ,QT!"$kbKq+6(`j6`q)XB#Kl+
-6Tlr%FUY-`ad#cBQB"V``*Tjq!+d+i*p[R%2",bNcEep9,"i%9F$kDej`Y-,`6Ll
-"5%RBfhT(,2c&r&5r+X8q!iZE#+"fC*f!,HN@c1$YmAU,4Yi&`i3&"-ZaU-6%'kU
-6kTXGp%9G-)&IA,%fckp+c*cfA6%)frXqVUJQbi"P0i0Lb"lDjV`(kqLCiCFVi`C
-Z$!!MBVBPeifECPRUR2hU6BZ9lhGqJF03F+PG`*V%Y,Qf'$BV6SkXMM!0A00hCj2
-`,fV2R["6%98F68Z#k2$q[3IXSEQPh)h$5'5@Ak'ZS,ZN3rZmJBL"Gk)S"TEC!b&
-(-)KH*&ri0ADkDi30kkR8flX8L'5#ek#aCSf-D[jV%lckrVA0b%#T9$-e!LJ0pfT
-"EK&-Z`G'QBcV4DJ$hqRNT%chK!bp6YRYGVC5!c[j"2m-,"bMN43&B*BqVMQFeNl
-6e!BTMjk,LRe&E[,8qe,eKj*Zd&0mjl+J$,"VqD3Mp"4YYrFLdb&IDr$bH&EBQ$a
-%N!"%T#-S@P*aJQFdY+*,$m+GLG8e-Q#bV%"VTljhFkhJcBZ#E`kQk5@j`q4bFJb
-h@Z[$APY0b)ZRV%c+La$,1dK-pDHQc%&iUCJlVfJVh&@8!)c+rhCpdA%mA(M'0YG
-Kj81f[c3f3YbN#ICc'@X+TkI6#lbj+aKRHHT'fTS9*4S*IPkR(0FN'QTC9J0$+qa
-3!KNVMV,6IQTD`)6U'rV2ENB$aD@0pl@KN!#1!hbeRZ,U9mV5Dc@"9M3rUFLB$qm
-aRfM-rVRr(NC,B6jf4CCrBY5%PTil8cI&HKE(Cq*VR$m%1QPY#m6d@i*!S@*8ljL
-fIQ5RFZ"GaV(eDm&EN!"hAM5@-YMcl2bj*2G1c-eMc!QAIfj2el#50XUXXVbC4Pp
-YLbH'9hLGb6adVb1JH`kD1"`DZ`GUD3iIl5VH`c+(90-i93'09AX%)"Lk!LP-Apb
-a"dRM-jHQY,@B`aA4R%$Q,XNCmY2Rm+Pd@LDV!bmMQPTDAJm0bU,GUA#c+f'Aa(-
-AL,SS&c8Nf1+kP%cBZ&eAb8hPEUKBeZb#YND,XK8pkTCJ4R*a#lBjri8)mTY!l6e
-Zmi)2+Cb9)PeZ`4I@cqCkDkIFJM'@Nk-p5288C3",DJI0l!N3Lb(`kD&hN!$ca#5
--#lEA(f5J,pVbe)`1rSm'$CNZ'1[C3*a`Pm+YpKH5N45GBUmAS-!ZiUYPGU(kV%K
-Y$Gbl5H30Vq&k[jcM-&DjqielAqiZ0LNLX$%,5D"JKN*La*YpSfLL%4`ea+4Q1YV
-m*FLd4&aS%R-D"X`HreLVTfj!!'&mjeJ%9818d0,!d*!!%AjCh2c54QaDYq4I8Zj
-'qeR(T,UbV8aV#a20%R,Sra[Yf%-N#J2M8M49&[IJ%IbDc6NV8,S'p%`KiMIir[9
-DC`c8c2XTf4)e#eD'0*J51Je`XZ@+eYdbh0GELaFJ5#U-[8kiCPl$l0`r'r4JbZH
-$3FlH)f$E6[Dm!`hdce'PNC'LGGPERZlXJBJ-lBI2)D+m`(HblURl2NUQ@8&R)K(
-3BQB8"9)H154kR(e2*EdUTL)eC&41JmR"mSl3"&mFXJ90PZC36i-`a+$PJ#@!K2*
-cSRSkKkm33NGUTdXPq[L8`2AP%ZVUpB+j+D`VM(m`N!#3!'UJqKQ"D3G&@3mh,C@
-Ah2BjKTBD0&2`UY*j!Lq19m(q2&h,ep9kNXPdeNr!@GKI3fkc,map'1-E2j8Pq0k
-SfX+&MDKT&i4VRL@drQl(iMU'0$R&BQUIDRC*1DLbj(%mTH85J42G-ZMd08NeS'!
-RAR%rDlPJEq&I#BBqd1eF53BKTjE*UaaSCp[X!T4'iJ,-!(#df*3q'MC!G&bUkiC
-UbjEk(!,c5LfZjFHdb5Yl'Z2rf`V1ah+P9E,X@C8%f0,G-2U&3LSR@'$-VJ$2kQ)
-(pCX-@N#*H14R46APl2QrV)NDSm'q#UX$$M!KALSk%!$bJZPHZq2X+0-Hl[J*YY3
-V[Ib5li5,IkXIpajH28V!MqbE`rjdp8XS1mRX-T@R'*UY!-Z"j"6kbq4(E'AF@mC
-RQD'G-HcB`ZbH@6L!1*)cjqDqqlYbKAJCmfhdp64C0JM"NjSf!8%$h4$)(MVfV0&
-V!lP[`SfaATe0pX)`8EM9pKHD%f3l#*eHT2505h1FUB`9VRHYfa)$lCTmb,A5N!"
-cVflG9Z'f2PpYUakAe'KmK08"'3YE2hpm(`*l1N`CCqL')kieeZ("Dq$`GfDaN5R
-jX'"c!*SR$S,E4F#!#Xbj$0qPP&G&b#AL,2BP1k3#eNLXU&kIDA#9"ThGMIAS+TH
-)r,A(ATF4jFN2`EqR#+Ec[83j0TQPb%Y8+8a-K#TQQ5,(3qBMp0)Va6#$C6D,%Rf
-LA&T$6GVMJ58NMM2PPSL,*BIUi!dCbSmSdkCQKG',h@*@(cKjm-9$5I*DqFHHef'
-@h`!+8NMfmkAL9)-eLZV2M`h)HGNdL"QFMT5h6RQE#CB5X22a-@Qd-f,$Kbfb%X[
--"*N1dpQ)1Z-J0VMiUDYJMh%c(#X,Y&$ma!D(AYB%VX"0IfAJaGS*%8(l#N6AMc"
-hI3Jb-&"+V5IK'#[`+TRJdA(#(UA%G(YL-())ZC26hljK(X00Tiq$#Sr-qNAI-Ak
-,eLTRUc8NHNAiJZY@E[E`[+UmVNCG%%A,@69CQ4qQDj&P!,qkkFch+99dk+1##6J
-4$BTE0*&AafLlR,BcSC!!I!h6Q,kbK4JQ'5E-(jBM$Lp98$K*8,@Q'N"h$&ir09e
-lGUh1eh"HN@KdffcSU,+!c"Cr8lE#8j1Jpkj*JplDX(M1LpJG,ScYGISIBhZ"YC3
-PGS08X',Le[qkpq[f`!l@Z5#+dbBURQ1PJZ')lDdF&%HpdCGE('[!MkIXCY1e$5p
-LK9[KX0jFj6qGZ4m6)KHl)+TpMK2YMGDTj@kY5[k"emBr%$'0Q@K,!bEA$cQ`"Ta
-YMD(JNpk3!"!V81ZI[DVI*h)kkKKI'fr2b0)L0ak!IE*L*PXp(J3qb[4FTk"`NJj
-PlI2`jMphA(-U[Ecc2"4Ci8bM&8&H2rXpdm"(q@(F[hU"Ah3K%4NfkS2iQMDZ(di
-)'UM1Y+9kQmVrr%-[IUTm4`*`QR$)D@5U*Me[PeV66c(IQ4S#$SHm$F`5d@rTkr"
-)f%NpK6Za'!h,M$iB*-D0@mR9l)8)4IrF6mU6XdMR#m3%Mr4&JTqT+2VGFN**D*!
-!`M@)cU[q-EYF13-QBiYI&Ll+Rl9Ql@jDmdaRIL5Te-TcpG(,KMFadB1iIDDpP(,
-Ypl"69CEeTdlK$83m0$blJIL)8eA@Qd+25FX#pS6!@6RViT("Z1qJYBDiI@,pS$D
-A)Qe*%SJ,RQJ5iqGR`e66m%QhF+LZckZlFQP9fh+P&2f!0bP%D#d!#HjCTj9+8d@
-*19SlEb[V#i8(ArXeTaIVZ!YX`TU#4cME5)VQp9,NPcaGQ-T6q&*&BX5LRRDXil%
-[2qmDf0rLbCT#meKmi&*2,i@IDhp&bf$4r#S(-c"CHXXE4!9i0#e9+*5S"me)6IA
-4+96IqNMrX%"[X0T&DDV2F13M)@[eekIT"PSLMA"EcKBeq@[EadaddGP'c'cJTK+
-pr(bk0AL68*1)'RQCB@L8(TF-R2-,kK&6"XZH3Hjh!(A@Mp!P&PPKh@(YAJqY2+D
-L4QilAH12$CD2EJm*JmcV&JPh[Hf*4U,PkR(5P`dKN4,Hh'6iY($QQP,!$NTr*`c
-)RJ%jE$c3l5VHGkC(Nc%Qhj1hE&pZ@2k5pkQb2ZAiFpNmp0A,f"qUY8'['+p!
-ci863l,qqpk0q90GYpehkN!$(61Q`MPm,$PZ$l!P*ZheUl""!$a%I#5pRT,8eE0e
-85Y'FT"Q`K+T0jiYTdSJe(ej'P1*(1SaC(@Xl"")#a'`ScX[B2Y9ZFZl"JZ[
-Xk&[68J0$NbNL3erd'P[j(fmVS4)+,1VNh(3UpqmPqM)mH24&4m!5(9X@I*c+aKL
-(D(pXH(df1`EIBT3U!H84!m#SU"f"pHejeAXGib"KqPY2%l$NFdCPjEYlhmk@TDH
-K5f*T"5iEc31,@IGU-j)aYZ5eTa'!GeKYFla&lhFJ``K-BFhkh5!%G"(0Y-rMJ)C
-Dal,L9$5lmb6Pa*PcHHMaq`5)@6E%mJ4Db)A-R!5hi%hJrZ0UL&)Dj@f86ZF"1LK
-T!Fb)!''0fiB$lmaRS2"pB4DHbHrj!KaG@G#2I9L&h0R)+SYa#SIMa!(bdACF%h#
-*9i60eQ-LB0UQJLFbip!#Jm+[2C9%cDK8r*))e1#(ARLIiqT8j@Bb-c+P,`e"m$H
-[,64*30Qe1Q@4Ja,Kjd!6QI`ba,!(D[EC*AMX)kQ8,LhmqkG'fRi9Bp$9S8F&bL`
-%-2PBT&E9ZIFVHfA&4MTp)E38"CqU3@"jmr1b8kL8Hf&'PbMYUYVGjl@m1rpETee
-l#ki+[-e!5kb`YIiKN!#e0"f+FDd[dI1eRLXHR$,b*Gf-%X86Bpai,K,9+4946Pj
-fTS3K$B[F4*iP-05BDZ1piL9pLTLmh5E9Gbp,5fQT%l&4[4IhK4jD$+fqh&cXV!"
-bXlCIR3d3a'YX*LicY($6!d0Qd$FAVHf!$rM024[VeAa%MLeTTG0Uh6q58V*#MSr
-r$eP0U`Gl8LmGqcbQeJj16eBK#FQ&95,KIK2ZbT[r008,!)"Y#"q[3""NB[5`Nke
-K3m+1YbjBG#aQkA0bXY!Z*l!Prp2-DAb+`El6*Xc5m$r$S2rrE&6p0l3CMFK#AKm
-,alDV"(jp8Ql0m'YkQSd6j&qLLFq0+8p99kK#)eN4L4A[$Q*5+RCSc"!&8QAZa!#
-P`"#Pl4'IM,MI,JQ'ZAA5lKq0j63NNG%Yhl31cj4JqT0e&LRcEH'bR0!KlNbr10$
-M$AjU&NkjffaH"%2f(I*0H6J',I8kq$j!TD!SibLGB[[Xb`Rq,8$8f+ZU8"6LkkH
-$pfJY#LP*UrD`35fMH,Xl#8(2mDqN8BqpATNSS--q&UZ#J2)r(*UF5#3QIKc3dEc
-J&qGd3fCYl,#i,IH3!!a8HYXk8a*cUCTb(BjpSl$Pr)h4'lE1f%6&R!h39BY0UY*
-fYh20JKNhARqIDIbIe5E*)e#2fE-%+aJ+6TN5S[bdj6+3!*MN+KY3bpLRYb5&@-R
-f%eY[*5X+biY6Q+cq1GX-@U!ZP3mMC590#a"bK9hUmCp*Sm[@)r8N2TMRD2Em9"+
-k"G0*0('-(F6@1JB#TCDjfiee3miZpB*L+RXQVMe5T!AYe5!"m[*f)iq+j$8Jp!p
-,j3@)C,ALS#bDQ2(ABFEN[lT3i'&Prl,(h3%V6*4`DYh)M"59M$-BM$3@&4`R1Nc
-(4de@@%AcmTee@Aq2!%Yh!`DeVBjX(4&5(,[AKGmiPG*pF1X23I@Dm,hq&-eZcF2
-h8K8dm59'CF`"B(N@',DRR(NSKT9bValF*RhJ0``C09m*#-,SE$2crCdU-9Fk$L$
-XREi+&['aI0PSY6pUi%M"+,Y'EUdDdlpdl9kq32b#eLM9QU"&C)6aDZURMp%VFi+
-U3D1!&l'hFBc8YeLkpNk0AdULA3NN&mUFIPV$d%`)eI8!R%1@prl4XN331ZQ$p[R
-`1D5Y)1+J`b$q`ZYIl@2il'8%#$p"m%`LFmlpI'IpCIJ%N!"j"`khR%Sq(YZ*h%q
-R(,JJS*3'M[VLl$"95**$&i[frXcdD'GAF5GT&FiV6`@*e[K%1K-E`kNVDpIDp-$
-HLJ%CFH-r")4ApD(24)`cCN[bT4dHSmM#i#p2MhKef8EG`UUIhGY0FI"Q&m!Pqhm
-K1q""Rk8%@DeNTM9"q$)+*rHEkhi0$&IEfq,5I@V8BUFaaNh'YAaKJQ4N2BaU@H+
-T!DDQbAiL`R#+Xe8XrU1B5XKQPe8*1h0HNNQ')lCkpPa,IKcUHl5k&$(H0Kc%F6j
-"I6Z8"jVYh8kA5T%Imm0#lAPY&bLeQ[`A$@9S91h$@EZ0VFNJ8[&`k1r&92VZ*0X
-rec'6T,Ylh3k!a8Vie3IJ3FF9[e5D%Xk@GT4B@9N9b%HZ8AErjKKemTN8(Ai2&c1
-JKK9$D6K`0J3@%$(80TESTGd!U*!!l-SU["qm,'F*IbK')A%)Cc*RC(RM@L!KNLi
-$q)hLRdR6@I%K*Qc"eDSf[94)ZkcI"PfEl!Db`R&4b*!!1cZ4F0-Ga%mL,SIQ41l
-60kS%6`c)a',5XjjXchiaJ$JR%+iAHD1kE#lS*8UcQ'#Re!V&%p9M"0(aq3PVi#6
-T9h0S(E+1VGE3fqAGFZ(RJ%[1SZrG#L"rPeE-9l-DL9j-kBBCIFr"3,*+l`+25!6
-q+e!CNd1bLb4HHFUe5$JAqTa1l*(9elQYj2APE`rH4aG5KU3KPIJDFF,'bT`lBm)
-!B`YHLQdJL)[edi+YqbrVeB3"B4PAZTGP9T!!8'%-4mD&Z#pc4QJ,)B+(j6,j#kR
-&22(ahMG,9$Nc$paf1M$42kXZ9VXQ)CS"Ih@fQ`f-piKGH"hAGlGMfFM-CEEfR9&
-QR9%kchMmKq'X435*!'MpZibG8hl5#Y,q3&XN`jQI2&JaE2)@Y,fF$ibhk0X`m9q
-SKXl5$dGh!XPlCbK%*Yr(546Ae&KE*@*q"ZQbJb",YDN6Xc5LfYqBBUmjLN,T$&8
-rDe`jia2[LMB2A$%,#&13!-q$H6DlmadrPqGrSj6!-#"NMA6LEQ9AQTNYQ$*E5!Z
-eS'EQG5rj$B%$B`AAi`H&DmTVl$mIZMfeD"XKN@N9jN@)hf@`MLpC`FImdf$PKpH
-D+%(S[Li6fM#A,C!!!Rb9!(8&FjllNkfC)+9KJ)#Ckj@"rXjjPSZ3!&e0FQV-%X`
-Jl-5d-h3#LZII85URY+&Fc!mLRU2qbJAEP1+DFPT%hE[SBf+JV9281b5YlSM"4Gf
-3!0A6XMhpPdV[6D$M6FQL8$BE@b$+Tdc%a"B3PmfMTq(c'RVKrX[)ai8E[J6hr#'
-k`4L#b6kqhqPRV!2@(B`dpam-Tb#!RArMLe9Z5!'$[1*b#3UXU*BT5ck86S2#1Y@
-LpUblFTh$fl+RNp*ak"m$r@&1BMY0Uf1$J`V5Q&Di!TM!kVdB1-8d8@I[GJMP66+
-Z`qVRcRjUXkF%SSKpYC(#@E6aB,19U0LARGp+"E[fIUmSPHBTpAE2DKaQrmRXj6M
-J+E,5c6-pF$G9@6$3b-h55qAi-Pb(j[T8!0Z0ZMq16@9*`5aEPJQi"9aEr!0"Ed6
-ch*!!Ra)ddFMJ1,Bf@FUP4,U#%KUN+)[-NQj6,!lC9f`i!Kkk@5EEl9I&a`)Z,Np
-1VQDRqr8p5ePe)5@CE%bfT[R8U$A9PIa(jM*9B$lB5CdfLZPaQNDL#8MYSQLUp6h
-c5TrrR0VEL3E0b1'lFlAfkR4ZrZ)2*(c%Y%T%N!"SdPXdMVI6&HEfi)FNPcQ8D,m
-KlE[2`L0DFYYCZH)Te,K6&f&f0p3qGD'8@ihZ2K$DYe2fq(8r@fS['"j(ALmJ(dk
-!kL6Z&jqaSUQMX[K1)Ic,4195T`TerF14-f%m3SL%4mM,kbihAd9SHc3!&@Ei+(V
--5LUdZkq3!%UR0qm0+lEeU%4m)4HR$r@eU51$Yd2maVKNlM&'l90k-&8$NBUd'6%
-Yh'+4rL(p9L0h)Z91rYqI*1"IBm!j[")&AlL)0DY*4jp(CMTm)p3A"'PUD4ir1C4
-,l3)cHb25c6QYT#)AhaCS2KKIl9-Amh0XCfX*dVq8@AMae&If)j-FZ"R)MFG@ZY8
-ZMJ#%DZQ``U1+E6Q)M%H54U*LCY6!4`AFV!E$FR2h4,-E4#8M2S6r1[cF,HRZ")N
-505U98k1@`-qQrU$XpHme$6UdHr'6TSX$60,,((#d!&eH#aHfT!!X$kk*Nk*ZGA'
-``&&K!"N)8[!VR!e'f*rl%DVITRAdXlp5k0'N%K`kX9L6QkGYUX)AmS5EFZ&H#Hh
-cda"`ArZ[iMdJjIVKV4fT$V*mC[8I,'&j!C,KjZ@%'Gp@mXV5r0aTPijN*c-&c4U
-3!!mFC!d*Jh,YkZ,410q$lC*kHN'cJ'CPi!Y"6+UK%05H0BE#0qQpEBKGhN,MMf0
-epR!rX*e-a1q0S6d*FNYkN!$E9lDYVB4cr`lS!X$lciC#+RT+6!'T`(f*`!RT-X8
-ePIQF8VM8``bpkCRE0UKFHC8k2r(eYVLR!@IL0eaQ+13c&S,'eeBFP2CdB"FmRqS
-c,rlVfe9V3ZPJ-5rm42ZRC)MPRCPL$@XQFl2EYEHE1D@4kBXAcSK$LJfRYZLmQ)2
-48-1"+RH!@Qe"-"3a@Z@YS&GH!11Vf+9,PYR%kL3dpElRT55YpqcYKcki!#'9JQM
-CFVFEpY$kIq3rQ8Y4fc6IfjF1ca)K4R[e0cN*!aTe3S*mrr@)qdV,DeNe3NDma9[
-@BUdLmGfl3-VKcq!")LVIP9a6#B#ChAYFilrF&'8,5KNCQM*Y(*!!(Vi"YA`4fY(
-%&EYqH,4M8XipirCQmBTmh"*+N`96hlqC`QB2A`HaeN@H)#iKa"EB4-A)VE'hmIN
-aT*JTj9kD-r*6JjCAR3"JdbJTk2pZ$2QAPYK,Sl$EPZqNLk)NmE)F!QRZQ(DV6$5
-fbfIp5cH@3B&#HLTjQQ+P3P05@%2&kiIXU,!fa&VXb)J'b-5B84C,$HFe'+C@p-I
-PIUhmI,AZ!JG6S(([EfkSJV&8#!JIIA-T(T+YU-PSE#Y9j)L@!Bi#edjZf$ZlHj!
-!A,KcSj8)BqjMSJfF,"UkI09Q+&bVB9FjSl8kpNYhRb009CNqLp[S"0cR-%lK%@a
-$H+[Ar&$J"DLB-cepY!XIN`6SiU(f1E+DYb6,FpF!NM+$GGc+XZ[(NYE[PBC@Cb%
-VK+MQeU"#f5$5h0pJ$A1H``jSBpe,cDp9AKk4Ja5i(icj6Gb9pc3r0bVY&*60U1X
-4(!%',+lIAAp(0#FT@CkM#l+Z[ULcAq!6`cEerEQF-lPJ)q62*%rBDUTZCK&RERL
-GCd!0)e%6bYYm4fPC&6fa&&FIdU$j+D`(3Y5Fj#cV$P[1$D#(hFajb&mjeXrRp3d
-LUS+c"XUiGXTCd-ed&ATjd&fM6MX3q$1%fBTDG%M%D9ZAc90&plhGQR"l2XVZB*h
-5*@4R`UaLHlpYqSD&N9ralPE*JGZ89D"3P-#UpVjEPIcT)E-8p-(i)r28bqc4dGQ
-UCSFm1%eJ-0,a""LAp([kVfifk&q,bHMF[`hN&q,bA&im4Arme5eMX'aNfDPY"8$
-mh4K$IZ+!2KHa1`XDIk@c,hf(T[0I%FQ"R(68DPUU$Q[%"SHLUl[rQk9eMe01GX8
-Q#q[h2qXYA@K6"0AZdNpSLUl5LN+h-#S@C2FM[-'2'Se-lCHZQd'FT@NkGl2pZhf
-JDXbJ20JGPqeSP&#C)c4@22KI[eS-+)SI`bK8DY[+"`AFBhjB95mYjBZci!J"[*b
-,AGlehRpL%TB"Ap4*B3f,-PjPeq3Jr5ljl)Z8J9Nr)p2#H[NS$(F4Mb[eR9eZL+'
-j2%%DHCEK)4"Qje6)LaX#BDp0J'-"A[B96eIr4L%1LAL48rS4F(2PPq8b3,J2E!C
-EEf'df!(%DKehIQa&V`#PN!3"!!!m!!#dSF5TYA@&A`!!6S`!!+V+!*!$FJ!-q(d
-!!V*0!!!QT3#3"!m!9'0X8fKPE'ac,Xq!!!#(`de08(*$9dP&!3$rN!3!N!U!!*!
-(3X(8XS-3Ul8c6l2[hhpr1D-X0LT@X5M[fqqi+1$$(ap3lJaVD$,,D&S[M+MafqH
-q8+51NM(PIc8LBbY32kLpUI3'm2)5apJ,lN%i4SJ,#&6F@pI",iq)M4m9A(1rp6J
-YP[',HCqNqAm`peQA3+Y6BI`G4R-EC'Z#G64i(L3-Ip&'[")PC"&V8-&cie9q`bU
-QVq#)fP)i1",AYci(3FqNV581&!H"qR03M1L86,Fj(CL"PUj#%PJe)GB$,)e(LJQ
-4MP@VaEelAf@c4NM"ccNNdrRS5r"b-USr`5,r,G8K%dkFT'T!%h2Shf5G8XGiKNh
-C*q)r`&qeC[&Lir#3!0Y#akVAh'[XdB+RX9F&ZdFaCkqIKEVfm$F0CmbIH6!qXpr
-C'T1l&S+3!)+Irqi0&2Rp'LB!Q2(rSrVJBk*h'(*91QREq8eAHpU)*M@KKYl-2#6
-@(Pd0M9SbUBJiiX`a[[Q,$Ec012i!CLd0qcY[ETlm)[ikaFLQ5R&S5XC9(bKk2DZ
-NU*e+m(qIP*RIJAX*UNjC`fRDb#4L3I+"B-#4MKjjQP*b-r*YF9j)Ybma5%FmY'N
-YiYm@KT0k-2"CI,FHR*'%9m*pcE9-[%C"aMIG$dBI26$Gd+!SS10TGYY+MF8H&D2
-1FE*12VQSE5`AeJ(ULF'hRX+*[$!UHXM1lYN26-2@M[8YedMkf!eTi6R`@8Yc#[X
-ST-3CbmNQL6(&ij4b+UQZ@$RZY1hD$ReiEIKM"``(#Gl$5Sj6P)#(ecT+%*PHS6!
-3DfCDA)4@lB(ecda1GMAIIA3%3db`%%A[9"FBV-jiF@T0IM%eFDa-XIVd"3dpk0,
-Ch)rKRar8iJ)EpCbP0&0CFB0pliFi$&X2@Ql!UU0UcmAc-E,@cf-6ZUYdid3"S56
-BdXMH8JH5b)MSlI1A*I6q9MY(M09Ui&V+LU,U9pDf!EFEr0!qemcNfB,[0##MG@M
-rJfrjKi3TR*9GT@,Xq#%Yh6m4IKLpC[%,fV*fCPE+Hi(2Rpl6kJNB%HiIXRCA!4&
-YGH0,0i##4)'qQDHhhQ)j,)TGN!#HIAURGSH+0*q`6)5h'emdcUhU"EFlSUdlr%)
-bpI!1GSIqR[VMh!Sa+M6kkUpj6A4RI-Hkf&[h!D!kF,M25N!BTI[Tj)b%T+b+#6$
-5'13Si4dhfpRG0(JcXF&8Jim!AH9mMJ9&RKp5aZ+lb,8`)ip')&ra+PpD!`4&-Yd
-4p!Y2dPmE#2,EB-*jm"DQ6GAJVbk4U!BDDYe4*-UqCNAX8IJNU1`3`lhpYq(d,Mi
-#[B[6fTfB$NfLi-*TFkcIGM*GpVr6A[hZ,b!Db,jli6irXSf54mKVhGfqES5Ed%P
-["3%N@L'0lY(Z#NX@3)P5(PSfJ1$+0kAXmC4UZ22N0L%[VUbHrrdK-Im!"HLB'j6
-l,CJH$1SC@"8jX1CKUJq`N!!rDJMY(U8#DFGe99@-2j!!#bRBETSilA+hY&AM6Aa
-K9kj6j&+hp1PVf`5,6T'd'eC1[$&[9D33@b*h,Z1e%L+,'cm,8C&5AJl![-PFPJi
-L!06IA4G01Xf"ri!IV5BHElK#+,I)`XLH!(`a%#Ri#0Q@2Ff0JH3I&3m5@I`i*MU
-f"-X@EQMLK4TA41q-qmNFaadJS4*Y(4JP)ped"JL(B"U65$!Q(RUEZrPh9hS[ALL
-N'`r`+)4)N!$RN8pr)&rB9YXj$K&NYHV(b(Rfa8[YY`kJ5+&m1ZJbie`b6N)VKpQ
-fP0Z2[YCDHXmJ@PNH%0D2E8D@m(5X#-Z)R#5qeK@R0Ji[`5VfBdYR3+IlH3&m4fF
-BIBEQlk@CD2@XM0el0-YN[$%-8+THTH0$FMj#p@4"!G+Eq(N&e2#m3ZRNJ',Rfar
-aIkb(9#U$lfT[IEVd*$V!&BCUZjEef6(r@+ALDA[Y2qlX#XTDrkR)FCB)2YX,G5,
-E3flmh9q[3'[cTiliT3c8(@jPi66c*)rKBL`LCTfe$hl0!2`c1VZ@(4mdNre+2%V
-pl#[2e`bi%@qSIZ,$MZ+SU%2CMX$#@dU!dFbSfik23V9XDfc-q2G&Jja8p`dG908
-IB5(-1ar3hNi@X"GFmY!U05c,'`&ER62@em9pN!#6"lG0f5bdjQ'j5c)1b+4CXXb
-,0[(XqV"&[E3'Y2X15q`%$"lAfG)$&J+)4!mk(ARde[*68DrI)cbIJ,IP*C0P8I!
-#JSGjbpbH5d$bIZT96VLBb"9C*fGK11JTN!"0KE'HJI9lYc-6B[LG!c&,ihCpLHR
-B[T,AiJ*p9a691fpV8[EYYjYSrEcifDY5dD0+%QKcCk@mG%hf03j+Xj[#@U"9+Fc
-qY9)qP%2Fr*p2(Ra5NK`RkN#k+-B!Uf)FfY+`F,!bfcJ`PMNfMDRm#f6Mki@ZKM)
-T!JmTHH-BHKbVhlNB#J$ReKAK,%$HPQ+2"SB'VMDqF!)@SmhAdXc#NP`HZ3D0eI)
-iRNkpJq4*l-RKe2H&'K*b'Z8V4m#5caS24T5R0&6b[$'$,B`%!cUVTfSc`A@l)4i
-KT,X0b((-*BH"kSLFLjT#pDEMU[U5f0Dkj,b4Dd-rK!`5h$l*HXTrkc*$P0*DcI4
-qqeR#`KXN06P`Pq99#c+jKUdEPZ,,DE%8$m-PVi,kNBdSc()CE$ceafXTiHqEReQ
-MT!TB4Di0YZTjXEkK)*%AUqdd'aN&X5f`3UT58326Gb%(i))RAM-%S&,CUVGr+$K
-R!P-Xeb8-jRAS@N9alCmXKP,*6TM@+#8!RlBB6"@p$1eAce'+pI'r3"#hjm2LVLe
-J6Gh[dXV-V3J!MXTQqLG,EdE3!iRIQY+PZc5PNUZZVbZ"m@a+8M#'AB8ALE$4,,D
--ScZ#IQacj%-6%1V%Mp5!%hKI8MlNaK"ajF#%e8`59S#D`T8KKbM'*fhYe"$ZSN%
-CjiCk*hlN"+%4#2TXB&9V+KRefD*)Kc%J$&,KH2&j#pNVk,M*i0Ep#ZdF9#ENplr
-G*mrdR-ajVSJZUm-1I,*X-@6bM!ZEE-#p4A9QG1NC#ffqmZ*I(,`03'0D04malXj
-m$I-l1`T1jaQTrHh[d&D4,!a"ahUeUl1@%dA-,jfC!ldNaU#LHRTU+q+-8#mX(X!
-H"mR2BHqFb"3Fh!`TGP9c9`VLj&@+++He+KR6!BK(I-$81aSMG*9RIF153bJ-Je3
-(9J2Y,Bde4mG!f)2bkplYMXqi&iIA-R'VYC!!"(VaHF0DA[$$QfHI!-2B+3hR%5[
-IFh9",qEXX[Vq4$PY#jkN2kDaTF8j6!8T[5#QMV8"A$21aU1DfTLZmX$-L'%TYiA
-G5U#D)4-K!5VLdNVLa,iPc6+dabV!"-F95D9ElKi(R9%Q#[b)Ek%epl)hGQ"r-5@
-rj-ebX'F-+$QXC4FCUjf[&VVE'Zrdf*fB41INKR1IcF!)"r%'@[4GjEFH%+Aa*F6
-f,i!P9'-j$`S$me`LlBR%`MFkK%aCa&KrSDqfm5iNpG)jGIIBb"!*USCf#$4Q2D3
-ZpZ1e@`*Dbp*C6pAar-h1H(P4C+V[V"TM,&#`X1`U@R@FH+KR`%!ZNES[Yi)laPa
-rpmUDG3%jbMc)cd3G'aF2)K2`eEJhUH[P+AX9REmI-@QC$lF&P%fQUK,-$Pji+#@
-AV,Pa(IRPb8,aUJ6EhLDKi!-,aV2Ur2HB"@[d&Mdla,Edd1*Hbj3bbUB0V22aHCF
-6SK0MENPpL9Nl&1lB'TJr3jC3&%pqU5&c[[@Zpm2I"(QD1'dEdJI@e63AG6#MZ&9
-iBRa+ceBHa5028rKUC+,Z4Bhq#X-[Ghb@KMa-2P@CY9iK#&*9rK+GK1jbrTiC,FP
-dJ-428V@qjZ4`*J(,hYHaj&Uj"cr9@d3pQ5)4QABNEG5)Rf`FI`(6j`%CLbV69L)
-+HIEcLKmJMYEG#SJ0D`eV+dS8)i@FXpJ'TSZ*$3U3!!`%5q-bi[k"rU`RqAkHFZQ
-(IqQEepdR`+hPiI#@*aZf`((9QYeD+lN0k*D```06Kl1&QT,&VkC-XIb$phdLf&X
-'MabJ%l-B9jI,eMQh[+Ijj*XN)3!2CI+!QaQ3!'iFD$UAl[JC&RPlR6%!"Aq43fF
-NQZfZ(p*dP6Kp$0PETkS-Gh[%Y&9cKUH@b)+J,G@[[Zhi@B"Y`Nd!k$R'fV'T(R1
-&SQBA+0KRA`!cPrK5f$4%QQBFjBbY,'e1@LdpQ,@-eQLRcKZHGQcXf3Kc[+ASeC!
-!S``'Xl$m9DS9[2rADH3,hTYQ$4d5)1'M%#)XqZT'5#$&24+b2+`86GTq5%3U3,#
--#KP+UiB%!6NdRjS)V8IEK'8hE94EMLfKa+e"RKS!IEk$5S+kHKJCE3TMYT!!SXm
-f$+Y&1FFXA%mpq!jElFS1@VX(V"@@`"R"A1lRMT99Z@U)X#FeRlPSA8!D-aXQ6JT
-ec`p'kmSBYXC`1[)@pJ5G(l5$bUc`$(X69GilRM"SPBJJiFh"U6k`5kj&F3Zi+PP
-TbA8pPXUbB*962kkMq(!(fe2,IM[A3eVlEcQf@Y,3P6lURC4LQ"h#jjj3(8C[9US
-GCAIq`TSEX'f&ZK46+HHI8-1dX@MI836)HicB9eFL$GeEJ[HEQ3GmV8J22Kip1V+
-ME+jKfhA9U8-`i15J0#!Tj9XYX#eIa4ha1*aKU09ALXC3$44@qJE&NL'jkTjfU82
-m4h3G!N!kLYfE5+k9MMFKk'a+1JJhHcMA"Q4KEJGB*QdBVDVpfV9Jd$6`U5UG--c
-["*@PekDqL$Dj5@3*4(GacL(e4VGmDY8P#F)rXPRf&0d`55dMlU2hK+b0lcX*%qa
-(2!h#5ATbiUAA@Em5pBI1Z0ZAA[l54cX3XFKDUQB[ZK&2XJh58DQVcBBFXT*m(J(
-5*SeE&HcjMIN!lf13!+K9%Rc2I"XNrGF8`Rm`Q[MF-djj9,EVqqH8'K!2,4me6!D
-@m2NJk+bi-rCp5keb%*i@bXl`cjb%4f%E(k@9IB8l&F'`ed-"$(q3!&Y@G(kkQ*k
-`fY5bU*1!X%k9X,kkApZVVk9,r9YhpkUmiBPDNT[`e+fMD6THEQF3P0T@N80FihE
-2iYTG%E0PkcdHSfmYNh*kXjeGR2ZRfBNR1[qkC99A[1F%k0UJXF4-+CFU'['LQSL
-(q"[i`Y`FZ4j5'6D-FeDE`SNA1mrjf1UiKHYI%Vbp'-9p)hN+CUK1BqQ('XNhCBQ
-2Uf'E'VVq6@H0fTN#Te%3VlJ0E"b(QUaQPMIdacrVp$VYb#h*5-Ned"13!!@R`HQ
-5rNpB#De458P8B,Kcdj,l&+VHTBLBK5NL6`(h%6NT,!di6GP[-#Cj*G@ClMiXI1i
-,2f)%SULEfaSRmDa2*$R@8$IFbB*+*Q$mXCG*dp)E0`R%jJiX-P-9DC,+lVLmLEM
-TPaN0bGjXjHJ`f8[Z"FFGq*UaV+-GpadfCl'0"J%Jm[&"l-a`eZ&mB3B'TImNUdK
-i3+0qdEjlS-M`2JBdq9([PaB@p3[T3&S%HL[+)10Cr-b!D9iYQGI[%e&lVcJifS(
-bN!!C`9q)HREHdePjK4+r0%9J[&eMjj0&M4E[HFD`lcaZJpUIKUZ"@X9JE@#rqF9
-Ih,`%@!i$kYerM)IK'Ebb1H+2-Dm!VCNBMNL0ddP[`(BD'83&dN0Ur0&HZG[Vaab
-M1+HFj+SifLR8+8V1iG"iYd(LfqR$k!ATE#XZ-Q"$#6@kfc!C(2DaHp+6Cmm[*qT
-Zie-6BB9mL`Gi(TKPZjI-rS'YM9`Q"%[KjKrb9),X)YZ+GBJ[SQ3@rbpLS@l0-6J
-jcYZfF2DTFCQKJS[BGjbRF#P4c%Y2VEZfbI!126PQ)Z-2`II5)ah58a!M'(*Uc"L
-0Z$`lLZU"kY9a`Tm,3I@Ze6J@p-dTYfhTK@!5!PEpGMX0!3d0Cb`*H4$Jh68q*rT
-%CbfSjR5T,DV"f"Qr"K+*XCEcX8EZLZ`&48r(e[54-5')bF6cac$Fqc)*aap3!C-
-6"$IA+lE#rBHq&RRblKp2*@03R-QH*V9j,pV(IR4Ja!pj2eEbfP-rFSd'epjk0CU
-LX4(X,'6LZpF0jbaQ,P)jDPLjYHV"5FjU6+Y%FlT!+@bAN5K-ApHjKq3RcdIC5aI
-D8h'qK2ID%"-[T4,-+Jir%eUSRIUZ&J%aTMAEJ02RTM&)DB1T1kMl[RZ&*fch!LF
-l!p3&eC8k@2iYHpbJ635rVZhqBafRZa[@0CBl6+GmC`[l+GTThh'mkck81e$6Ab`
-CTE@6%3ZScJ5kK+3S$1lmIcf8UL8DS1LVF6RGF9ZN$Kp$YqVaL(1!Ih-T5TkGUPZ
-44jRKaNU92(Fhp,4TVpq"1VdP"U92%)RX*2(TQ"D@%m*KA[`2H3MjD+)Cl*IQT-j
-!aUc!C!L&X23N#R&(-0A*BmSL@d1NT!+'pkq'XQ0H#NIRSc3DQ@"1mL,#1HDiRac
-"b'#qH81B*SG58"Q8hTT&-,@H@FmLd`3+2Tb[+2LjFQA)d(UXhaDr2@B`2LeSGb5
-p#6M!j3FekH&a3ZJ)V6fIDT!!bD6PqJI'alT*0mT*T[2N*F3K(TdYMK5(H,%(-Ef
-qiq6R$FAc,)M8JaEI3Xrh1#I@'48m$MR&$DURplIcrl+GM66HZb[C'2qQTl$iXUr
-bULmSR"rKi+$j[p#F5455`2P&pTSqpd&cm!K`Z@6DX4qb)J@QR[P"T(3jfmfUki3
-,V"MPKhqb1CDI4[e`9S4eZ-LkRPN(qq+pI0q$0KJb%cf`-N,Ahl$!r'`LeST0b3[
-ZX*b(+qD#)+eHp+QfDN,4CSi1dd$+3lUSLQ&XfLX8ECjrdh[X90Cm*5QX&8"2fQ)
-hYq,96ELP6FjlBE,,mVhL(XM`B"I2B8K&Kl[V!-e&mkZZ''6JCRCcV`BY6UY,0kN
-(I+U(JcRCZ!$iqEq$4Jf+m'cQ-`l-*e4*@bp-80kHJkQ[KKf@K0V$+a9(KcH$ad&
-e!QrkR1,ImXm*"mMUflpj9GFl!S&N,VCK!ZFb*ec1Q&+aRH3XpC!!f'J0i3'HLQH
-*beT(F+UC%#AC*52GE,kY6rIaKjSV'+-PVT1`PhG)j9Gc3#cIBBXk*A!SbI1Q*pP
-ch*X510bZ"D%G(%dG!q422G)d$l,GCBP$r6r`'hc'ihAmeI*`XPF&cPUBdBEY@lK
-+TGHGLD@6Q,5k#9[X"QBrQ4DI$fSadI2eQ1QHk`NN9Y'[KK9T(FP1PeE-i'HNQq#
-XH*S&dlDVc4b8a65RQ2$1Lbfd9phe2)UeE&jVdG0JUR-5K61)i"DmfG(Mjq'aiK-
-@eEfEG'+4a6eJ8K%@i#p#(&Fkm2VEYQ#&iQJpbIcb[Skq8rld62QDN@ZdUq*'ZCe
-B#Zh60Ta#*PqKj)i1rQa&Z20'XH'%E5ejTBUlpT6F2)E[TGiqQ'U5`c#fEXHe2k+
-4PPbjccVk'lRH6!5U2jQhHQLD(2Lr1FPr@jXDUE$ZN!$(hM2dDT@IbB,3H,&j,*e
-QM$-$KT[H0rD[4hKYI)YK!9'Xm,UJIE2lJJ&$SpF"HUHp0eBmRi)[Qi)q%l(8JUh
-T0j-AP,*H-,-'I9G5d35!k,QTjrdj!XVB%CBqHcp2YB+66&(f`3),Uf'f)Tb"0V"
-T-IN)Y%ANT'EV-'JK*LQkdCm2ID6fDhm)[Q+L*48K,+L@I1iJLDrdZ*Q@%p`Z!8)
-@X24G2)bBmdPE[mS[C[`'$U*dT8,k+If$N!!Kj#CdUV6jBY'QP$R88Va1NND1aQU
-erX&R,a8jE54c+I(,D#pYrb!kFk02SEhaTqS$9m#REG&Z1G5,90RN2kJMaB+@lq+
-dE**+IbUf4JUpc20TM9r(KP)Gph1"XBGdQe'qFcC10EI56(&ZY-j5+#Z"@imq`9+
-@eU1kqe!8Jch,[Ej0FDaMekii`qqh$kX'hb,BLd8EaPkl0CU@fF)@+,V`NL#3!$M
-@fd+ZmJl,c$Ma4kfVK!Mh(CQC)cm,9KPU6!kLFdF20FUQ4Uf,2$12App914$cLDe
-['5GYmAD8"TF(M5(I9'he-Qli0PreG1B*DJCjT%kBCC-'M`%MhqB"XfUeD'1e9!C
-8M66kK,3"LYp[Y-Hr44qERHUkCJepVK!Zf3RjcFi3fS3!f'A43+PCkAi)%J'kYrN
-9HdcYb"+J'2L&k3*X[kZflB1jB1Y3FlkZhQ9(@b$Gq5!L,Ja3[e2j#DCrHMZr'E,
-Z@Jr0lHeplU9pB&52hT(fr0%c8'Kl@afc"-aQ!@)%bN4%lC-*-CKPKi,5mLBcI9m
-`5l(%IRq#1*(&`1cpRc-%NX6A5S6Fa*SkhEVdi2GrTZ&9F25p+FV1V!8"(I"AjPD
-iD&alTPYPZ,pf(P)-(4eC01q%rPcZ2qhPDecelTEj%'N3CM"b6EIbBh@*$QIZ-,U
-p85,e4#KJfApS3kAKp+#AIrfq[(VDI5X1rM1B4LI4*r3@)lGUFpING6Uk(X68+qr
-Y)a-Y9C(K[AlhIe&,eM%mBI)FGR8"@b8b0@9'QKD&2i`[&&1`VLb@LQ"$(k@CjH6
-9Y-XLf'e!lb&Fj,@8$ARmM+bV*+0*K!PEqrS3&NY"+80kcmKPS`B`E"9Ir8G#pV#
-)VImeUB&1TRPmP"9#MIAp-a"b"IB8M1hl"8S@AhCRR`S0TMr[GN!ZC1V[*krSaM0
-GX'U`@0'0BlP4@4%)LR4EQNej%)Z!QAHBMqiD%S@UhZVL59ib8&%ikYh+5eX%aT8
-ELqiVl)4pP&Bd%E%qR)F)NSTEPflS++Vrq*R03YE0R`l@%9&b1AC0bRpa(ar%+%Q
-*&-bqhFcpb'0N[mZ&V$h5Ym--RQle&AF*SQI!p49UL9+114L&*912bPcHic*)5G"
-LVbcE)A%GLU5!pKM`60U-J!p%%92Hd+X14,-Ma%CqhLG&P6mI,HHN(M$Q%BQGB(+
-1)&m'`Z`,JLA'2V10I-A'lCNp+G-KjhV9,33++l#)1*Ge$Ufd"bkBc`Ur[*8kT#2
-"QheJpYF%[4Jcp%JaUdIYPA,#2$8%FCb*NI-Gk&"#+9M+r[he4N46U4BfdYb8L#H
-4r%Sf6kjeG#+lA+DMVcmAkQK6a[#49@a8iE"N+&FMP`8qd((3aB(Y&`jqrFQ!18I
-HcAd`Z9-()'kila'URI+Ylc%,'F4T8Jq$+YG+Y'42)je[6)hr893Imc)CcHVA'3M
-QBP1XV#Ab[-G!rI*8&h2HPR2ZUFLcSRk2[bfb[RNYS[Yd828@T09,1+E(h-jk5qT
-CIDIme$hCq$[A'C!!N`rE$pc$UTVc#jXZPiH$HI*T%lJjQH(2irlC+"UNE@*NXSq
-UehqmYi1jRbehIGF"+CS5N[QjHU9c8PT[$LEY,ESrJqKDl&,K1d4KjLhLS@-MQ)-
-mL)mUTm6KRB25`XH4i5!e4j+Ml%%-AZm9FhCC,Kq)dP[KJ(!P6*kdeSSl-RX0dB0
-I[X*r$eJ+)jCiPR*YRMpXBDaa2e[jTN4'SP*U(K499GG"'FjCrS-9rl*)[4$8[@e
-bk!+SVS#*%%XiM,hZ8N&dU0f*0T-"GX(fhEZjP[99qbbPQR,M[[bcrkEMeE&'UpV
-3X@EF)I5jEbfH5e,3EUKqK((LJRhF1h@c,$ZdHN,IU1lLr(*f0L$M`1kHB%a3Jd+
-cb)Z0iCHV2iLDTU%VpL2415GMQbGMl(Nm&!3NYDNjP)MrQ9h-C'HG'6H'aUl2cLN
-T9(X@K,TN,K5(9N`ir-X[V8KFjIKL&`$L$*H5BAQjc1'f"`&R`2TdpS8K@6TERNQ
-lVDc)idY*4K-hPieA1mlll#C8jeTe9rjKUQK3j!3&56,N"X5ZU6aRiC4qk"QXAN0
--KT4XA0[FUiA3-@2#dP[dfN53!#GGP,hTEp6'QF3Rl5'M'P5lbHJ'II!9ZNJ,Y@e
-I*U`@0B428YYmXhTJVm5!B6%NI%c"Gb8V9i@*#03bN!#1!jSPNA@Y2$`H"ZTD03C
-IN!#q!G5j'FfXK5YM2CYBYE'NF-4&-9'1'*ElJj5Ti#c5+lRJ6+fa$l3LeNiZ2mR
-I%r*dmQ[Vq(%-khApZlfmr)'H2,ZK0Y3brFAESj08(KB6[)eTecc$rZ#'m'`FiHa
-`H69Lm0mFka[GQlj(PRHU3-A%jDf24U1lA,2N#"ULZ"1QM@URaiQcl4CZNCAD`@m
-6(eL0qqllqS@[mdT0ASUYkB!q4"hrR5Zm%)a!56KpZCa1-(m`*VR1'JNUS6i3L(e
-qEaS4daiQ#IJJh!'6ScD8S$`*cM@`@RjDP`E,eLbB'pjdXUcRdKB31Xjdbb9BY0K
-CXZ)mk3pP6Ae,L*5QMR`hTH4)j46rT93H,"d[MkS41I+jed5ZVR2Zh9I$'BJ%$dk
-*Y[`APLPqG)GD-Hqk6+J!X[E&)*ZA3SLpUi"096I*"JCEGfk[[QfNN!$,C%JcCTl
-3B4[rX&ZXHU`@aNqRdXqalei,iePRB4KXa#`6[['(D0"A-I(21K@(JGiTT'5099@
-q3,pE4A,JZ*!!&UMFXV&U%-(5-`Id,6+2pCD&#$p1UkQ9+0+-bQR@38MVR`DBFPQ
-L#k1YQlqjqI1&9kMBGK9(Sb-iRU-aF'EH*F%mm#L$FJ,)ah5$Dl5,6kKa-9,3B!5
-XT&I+aN@L#!b!&Z,ebi`DSZ3*C"SYrU[qPr8R#h"LqE3T+H+mi!6"fIfL2Rqq$HU
-c,mr(pbYeGKS&0CJ!3c$N*a*G5ENTU3@YSBeR3D#1af'!6"i92S1JSKB2l0Y!J0"
-L1BD`%e2K"(jXXdGE'd[NfS"SD*cC3[(ErbA9U2#++3c+R*!!5hZ3!$b@4P`rCJG
-%JrCC#ZKBjCV--"-N5286'J9YB"Gb'Jc`DNL#8cEk")E(P8fqP-e-aSjSaZYJDZc
-%1RQk,Tal`94F"r2'K%df4ZN'(AQT1+)ap&*r$qkfcHLp(Qak!Zf$$S9!8r%1&Bc
-UPrhh#LADrQH%"2AQFE'HVM5dpclFJ*IAGD&GjHd6-8)f9r"Y"ci2FPL"VZD-,pf
-S%iiHA``L'94`G0-F'%!eMZRZJTqU'behrp`YA8UAGSRTqrhA+X1X-38S13dI%K`
-0)ErAm-0PPT,BaRQSFAZLqiXZe2%3P)a%[X"8haciA-qAAia(+B,,#qPC$HeBVHm
-R,+4I!YG5F3eFdEiA88Hf1V,CArKU+"%bADp3EXY*B*ed4cF(`kl1h(&D@e5qVrB
-G4ikkUi6dfUeSL6E'K$,YjE!K-0lX6FqJ0Va64fLXCA!ReaiN0[%a*'@[,la(KVT
-adiNM+q(KC*!!``*5E6,2aVrC[2SUG1$)eJB[pPPlBca42eL+arNTdahXTqY5#eL
-ie-k(C-iN*,ijZ4G#miah2lLjU*DSF`9QAAqX$r1ZjJ)KASYVah-Mc150)9%VVUa
-ZVk`$62AkZ!T3jfl`h%f$"VLhU6%D9mL*aG#k)rK5jr*mNhUrV)k0[p!CYBGC580
-5QV63S`p[Mjbl$MIS"V&aY!5aUV[r@cCq8Tc6(`*0Bl'0'FG*%bcJD+9M"LZbl3C
-,K3[Y"ppSNp,6M%@dSP[[V6'1$AqQ+fU9Pl(E-R9B&qjqS'9Q,@dbLD[-`T`jD$K
-l5kUJ4jihmUSPcSfZ3qDNq5Dqe5#Q5eV1#"LVDT3ZdYIBr5MrqCYd%CKF&T%!lA,
-fMN[IX53PmfGddI4QKj1JAmI,b6G0iCff&kTp-F@ir%f&qI6`!p$Q(qmLJcFQYLk
-Vc-d')dePeJ#HjCNEC,Br4pI5de5K5EeHB,ADYK@6L$!pmHjILZ",0e[S(D+E4'c
-`#k`"Hh&9leL$I([2XJQK%r-TQJUlSIPFiLqTIaPRNC8HTHR3jM2)4c*&V!EZRUl
-D@-)jXP@LMB6L[)Rd3k[A82PQkKhkXb"Ce,dA9lHc9[6Sk4SbqRIE5Bj$!la"-dl
-$#IqfAirqhZeaahj$ah[PE8%bSrmLNlbb55-d`IaLHU*h&ecaVkKY*l"*-H%Z6Bk
-[VZ-&!a'"#+UQIljG8DaCYEL6`md%CF0%,cDIeQ[+#D%-BA@iLVF0&KN)*TX#6mq
-,"4UpIVG@dIHiHAcHQBF(CrZG[NdHj&51Ca3PCEiSR&'(iiHKpI#ZcJLEp3SD@S1
-3!"Q9FHY(aI"#k"TCf1ED$ll`"C8-iZ0E%p&8lFCp68e5A#imi68-daa,l8j,fPS
-V6F&C5"d*)2P+F3AlFb'c35Ejc`D#22&,$TJ6p&m+l6Deh@ChA,ZfEU'pbJaMh,k
-Hp,Fa)20af[q0%0k0)YBI$k-Hb49I%,JLb4A-Nb-E&SaT,r***+hP4+a`B+[4i+l
-"kqZqkQhEpkHI1@M-J@SlfG5L4d[F`P4F4XXRLLN6H'dTfrfUI5VBN!#5`PYhY4C
-e9ia,6IDUQFk1BrX12iJ%EV`LlU%%6hH19qh6HbEAPBQ(B*a),SGkZ0RI&VQBb%S
-H$GeBfcPMj+Ud2@k3!2ja@dAeYAMp`TYR*+G`5ZCiqpK+E8XNA"LSEbQ&-MXPAlX
-V6mlfhq8C2AA%E3KCRLmVHiN@eEU`%q*3HRh(RVTDARe$FmQFIRASZS#C[(I(Ulm
-5KA1FM&e$Khp%GSe%RXmBERH8+P)[C'@f[pTXC322lKKE8eRL,q4,m2Rk-ZN0+c3
-LIGQA6#[AI3BCL*`iYmSFJ@D`(V8K8IS(iCAK)%QS01lepcMk(X#$BKN#-I3A9KB
-dI6SV"[E*Qc*qCb[Dl9p5pkAd+CrejMJ4cM0@l-BX0HdV&FT4#r,2*hIYc$YkaH`
-LC2Hk8DIl+!c5UXK-Apf9HQ5KB,$KSF24iG1j)%cP5V30`BQdq*NUDS(A,9!#G3T
-*&jlNrd-F#el1D`5''M(,ilFV@%dRLH$INr)H*d*k+XZkQBa)8qeG4#UA#!h&&jp
-EB*aRfhJMUJ!5qI%`80G6AeDBj(Z`R-1A"UkF&fYlZeH6,lL5ZAbJ+Mf@*0)faQ%
-c*35T@TlraBNUERpe8U4Mrbbi(c&eV'8`UmcT)jV'8f-(T,2N6l`pE&Nk+BP9SkU
-rpd0S,[FE!2CR`aciSSMQLTVq%Q[r4*RHCX8TeVNfk`+Fem6l6$I1Z5ThA%59bCk
-6f8F&LQ344d6f9#i99)YJprqB@*YBC#bFmTM5P6q[68LpK"'k1#V2[KcVj5-5mHL
-)4F2bSK`Q"Q)e0A3-Qi4#U'`4HAAbMGJhja%pZCZKd#d$8YDp%k)dK65)A*!!1@(
-'+ffNUKQP"MpJaqJlVf4AP`GCTcTeS30KQTrTDPV0eN*GpCTQ%Gr9q)%J)Vha(%Y
-kSIeQG6%@N!!Pf3irph4B(rL-HE2U`I#@UEI4jcG#4Xe,@P4+6KE"#,3qejI@-if
-qVjVRi$1Af6IUE3#PF9pMpj56LJAQShSPTQ)riA0I*,9%AZfRh1#&&%X[414Ud*B
--jfq4Ab-mmdP5qe)j*FJ3R3'`X"$N"+APQi2(bHG@FHVNP)e,8(DG'`#PN!3"!!!
-`!%!!N!U$a3#3"h)!!(*Srj!%!*!+3b%!!!%!!!'3!,F!!Bqh!!!%@!#3mh`!!3#
-3"@N!B`"p!*m%!Np,!*!(23"J!21)A&4SCA*P)'Pc)'j[G#"PEQpeCfJJFQp[E5"
-[EL$5AM$6)(4[)'0[ER4TER9P)&9Z8h4eCQCTEQFZ)#""EL"KC'4TG'P[EQ&X)&i
-a)'*jG'9c)'&bC5"ZC@9NC@3Z!*!$8J!"!*!&E3"Q!)%!SJ3#6dX!N!8%!%J!C`%
-$L$*6Eh*bH5`JBR9d)'%JC'PcDb"bC@aKG'9N)'9bFQpb)#KH-#NJD'&c)'pMBh9
-bFQ9N,J#3!d`!!J#3"6%!C`"&!+d%"&&eDA3!N!8+!&!!(!%3L"T9EP0dG@CQD@j
-R)(GKFb"cG@0MCA0cCR9X)3#3"3J!$J!S!#kJ!J!"!*!$I8&%3e)$!!"q$9-+Ni3
-"Sfd!l!Yb!l5b-LXVieY0hP[[D[HQELEAJ$%!3!-!N!1kY3b!!!PT+[lJ!985,2Y
-+b&X1iq9cZS94MV)rcirrVL!j0k`Dq"(+KM9jKQ+MCf[`V&ir"HlX#m#`U3BL1%a
-A2VhVbkfM'32&(&P,'cJ,!*!$@J!"!*!&A3"`!(%!V!3#6dX!N!G+!&8"%iJk8fp
-bFRNZ)#"*ER0dB@aXBA4TEfiJBf&Z)'pZE(NJBQ8JF'9bCQpbE@9N)'pZ)%K'8b"
-fEfaeE@9c,J#3!fi!!3#3"@J!HJ"m!,B%!Np,!*!(5!"H!5@)6P0[E@8JDA4PEA-
-JGf9bC5"cDfP`F'9N)'*PBf&eFf8JG'KPH5"KFQ8JEQpd)(0eF("[FR4PC#"LH5"
-dD'Pc)(0PE'BYCAKdFQ&MG'pb,J#3!eS!!3#3"9d!F!"a!+`%!Np,!*!(5J"9!41
-)1P4SC5"QD@aP)0*H-0-JE@&j)'*P)'4KE@&RC@3Z)#"3E'9KFf8JGA0P)'Pd)(G
-TG'JJBf&eG'P[ELi!N!-S!!%!N!A-!)i!i!$5"!K$EfjdD@jeC3#3"33!"!$$!@,
-!!J2S!*!$e%&%3e)$!!%5$9-+Qb3!1iU)LKA2&Y"cV%4X%28X2hmrl0HG[qIZcJb
-R@0KK*5TBK999BZ@rm35aUJ8,XQ8l6L$jN!!I!93NQ2Se[)@RhFACh8h5b(U5[Ad
-I,N2FaCI(T3X@qBdi9dq9p3XN2%U1NN'qk(5em(4U&CSL2JAQ6XFXGBZPFi&Plh`
-8(,JebXbQG8"2"b%-6&H8@CbY`EYPFb)Ah(i-H"r`2%#L6q-DV)Mdc!mhH5K3fic
-)FDZRR-9M@e'jc-h@kB'VP$IIbIX-kIp8rmPY!*!%1J!"!*!&8!"C!'3!N`3#6dX
-!N!8$!%3!5!$SL"P8D'Pc)'&bBfKTGQ8JDA-JC'&YB@GPC#iJ!*!%5!!"!*!&4`"
-D!&X!P!3#6dX!N!8#!%8!-3$SL#GCEh8JD'&fC5"PER4PFQ9N)'&Z)'PZBfpbFQ9
-MG#"`BA0cGfpbC#i!N!3-!#J!+!#f!4`%!999!*!$$!!J!!J!SJ%F!)*993#3!``
-!BJ#5!2!"Q!#&998!N!--!#J!+!"e!6`!Ke99!*!$$!"'!+B!ZJ(@!)C993#3!``
-!)!!)!+)"(!#!998!N!--!#J!+!#Z!8i!Y999!*!$$J!S!#J!`J'N!)K995J+!*!
-$$!!S!#J!P!%5!J"993#3!``!+!!S!)d"&`)"998!N!--#e9Z8h4eCQBJBA-k!*!
-$#!FJCQpXC'9b!!!%-d&%3e)$!!Ch$9803b)5%HCHEK"N,4P%D[*%*!X3@DZQ*LH
-h2BZ-i(ERb%Qh-e2bQAph[qrELM`EhmbhY8#5eFlXbH4*f,ilNa'5j9ENLDc)laq
-42j1IbEcCeRB454B6XMFYb5)S31)(rdjCKT&84$LS#cYiiLGf)5c5J1e3aD%@GK*
-H(mq1D3bR6lpC+R)6)mRY[@4[%r6@hmf'R%[)+8FIZEr5&V,ejRAjaL3*5bPTf0k
-N&a@6NPGC,a$mi-RK`KFHI%V$*QM4BN6+hFfqTX2b,*5j55k)jb(*(2h&i)XDJqi
-m&Fee*9$cG*JIMZ6*i#SGjViNe#Xq)@+3!*h[`af,NK")heX@$ED[(5XhPA-`LA1
-fRcbNbSE0RBqrZ,m'l)YVm[NQUD!A@)"Ck2@aqNDT+'b%UlJKdF4%D4j'8D8QKLJ
-RXm5(8JQR40@4X8N6+L,JmB-'82KL!,85ECR3J#8d%@TbLdfC`eLTT"qR$+aeU)[
-Di0J#T6DMFe4B`aLflrdNJ-)Z!m3jBTLiESAmcl%RFHbLl9fAJNh,JDRU`pD$+ZF
-dM(GdeX@!G"Z$#pDfYBXaSNc2)HBbh"2bA1lEQ20L2d(0f,[Q&#I)A'ZQ2(KBb@@
-qIDUNT-rSkShVZbh3b(2j4EE#Hi"%aD`5%YXK48JPi!JpjfESS#*')G-lpU&Zma9
-#N6ZP%AF+hP-PhjBJ16hDlDNc*qDmR%1jlK@TB-cEfPh+FK[jplG1#3aZ,GrmP`r
-LNbG@J3Mpl)N"@`NmD#E1Ye,'NV,SJ&0-'N"4lGDH(L15jV)kGQArf*KLjXEBBNT
-+ilSFVqIQ2L6S6,2!-qdr5A,SM5rZ8%e+qrrFIEa)TAK+(ePf3"KU9mH96KeiJM&
-J8-CCH2(UplHlTpQ8&pIV!mfS&!eYS22Y"H59K,,GX(5'$iDUN!!D1!1%4[Dm+R'
-d+EK+q$Ll6eBP[SHY1Jm&+*f0f9@c1LPl$U`!LB0EA#,N"l-#h9`&eEjM4RfXIVf
-`GZf$Y!rlJeGII3NEUUX[JA!5-Xp,Z*!!K9k#PFalib#6LH[)jR!53fYB8Y@+#cA
-4e!fZkRA5eL(bC5reTB0Nq+`1N!#ULm1*SfpKL@KA(V8&MK(J'6fDpK)ZJ-$X$'l
-TUd'pQXb1L-Hl60lqhlJ2YkIbbBfVNkBAI5lbXT26-1CCQI@i%dADZX@J'V("P$4
-5$f-VG@mlh@!+D@pipZKGMr,CUC9ZcXXMqF'dI'XXGU%XA8IkajQ+#fPh$2Aj@FV
-RjqVrINKT#[0r9hl1a'Bar[EhjGLF9@FZ6fPZ&[UQ90aX9RVbi))fT0[hNY60m9P
-ip++5qIc2PqqBK`c8pE9GaLXRlhFHm(""&mY9YB2CTqfiUkZ$G385RX(1bd[ERX3
-qk'4JZaVPpDGj!R%'T["3[!PH+Gc$PhJ`"hHqIVA3@F0Eeq31!*!$'!!d!!!"(!&
-S!!%"!!%!N!8$k!#3!j3!N!-m!!8%)'pQ)!FJDA4PEA-Z"&0dEh!E5A4PEA-JFQ9
-YB@PZD@jR)(4[)&9Z8h4eCQBk#e9Z8h4eCQCTEQFk!!!)`N&%3e)$!!q!$Pd,V")
-NGQeRhjerH,HaE(HH0fCLf0QFadb@D1p6'b-S1Qp(X5GD$AH6&!QPSb`MVD*U#kY
-+Rfr$#'qGN!$YZF%SSpR5d3DU+Y$UI81Y&!rS'1d#*De)Ubk0bCE3P2H9"J6XIAM
-Ilflff5+TQPE9q`-0rN!M)f"L-b*%)83elYAdTa[%MpAh@,9!I4Sl`c1T[b#Q4mm
-rAcEf`62IrVq+cHQa!)kNeiF[b+S+V)bKrJkX2pHRJ(SG0[k*S(rkL&0!`X"V3'U
-4`(3'#R9!A+9%!ma[5(BC"SN9L"U%U3lK&+4jQVl"pUk-hT(C(`CfpBqprI$G,Y,
-P$Si2"&DZrR+i4U3Ff1hjAr(%8GjLkR6`qH9jHBkb"SGYb*[,SRMR(Bp-q+[%BPU
-fmEmZre[!9Rhm@lD*,+U2j@dZZpc-1k#8cm&c+KGaD#QV6FdSjA$ff+-lA1jYPV(
-P),qJ,V3%Bq'!IkeAf93MkQX4T42`bjrB$d)r9I0'[R+MIJEYK@S$KP&#Z&&ZqQL
-[$[-qfUPN0U*Ub0%X+l$f9j,CQkLIKBN1PGYkE#adrmUe0G,b0qkG2MLb098LjPe
-,R$H91mlE,I10[0Nq&,RVAFb*qH8Mh8qPFNI[Ghed3B8mNJ,[BPCeAlN$r[bFi,(
-2X1QmmZHP00qhA-k[2ji,Vfr`V'MX-V0B,f`p(Y&2'NIr"4Uf2T(XRHRq4Ep3cDK
-["+HZ5kjGiMSKVP0d[BqZe4,UHY+%qMTiVIBcBLGVJYJ464)l$6@aNrB6X41q+iX
-GXefPh3ZdLqUIq1R4$&-69IK((L2fmZ!l"B,BNcU6cC59h[2-qIDX2lEG$LPTSr,
-5aff#f)B1)L1f3SALcr4@BfV@)8V,Xik(@BH!`fDjK#J(0hcePL!fIfE%KPGmD,L
-@&EhF,+l*ZLp#*$lE%`lk#8BeZ#Qq#1d6bY0p%Dq5*U,Vmc*FL@cA@k[KPTP&C&5
-#p1YJG&!4iPAJ4#8%@c[UNNb9KmPT`&*'YB,li-@NC8FSQK#ZApmmdV[PkV99rII
-'a`BL65ZdFkXf(jYd2J$*F3[(#fdPeM50JY@(GkhmMEb!aH20TD+He0UKJ-Zmb2`
-6T#G2Q*N4mUaLDCr[AJ(TjJ-QKFEhFTTN@QBA3fG!JJ,#`#iK)*C1@(dhE3kHMaJ
-dQFpT3bDIH6(N!LNL3V0GL)LPhF1q)Q&,YlYPIXAN4'ik@TLVjZB[0k6DA#"*BAC
-b$G0#D4EeCq(3PD)R`E"2SUU#U,b"ibG3Vd'0Z1cJ+jl+XL5Sm1%LAP!%#R`Re`*
-hRh)9*#E$E$Y`-!DHEH!8R8T$B)P+,&9rI2fPPkDhlIYkm&AhffH[(aXimSGVHMj
-9V0@AMlRP([JGK*bQU+#1q(bHaG!PrJ&[IcNe&&S-c9UBI#TH3q"FfDHFS+VU%,$
-r-YJcUBRTa9$#%MT$K@aLGAj!pQ99THJ-8d$45-V@S+"p900Xi1bUUP9Xqr!pGYT
-Ci!TmkKj1[6Sj'l*j3LkUEfZlq*DC)SQbRC4&pC3KmJ+iQDNpE0`*ihVYBFlG4m9
-F9Ie2'KkX`q!Be!M*dX+DX1bHE%0e#U+-(qQd89dD`VJ9qd+NIFXP,TBSYN(!*))
-U*5%M+Lf9I'Apj8-DGiQ6!GSY&lRAYC&V[4[(pK@+SD[FmV)hG94Ef(RZdjXr@HQ
-963mF3RHHak-h@l)TRcG&fTN3"d*TmpEr(5KAi$1H`HCjN5UQP#`ajCa-T*!!Pm`
-pF0KF%C0(-NSj+2AKC-RbkYb5Ik%T,(IX@GT+rP[bV0$6FX'cX[Q#iV-l#)'L3P+
-mTYD#NX+64Si1QT!!TF%B*',Je5Ki8clj!p)Cd66pU%Epp+[T3Y!4%X9SG+SE"MG
-CM8h"qlfG$X*p%$UI5QCHS2ZQ'F4a)k-UQ3m*C++Ye[hDZ(q`pm6kjkli39(9NmP
-NV08kVPdI(([hBH(l2jY+*S-dfG4kFEaq-,bllH%[Rp-h)&BU+HULkSZYf[LJqcm
-pTF'(cR5UJkBk+R[VR8eIZp`a-192Cfl3DP1peRkYepRE-a$mirF()IFpC415NY[
-ifQZpcVeY26X("Tb`L3iP+9%6J%UX4rA!rLSK!3Y%IiG4Q,3lCMAdqIFB95q0MPU
-0Q2)qbUG[r6cCaIT'Ik8RZqCEEp(135p8fCDiMKUMqKP35#['jR"XkFShR@FaGR5
-ZfNPIq`l!CS@i6N#$3,-6!LL+#q2PVamkJdFI8k!%KHa#UQ2Al9elqLb$pLpG$Rj
-ecVNdmhVC#53+i`J#dr9Se-(rb',ZY*Mk8[b$fk2#dXa[bZKrLfkUpkFaHhcd3+6
-BmP2Ah+Dqm`R(k9(rdN+aQ6N-5`KFX@A*0DGVC6E!m)Mr6E$(%Jkqf'*fj8cD[d&
-e4S9LiCD#eIZMQj)EQdTdY*EYfY1G'pB1$36jZIERl`q`ZSMCP@pITJk&MdAEN!!
-FFm1B"Q25KX2IBMU$fem42@Q%ClK!N!"rqb,A!Rh48DK9,PrV)ABbFG4J,%TJ*[@
-N%4qX5[KN*lGTT@kT[Y%GcZ3%bVhb"1bPFb6mb)ra#8P06'RQ"!IJireh@6irIbN
-bZ#2r8AYKY2'URXD$XpaZ#H-*54BN69A`iAJlaFXjmqc`lL%2-GXCLP-2XJQZE"0
-1ET2)!@PR6-'jH*bepM@U@bEYI2`l6B60a*%@*`P*LfIM-QF'h#&Rid(!k9B%$A"
-6&GkHX$C6I(Dil,ipHbZGLA$F$eX40("(UH)1MVY,F9[q"c[bipZD&KS9[)pqTY,
-6i'S)*$USQeccCX000CNf+98LYeaTh&%!eY!!89GeTNhL-#+l&CZc6!)BK'dp*U3
-YSP`h6$415aN'#GG[ENJm[P9M-`eLd#5A*pU$NC%M[M*j1&jNbE4(&4eQ4(2XPI'
-[@iV+C#lZ-fHD)k0ddKS-,3fd*p-D9A3UdaLF5'FESiVqJT4KLc!T5L@iJeel-Qe
-K0raECha,LL'kdQ0U[E1bbJbI4q43lT8V!*!%'J93J!#3!`-e,M828h4eCQC*G#"
-648%J05ie!*!$$J93J!#3!`-e,M8$05ie!*!$&3"8!'3!L`''!!%"!*!("%X!N!3
-B!$`!3!#`!CJ!!3%!N!F""`#3"J%L384$8J-!!iS08`UE*!"rKN@`h6Nj%l$&$Pe
-,6NmGf`%9!pZaqYJ-9[A12LLS@(eX`@kXkXE!2f0r925rrfq2mhC@'FEU!!ZC03e
-F9Shd`Bj'pkj6'Z`%Xr-S&0c&iM*#YY5j)-Pc#j!!hfq#GS,Td84dcbPjXa2G[-R
-Z+i@%-ma,@ZUD8SSG#ciIQp0r"2"krMRUbY2UD[qIAfl(Ujrp3rrlNCBP!VJcDU1
-#E9E"5#Dm4DYXM&@eAPXqBTZhKHeK&AhF&mE5@NbNP,3#F4p-ISc$ekiEjSHQ'HT
-6frC0h3qk%'KDJ#F%b!#F!%bpqLd!rZS*!a&r!2#LFZ%#%"b#J!'#BQ!Y1)Z43Bc
-I$%,N%MVLkQ15c,dSF4p-hh6j4F3VE-XB!*!$Gd&%3e)$!!#!$9-,@b!$!kCJ`kT
-UXc#`!5*LB$G,XGYCPD!JBX-HkYR!Q&8a#f-UZ[HR8k`+#iPMb,ELGpB!8LMpiEh
-!JNUia8#RBdJbMUrCpbBL$VrTa[llf*mk9dmSTT%&(C'kJKQiSm8DVUKU*k42-JV
-[4Fi&!*!$6!!#!*!&#!!d!"S"'iJE8'aPBA0P)'PZFf9bG#"NDA0V)&i`)(GTG'J
-k!*!'#`!,!#X!+k!#"%X!N!8G!$3!,3%BL!*H-3#3!cS!!3#3"6B!K`"+!-%%!Np
-,!*!&!J"&!#m"2iJCAM!JBA"`C@&bFb"dEb"LC5"NB@eKCf9N,NX!N!1U384$8J-
-!!,B0@`Y6-!0hFbeQ"Z`CdmT9aMFdilke99E'2fp2lp9kYqiprq)E'J!!m!d!!1J
-f$3!!#l)Y'i'Pq!GfCr[jjDdYFp0@cGpCf*-4E6ZY!bFUCeRCbDlbH0Gh4)AJ8X4
-rJKJ8[N3-RI0#5DL'!59#J#kS$Yl9"F#6K4bJ',6dJeNIl`L5Cd'q)0q+c@'mi[e
-VN`@PK4)VLVPbh1Hj`Y*8H1AaB3%!N!--!#J!+!"r!A!%Ve99!!!"!*!$J!!Ird!
-!)!)J!#)%N!!!*JR)!#)6j!!L)!)!)N!"!##(i)!K$r"!)K``)#3Cra!S'SS)-M+
-+*#BbmM*10!Bj*QAd-K*P)Cr`)"($!%!)ri#!"!B"!!)E!J!"!!3!!)!)!!"2
-N!!!*b!!!"*!!!!!#)!!!!8!!N!1!!*!(J!!Irm!!2rrJ!$rrm!!rrrJ!2rrm!$r
-rrJ!rrrm!2rrrJ$rrrm!rrrrJ2rrrm$rrrrJrrrrm2rrrrRrrN!-rrrrq(rrrr!r
-rrrJ(rrr`!rrri!(rrm!!rrq!!(rr!!!rrJ!!(r`!!!ri!!!(m!!!!q!!!!(!!*!
-$J!#3"`%!"rrq!!J!J`!*J3+!#N)#3!L%!L!*#!)3#p!$q!JJ!!J)3!!)#)!!#!N
-!!!J+!!!)$!!!#!J!!!J)!IJ)#!2m#!J($!J)"Rr)#!DJL!J-S)J)$!')#!d"L!J
-CI3J)'8F)#"Rr#!JF-!J)$rJ)#!"J#!J"X!J)!!!)#!!!#!rrrrJ(rri!$rrr!!r
-rri!2rrr!$rrri!rrrr!2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!r
-rrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!r
-rrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!!!!3!(rri!#!#$!!Z"!S!)3J*!#B3#)!K
-)!K!,N!!$q!JJ!!J)3!!)#)!!#!N!!!J+!!!)$!!!#!J!!!J)!IJ)#!2m#!J($!J
-)"Rr)#!DJL!J-S)J)$!')#!d"L!JCI3J)'8F)#"Rr#!JF-!J)$rJ)#!"J#!J"X!J
-)!!!)#!!!#!rrrrJ(rri!$rrr!!rrri!2rrr!$rrri!rrrr!2rrri$rrrq!rrrrJ
+:%R4ME%eKBe"bEfTPBh4c,R0PB3""8&"-BA9cG#!!!!%Z[J!"NlA,LP0dG@CQ5A3
+J+'-T-6Nj0bda16Ni)%&XB@4ND@iJ8hPcG'9YFb`J5@jM,L`JD(4dF$S[,hH3!bj
+KE'&NC'PZFhPc,Q0[E5p6G(9QCNPd,`d+'J!&%!!",Vi!N!0b!!%!N!0bca`0TD9
+5CA0PFRCPC+@P!+@3"!%!!$i!4,GD)G+jbMBk!*!0$Jc@!*!$e!!Q*!F!!5hU!!*
+dBfa0B@03FQpUC@0dF`!!#f3#@3&G![-$"J(!rj!%!Klrq2r`bd!!!)!!N!3",JZ
+PN!3"!!!i!%5fm8lcY[&2-`#3!h)!!5fN!*!$FJ!)#A-!!!%`!#BL)3!",(3!!Ld
+q)%*eD@aN!!!A8J"&!#)"8`*#!F$rN!3$([rirr$,4!!!J!#3"k@3"!%!!$B!4,3
+GFA1i)pb!!*!$e!!",)d!N!28!!CX5!!!!BS!*L!l!!%V!`!),6iJG'0X!!#-6J"
+p!"!"f3(d!F$rN!3#([rirr$,3!!!J!#3"k@3"!%!!%!!J,B'`L+hF!IL!!!"-!!
+!)5`!!!%`!"#N(J!#@aS!!"mq!*!%$`"#6d&I9'0X8fKPE'ac,Xq!!!"!XNe08(*
+$9dP&!3$rN!3!N!U!F!#3"N,"e'PFK"b(4aK@[R1qJ(P@i%H83GqET6BT*14UHT,
+eK$hlfi9(H0B6dI!$U#L1N8h0Cq2k3TGqDC@Vm@q&Q`J@9lZrhZCT8r+TZ$)k8++
+`8fpXhmSZf!"JIDUP)VGk*fJIQeXaYV@6!j!!8jZi&[XVa+YZ4J!'$$#05VZ6LBN
+H%K++"cX0PA2T`+8mhb"PQqPfA-PJN!#P,fj)deA`mk95kQPPLSmUV*&SQfY6VS9
++[h9UI2`FS"#!A#9'H'3E"PX[YZR"kNXXmL6'lU[,'Pb9M!+dP0,06aAeV!lIhTT
++G0K+l0RbT6mX(&T'mabLP"a2NrJ*qG`+IS*'mKCHZY*5NQ+PEIE"&E1`,F*H0VJ
+(ZB(BYiLJmIJDpU*#meb#JPqY!1q)-RE&EB&8#2YD$k'@eV119U'f6HR%q%B&KVZ
++Xh#p99K4kd'DkQ!6-jIVe6qH@U)JNYGb0TBUGXF4b*T@S*!!ec@'8C3cS8cSXP%
+V'NDMlL!B@G'%1(5*4l)pKZ3S&lCArdL%*&6H6pVcd'"j-$L*Hh#RlGaLJe@#YQ)
+iq'Q)J5JdA*+e0ljlXI)3KVmY8i2FB6MBrPq(M#[qjC+%3DL9E$2)K90Qr20HB53
+cjUQjK2'"jSCpme@6YT*@0(Q,+P1hEZ3b1@ZjcDB60jph83pRb5X%Sk@fQJV@Z2i
+K&)$`9$+8Y"TDdef4l30NZU@ZUAY&C)Urhd"%ff&(P`-JEBT-fbqDP%@VHGNFFR'
+L*Blb4R0GQV9BjQ'pYTf2UZ#%fM063U0PQGdLrl1Qrc108I,)#!pCjX([LC!!fCp
+[8+4QR@Z0(P3SjDmGN`b(RMDR-f*dX(96bf0V&U*)+C+9'ljS'&c#rp-*)B2AmeZ
+E&1!39hic*VHTLp[bY5XjZ%-PCE)V8*Qi#EMB#LNYBJr'&XhKrVrNQK!c$+k&KUA
+keiV"cKUC[kL1pAAhL2d0&AUQNV'imp#25d1K4Sm@imRTD[RB2XfiFJ(`@'CrKEY
+$4eKCJ!A%kmj`#L)*jR6)*15r8&&S@+FX-jPF-kl(SrhD'G2)bYIrj*0SlJMZGYK
+ZpFd$j*T#`0beN!"mhRqZh6,T2q"hI@f3!+"(,SCA0%pSU2c@#EYS@0Thh9Bml"5
+l4k5$eA-RqfHqU!plEV"[pGQ"H98*rBLXEe)NjDJ"+d3TlbN3,Z0Pdh!V-HEib4C
+#TKZ05*KJhEaM,(`,V$&0N!$!YJlr22fi"VE'[-LeTF9E51c91,G4mBSH(U4+fE3
+j#QJNH[YPVMm"G-c5A&kFfE(CPDHVfB"-`1N19a#`-h4-3F!)Br'[Gm6K*ak8LEi
+@!K8bjB1*iQ!2KJNIj*YLZ!hRP"dZemV-c"#fj&h+%-)FTU&Z-RLl4ZF0,[IXX9I
+RJ,qPYL0kS5`JfSqUJ@Ad[1HKYiLGh*Lc[a)8%RL)!pV5Th0S08qjr"S8apHRq54
+dX#`ZX",N3!AEi1"FR1TrrI%q8+2Fq+`,aQQD#k$!L(4k#*XVb1ErG!QpY5$6SY@
+d83ePf"GfB)@q[Bmrk(Pd8NqdT`-b*)'P",BcRi3!im(I)d0PSJa82iTKGHm,krb
+ir*Z3!*iJZUXH5X3Mhrpam#lXmY$FmH"9fASdSAM+hE(QdmPZYeXcVX&JU$V!00p
+H0HbI"0[5lJ&eBKYfX!+a3B)!3I-B&fr[f-fS6T@ilrP8fp)KlJli*KPTbM5*SjI
+Bp8S$)LP$JPX+`J*+Qh+B2XhI`9XcbAREbp!!r29CCbK)$kXqqq"#C@[-T'$e!HE
+C"qSB!dMC(Z9bK-5rpmIi+))YXqL'b'[8Y&&-MEXDQh`+)HD[!'kULh!Sl6Me1TB
+NBfTI*Bpra%@iK*pp*l1KE)fQkV6GD!pl424(R-`3XLpNb6"[Ci,bE%R`&(#I$,(
+G'`pGrblMK,CiJ[-9RemS9(b9315)XpdRhPck45XmEklB*YQHQ#qYG5V`aB#lN@K
+4UjhrPULm'LSG"*dq@1kS03fSJ6lF56dU4Gd92DAAl0GECdq#A(T3pB&UC"!N3m4
+VdH(1Fh5E!P1GP9FcXe$Ed1p`R06QMhNl6hlm61`JV8NQ[(V!($6bbfV#b"EaS)6
+5VDV!VPfCC45lFGc-YJ9)E[$"4G6,GkJ,HJ8KlR8%j*T,T(ZD8cZecZ-60@dS8aR
+h'M08'Kpdi-#120URl([H(#1qE`!$6b0U"Fj[J2F*pG1B`(KGaf3QF$*d9j!!"X@
+fPGM&4,5K9GI$bM`Q-+d2Nmlp)J$#GcU&JX8Ea5cp&$K3F&#)+96Tf'C193lK2A!
+c'R&&Acq5J,94KS3AAUB#2Nh#M#61jH[H+#@Sb))2-5rB-SbMSbemZf(eC6aLV-*
+%F6PSG(cNU*GZkQReYb2-5GCfUVce[iY0X4"T)aJcP52fAmaB94K&[P9P09Y6dZN
+e00S-GlL3!#aX"6P@,RZ!p1LSC6B!NFT0E)5ei!(#Dl1qAK[U'J8HpbPRd$RdhAJ
+cR*HR0LQV`$,)iQ,aC`$a46RhUZ9RiCbE*0&&(QGpC655UUcb1$Z!D!XGZPYR+q,
+E2[l4*l@3!(VfJHR4hl-5KBbX$LDLc$MK0GdpN!$+@ridD@EajBq&6rq)Q@DK&%j
+K,I!Jhd1A,i4Vb$D9YHUhPmAJZfq"3)(kQjZQI*-HfNc*S-RkZH5A4QACbEAl+Uk
+h&[m[8))UAFeBJVc64BaQdk00%N"lrDUd!D(A'3,!N!"4NIlfkaD0RDT82GD"9kL
+"6*GB8kpd3N4`SdQk&RcE$,'VU$mFD-d)3"RG5ThL&P'iZd!lD9C$9G12@U[l6*V
+A6RK#j'DC`M2Kc3a9T&bJGKqKm#i$+Q@#kj!!F'dq90UYjPC"6Kcj!jqk@VBqZIh
+N"K2QNNCH5V3EcY69@HZB(Sh$$-Lir3RUPGf,`Xmk81a"bF!'c8-r+eS*C%34@mZ
+PZP"Z)'9c$)-59'ePaa[V*mBk1FX84f-bBVCG&S-dB(d%YJaS5L)#AN#IH#q21Hh
+kc$RE`,(Pf*`3"J)Zf$CT+5e-+ERZ%KGFZCihV+P2qI5k*PhJ98SAecDc(Ub)I[5
+#Vr8LpT!!i%bEZNVmC!EDPjq!U8R2!A-qDhN`rLV"iEF#l'D$`AqdYY2[a0AR"Ne
+b5m1qE(U!qM&)SHapc$lTCQPT$X%$qMhTJ8EBFQA$e1)TT9!N0P"m'8-p0a5h8`@
+ccr6KA@l2-e-3``!iBic*0*3(Z!m[H#3#qj6EMe2QX1A4D6-53j1HkBPV-q-24@a
+"b)$*eTG*UKN8+4,KkN)5U"%cY"diF2HI#[jrTJ*[*NZ"PAZ"B@94MHDmZ'(-[(8
+$+l@`68[pqhRjF)U$m[dadi(G$CRL-X$UX#D3!2F6M'6rB-#20A#X991hMS+-*S+
+B%5F%YIfaYG9D`U(FN!!GYk8km`)rX%HVE-SMIXZGZfk92Zb9JFKY5Cd`Up[1dBH
+rKlXHf#MZ6*[GbhEX[G30`G1rPK3`)A"`0d-[,"Q&9PBjm8q"TH'J'UGG`H"U3b(
+IC%RXa&Ti4UF4QF`hM0LL4V42VGK5NM*TPZ%Q6GcD&eeR84UN6@8'cTBeDmp9SUj
+RP9I%A#3Y1KN)b6MFKENMFHcPl)FDNj(F8jm`qTV3LLK`j#f%U!!99jIPYU13!%a
++8#daH881[H'l6kcZ91#6a01ljIA,(Hrr+qFB1cLHPTB*1riNa)kaBGb!9)TQ[IQ
+$DVUhS*(+lKAdek,Mr8QT#IaA%#qq!S%qCrEhQidQFZPE#V1p(ZC6`4LY!c*dUE1
+QmM9JNTh2bpTG$k0-m3``UBCH9rB#0$GRBqFAa1bHaP#qUiV&PXI#l(i+3L+2Ve1
+)BQlLR0KQ"J#r4l*fAEF1U`$CL@dikV!1QN6QiQ&FNI(VeVSkQFd)drG'98E%@dY
+pT3bIr2K38'dLG#-P552[pakjcH0dKEMfCl'imC'fU`jAQQqKbbRj[l0aNXmr$[A
+18i28&9NmC(hKSc0jBP1MB&U`f,Bq04!jeXPELr,XV*RXLNbNbrJcVE[FP4RF`f(
+,4PHXpUe!%dNpCDRQ+Nql$P5V3f5CF8%HMbE"h#K1'qljV#bSYJMH8%-YR1)Jr)6
+mkdPmb8r2PH[8A&9J0)!`#hm@IUN',)dmV)2G&cL%!VfA,+Ra,q8,Q0de6Kr1Ne5
+l9fe*GA5e+(@ZLG*"K-h2bq`4C-+E+m#e#1G!,%p13RIPJ5C5eYHKf+JTYJ&rjNV
+CY*X$Ak+8QFNGk`U&VCa39K[p4i,[@&Aer#iQ%AHUc2e+-*U2,FK%[rfrd+I3hC3
+[lDBU)3[`F!CICC!!*Jbmae9JllV!$88%jQ$8!R&TZM4`iI#H#!+db`Fe11'T"UI
+C(IVDJ-4+C3Z"6*lp&VKKD6DrHb[QrcDD8(0!q`dL++Ir(8dhh*CXpYFSelRi!4`
+LU6P`MFA@mX0CRS4F4G'SaV9Q%&B$+!+eCSmk5ef'Yl,9AV19X$NcY(%$[G"Y4Rr
+k@rrM1R,P(H3rFpq"h@D)--rE-+K`J-hBk-j(cd&ekU"A#B4#L9lh0*AAdEdPS*0
+B[BhD1QFTD+V5hbB2SVN*!S`HQKG5YN[-JUf+#e[Z$HdeBDahibjlZ3Nm1e)r6-F
+dXVfLm%me*2G`3AZ&!h9ZYpV,V$H*'QY2%k(BRRpXa$J'H1c@[b-ra6pLJ%fjVa3
+19)QNHTr'6"0cEUpFVP)fc8P(K")CTXSLccLmLkRV)4f-Z(c2q-E6F'JMbpEr+Y[
+,!kLIePjSP2[%-SScFpYf!h-$ZCJ2PBeE"Q$Q3IjYa(ld2Tj%R@i+3p*-H@R-edJ
+(5&AqSr#kdilSISdh'I8+0I"a*NHZ#1d3[M8p(&*+J',UP*,8Z&1!Q%kJqJaXHkR
+0+NZKC`ACSC5F2&*NUjQPCq8jGUKSlG"9f5$p&Zq[NrMbX&$!Hf$jQQM5UY%5!h0
+H#blD1$Z8h%[AMe#L)YYH'q5m%*cZMEL'`VF`N!!Hj6"a%QBV&l#D#LK'*9NKeB3
+NT3hQ4R%c#N@4Q!18R#1X6&'%406jVQRR6[@BU))-+V$8-"VFT&U3!!3%ZZdQSMr
+TmR3*V`%CKPQk&8%'E&h-Tb46R&*"b(DBr#m0a*VE%Gp9FE-YIYF(aE)[601l,XK
+)XhKLl-'A`"'UAN6hkZB@@&S0kH$1C$E@FXNKGB,aL)6S!b1hVG8#kG3604AdCUJ
+e#R+U"*%3SPjZ1RCM%Qa4[KP,Mci8bb(J5P2c33r0,GQJI`(NfMPl%S-iQK(N+h3
+h&PRG*B02A!!iKI,m!B&!2Umibm(HJdT)V998H*)&#jl-F6f'(b@T(FpC&f1q[e#
+eDH`[PPpilM+CV$NR$1IG+XpX0VG9m*6)K`3LlVV,"kG%*m8ij4K%cK1!1*LaR@C
+f0,8KLN%TVNQ!p2MdMbQ',J8Kq#i1'Z5lGbA@I"Fq+KY!hHUp&C-)-U['9%"8EK6
+VGe3dP-VkZi,qG'U3!2f5&&!)Tm)b[)S#C6Gp`Feh&)&0hY@$"m8IdqdU8Mh&X1P
+$kdP6K,cGrlf6"8PebC9YaTRjiV[5KL+6L5X(!Q!hpK+!P0()%VV,IdiFH'mV&9k
+XLcJib'#9FjCpUk#LF)U+6"8$AA@BS*6qf1dCIhK"rV`m(5aIRZ-U'HELMi4BG*q
+!#Xr8j'Cb1Y(CSTY'DQDQ9@FH%0efcDYHZ,$bq4X8JjfSFA)-E!Xp',FkZ1NhK32
+MSY"(b@pGJRTDR+HV0*CJ!d4CVi@m[A$m#5"$L4,N,#dGa9i@U,)a"VTp,p#)k)L
+k8%-U8(+BV*')2LreL*b1)%iCXB3rbGI#-GA")Q!IBMPDSj!!dA$R3rp0&Le"`-J
+("XCfT8i'C6[5V+B3'QlG&pQKBB[[!h!S`1C)LYkXl#2QT"[r%Arb)qRcC6*`5r!
+kS#PLI`-)aa1L+$*BEa)RqTAGpe-jQ2eZ9MMm#MfLdN2YId[Q$l+-9IbqUZ31#EC
+(l`MAp5`V(29c-pPVGN0fapQ!`PkFGT6QADT"JiaeVQ&R3,3(c2aidmXDCD,6f,N
+d(AAk0qCjaS#(8$FeM(%ES4$YdKa(!TL5Th,qZr6AHkCRjXPl+j(ZbR*P$N`HQ5T
+J88#$FGUdXR`B,G8l+bBXlTK()[[c4M'D5X''Rjh)f*E56FlH&ia[!j38"CZL33m
+CN@"+)hLRCXjDLDlT2!VkQ"N@+a!ES9N"qSAQ@'G6!b2*aA5SSGHcbiL`ZmXRFCK
+!$D0dj@&#NeY4qI2r6F)#N!!B#-,JfBXq5f$G+2mk6XBR2XYS,kfQQP$SQP1"8eS
+9FpeB2BFSY54FK1-9YqH3!2!PY*K[Xr$HkPR8+qJkCdK%G3a6@$F)EB%4Z!5I@1R
+%'MDUbEe3VhE6I*`0VK9+SPb+V@`2KbL,q)'mhlZNJ%`5RVK2Q#3!!rN4Ck-)ej[
+Z%jQ0FepC8qm@RTRNFcH@VMSAbI0r[Xk6pk3D8-i2e4&,Ia2lR*j$clBb(M1RdQA
+CC4K[-$J(AV5TaQP"4Ar,4F&UB$f4#kim6#!K8HpNA[$'`4b0iG,Q!PT'+I(LKK*
+D2!cHl0%KT'6$(TbHE9(jZ*p%qF3(+RCp[Qrm'BA(ml9(F%LXBHZ(DNXchNAVpQQ
+XE@H*3(1Jb%l5l5cTFEXV+J#aI&#,LQiml2hjX3HffH&AV3MJ9rkG@2Y-aJ01UTa
+rqVFiHrZ6Gp0U[lX(442LXh9%[paqqY%dkJ3iPH"VEF@kK#adN!#@cDSh3'LMZ8A
+'(,6"4$(H[#l$NYk+3q$YKN9$9NR1ejJ6G8j9%5Pq,PSA2TSPr`*H&PjAHL1J"Z(
+K2QAR4Sff%eb8"$iETR,+TL+lF@cVNKP6Q!ZJr9'h[hTaSq!+SQIaB+bD"+6V'L,
+!V-aZ$!Hmfh(eJ9`Ua5'E,#)bGi32!eadACE!CBBY#4&+FGahJj&'%P(pe%8'(9b
+M%M6a*8H4+Sk("H3lpP6DFV8mN6jk&JV"0M@rkhMaJNm)e%N6jC!!8CSp'0C*p5d
+XZmUIU5SQIi-A8-q'0Ab!CTrKa`Z3!$I#G!+fSTVXT*)Ui6[RHif%9r+-ZCRm($A
+'DEF0f-ZVC6iDZJ93,09XU+TEDV3ZfbpYI@[PB2BKHdia+e3!GG*`bB*-+VJfpNY
+m[,N3i#deR(p,A[L(C$Jd'Ic+EDh18Zq"jIKLGNildLSNFUidB-P)e3FV64Tjc#)
+U&H25QYI!-i*'`fb((aTHPT80dM3U3h$C+HJUK&rSphAmA5KD6UI'TFq!k4cbk`a
+YfIN!,a3hK@MmZ'NX)8cR8qCk-q#BG)eR4Z6mM&%XBR$2!kU8L@U[fAF*9SF"R+R
+R40M1mCfXI(kd4QA(ld$j66c5LVAU0KNPV(0m9[q$i!j35faRT,mqN!!RR,c)[48
+j$%0!H@IbK&BVH8TqS'*BB%Y6hI6lc*R%Y19R-!#J(`kG*dp94ELNbr*$T5VSEhh
+9HbqX+'Rl+5BCiRk%2j)"6Jq&XkQ&96$da3YV#bRGrJ2clF8jFHjHrL")Bh$IPPI
+T6bd90&'[2c![3NLFZDRplq+*T[r1[(DRL1,eiEG"ESa19AeRIT!!p8-Z!ie[NDB
+HpCYhjqM-Uck&f4rd-&Si*N"4!3Dii-9d0H-M'C*lMMQJ)KkB`PGqUN*V-CN3lB!
+NLP5PfQJ+[cdH,eZ)ADh@$Hr@VYI0N!"69[q+(,VX%JpdhQJ-@UHbjIPG*b2Xjk0
+DH&I5YfZpaf!Q(-6S2'[IES5@X8#EBZ!8F@(YaF@0Q(A,+ah"!ZHDr-*2p$XfXkR
+QS%rT4)Ic*X%&(Z$1rmI[V1d`&e$@AK3LP'HDP03!4G0@TBEMTqbHeb'U#9*9mGH
+pBr6EZ$@FQIpC,MkLRNpB2elHKh$KPl`5pFM&kCdKIEVY))0GGX,X5-Ll1,-dfr"
+,q,JQA#i((VQbFlqq+H@2BKF-Kip8bl[%KcK%684+-d()EJAc(&%Gk*IK4UbNh3*
+h[#9NPm4AbH-%*Z9d+`TFpRA$j!8HX%EIri`,PRcXYTp*+Cq)ElSfc2&IRUa+edq
+@MSLU@+l#j`H-(YrbM8,`"Z8@MCVh%AG!e19"*D1-1Pcj'#+"3,0(`q%C@,20QK`
+YhU*prPL21,Jj4E0D`CQbeYMAb-*C)U3SjP4`30cSrY1U`l@IATb+m3Q4,@hFMIZ
+!USPPf9Z$,fKj*eAeb0h1$`KFm5iRJ)4,HN`Y"BfT+TKal6p31P(4Al)TiC[da&H
+!T"L@f,NmiYG[AT[fQJ'P4a2mPh(6%X"C9$"eA,)8CYZdE+GPdJHlj(4Ehj-"Al&
+kF&rN,U@pR@bFD[DDJA6BX9D$Iee[NCcN`Ma#XLrSMGTP$+,KR1H9"QV85TF8M*V
+#Y+HN(Q*'1,e08TDFJN90mf3TmBf#LJJQ$ST)T#[AGNUa$%0,j(mZb,c%2Fa#-pj
+Fp1EkaaK"U5S!N@+-#CS&MHUFT'X(limlR3KU,&c1KP@mQ*C*RMZrY-6%4-jpceM
+*E3eVHRXfA`"0PTA5C"GjABqEj*9D"Mqfj$Pf5AQ8VTd+VaZK0C,AjfYPqhB16,L
+H%M#lY(,pKC%6'l(l+aZ8e-TVZiUP)6c"+P2-'f`#KefmfdY45EJd4aUp+rGHqk%
+#(d*6+8ic15PkSX4Kj8d(m--e#Z2d!TN9l)M4P8ZK%%E$*kTFBMaepNi-PY"cEbE
+5@QH8*UcJ[jfM$E3AGS%q1*MV9l$FeKD@QMB48L8p@CQ())i9p[rNUebCEm!Yhb3
+lZ9ESm3G[$*Q6K6chFR'L9`5mHjHR[-e8%YGUce[ar@pYGqc1NYYCil-hj`$+9Bl
+jH4RXZ#9M@YlH1f1@%m)9E,0IZ0+DP3!3%rbUi`kdC5!-6"eGCQZf,(&d+'eM5EM
+`flh*-1"Ml!YFLf3KkGcicL(554Vmc[c86XffSf!9L&X#-%$"qpeih8$*8Hb#9`I
+3b`6PlA!2*(DUEMqUcQmr+%9GXc*4RYA[SNi[6m*l-5Pfbk@a9`38drlYK45ceYB
+NqUPS,X@+NI-Dj&mDHD)YjCqZJSre+q!#@RL5cX`K3ahmI!@G-XaLZ,,qLj,'jDc
+!2Qp+HD%k2d8"bID[6l[LL'E`U0",qB1SPVY*DNYDkJrc(3qqBDc@bG21`hAKMd@
+Lp-E$3d0Z4lBhkX-0P"V")([8mcCJbL9QaVLrM4[9h#k"pd&VF4rUMLmA*$+jbVp
+K,JA&-UHj-TeKQd[RKZ041)@eq[,Ma38&Y(AhAQqY[af[@11MF1`H6V@aZ@e$+I%
+h"KC3`d5#*)R%#Yk)@#Rjl#mNfbIZBMfVHZeV14cp'q-8,$fe$U`fqf+`PeX3[Fr
+P&G*G!fHUl5H2K!(U25DMX$Ed)+0kjCRKRi,&*1AfXlIjE(r)BbV)jE9C*'NMFbF
+Q3+lTbi%dPFK@44EMkA3i+!G'0G0L0+k(Fmm,-GD%LCI*CiS("Bjr!Mer6SUH+EP
+mepA'BPKR5#M2XH(A%'!+cj6Z$3"lmE[c8kBd"0hNkZSLNB)m4ECLAGV"EVM$X$@
+j)0R3F@Z$8jQ,C0N8(a3kbq2,@HPcPrAB#LbR'mZ8Q5X-e%2)XU`+bpYM@q0Ee)p
+3!8HfJ*fM45#D0kcCQ+M@r5`MShZ4YphA$d'aMBP`S*E$hRlA%MTQmTq2YaValdd
+l$6JP0b6*"CpQEad+!4%C6FG6RK+0A8i[459Bi*!!Bmr''aqp''GBbG@&4U,5`F1
+,pfREV48KqC1'6UBT"Dd-U'%N@6c,&P2[284AHS$&**TSV4"V"9I#-`8D$8j`Ij,
+"f4mSID(lY5@l#2HdPkDhbL1Nam%EL#E6@PMaXZCU2hdclm%H+)eJFKB!61[Q+QL
+"2(qb%LV&6jD4'89L38@LCYq+YC!!R[)-88l$ZS'&[Z"!(hBSQ"M2BU@+6F,BmK(
+bZK#4#@D`QC!!&Akm&IhVV)5($)l(-%,J5ANJB!S"DkSVLYkk40jmkST-#2lpTbJ
+2hfFe')M1E3YPrEM9kETI3ZaVK&,)"DQ14FX4)6D)%X(89Ze[5ZFVZ-1NXAID$*L
+c,!A@I[CGMhE8+PTkJZC,BmQ`R"6bbKJB!RDYV[qNKFCEe[ZDm$-6)0NMQcT*cIe
+iX[*NSe[904PicU9mbp%ZrIRSkY*`j+Z!S0LFI5DEMj!!Ta9M+-6VLpc4Pb5*[BV
+1l[9lp&IF@1qr-*C3QI!PkXF(+*)"K'l&qQbp`4#4Jp`24@ELXH$,pU,fI*XBfdd
+KhBCDTiL!(iKU#C4UT4MLb*,10U2r)S!)(E2X12G%&2X8,iX3VF"!99epAB`Yl&I
+Tk'%TPeDX-Li,B%4hIphIlcfafKaflmFVLpS2J`8[JcaZ3lTMqXE5c28*jU4$H[B
+"iG!BBQ-K*k%'mif-#jLRqf3,pp#8`EJY@Km)h*KMiV#5QK9J$Gkec%aY"h[Qd@E
+ED!CRMP6KkbTd1I#ZBLr9fZL6dC!!")#[5(!AU2f+ZFc')DPZ245mArZQdUT5a"q
+q-XBM-Yk(bhedR(ViCmX'`%I1V)Ge0[BEPTc@-b3eZDd9SMVF3TSU+T&R+4!B4"e
+9%SY-1)`@jkHFY(e#5li!K&@aQ5$e-URJ9a)!e'"2(3[(RD59G)Lcil+A4X`Jj1)
+!1K(T-VNlcH-'r#cB"N1[9FE4Mj9SlN1fF+cA'mb$MT9DaU,YR,qJd3+kHep2F1R
+&%3jE9,Lp3XrEH9F(ID2IXph3YUR"fD2ipbdC#43XDcr!Z&'VhFc'TcN-`8&4e&S
+B5I5KZ92PK!h@JQ'lbMNcC84riDQ6G-paKX0Mek-1PUjm`+@3"!%!!%3!%,JMfUZ
+i)pUV!!!"LJ!!1aJ!!!%`!"3h*J!$lbd!!"Nr!*!%$`"#6d&I9'0X8fKPE'ac,Xq
+!,RKYE!!"0cC849K83eG*43%!rj!%!*!+J!#3#3%k!*!$0`#3"!m!3X(9#he9rJK
+eEik-8V@kZdUV2E5CM[,Q!QPqceI`p4Mi%Ir,pA,iSf5%CNQ6JE&I4Gf(b46X!%,
+"e3qeE'il$r6I&A"ADfRMa1#5dEk6cNSf[XQ!TmiKlIrJQhrjCrdk19B[NbM#Yb+
+G@RAa!kLGZ(1MD9kqS9ApeVSdPap3d`N1Br2+I"Q*J@!+rL"ETEVKLPZ&Yp38NEN
+D*9c)B*3B#cBVKMePJqq+N54CZF6kC8ebd)VTreliJRK9)+flaCX@,8MC[(98m+D
+Bc1NQ-BS8$+DZjFk2`-1AHq9iKPS-c(i)#8mpp!$DeeM!ZU3RYlKqEf*m,E#q3jj
+%C1GS)Z'G+ZA!Em)8MHeh",ZcUVb5T!"q@Y963YbCK%RNrDZ@KZ)@C2($kP*bifB
+YUiYiqFrb+FE'@4A!ekR862BZ-&RM&93LAqX,M4m5Vf44"c-Eh1LaQi0[@lA%XaQ
+LS,#(*RrYhRjS@09-1'4CBTe4aQe98m"I5MQ6,MXa93&DKE[qbNmV!NI,"[h!(hV
+'4(R3[KDKJT4Uq-(eeZ+YLcdfF1"TVibCijf+VAddTYiDF`0FF`4-5K9&88eB$"R
+8&B&3NIkPPd9QZSCD(G3)18pAV,`)XDmr0+5B5)+kBVe,26(eAK[#@(I`YLAPl&S
+5H6*Fj6VF+$-3aCr%%Y*EMYC,#iKCpem535(irl4I&jqYaM*f0YcR%)!b&S)f"de
+#8`3TH#qUY(["SQlKIqV0NR'fIbJFQlNIE@!H(-UkfT[P@lGic0X$lPRkLY`VAkk
+b@1am!KK8YrhM5(b5$c84(kjdb8')k9$R"j)#)IDN[i(HTURph-I*JZV-@T,+,Tm
+U&0d+(3kp-6jZAJ853LEXAE4Z5D@A&1X@rM#SZUCqe[9RKEQ)8Ul(R6m5MT3P6L5
+)h3'f$ef!--fq@+TNbVH)dITkR3P#@)Y"ePPHBl8br$624dXMb[l59L3fk4Qie[f
+1VEbYK8F5L`M6mcScBqmED4"C6%'rpaZ4l0IJp1pAJc'4K'2KCicl2Y1bQLlGFBc
+A9@rm+RPV9QZpMG[GTY)YPm&K[M+[X,2%JG,-QBheqIjlEc2#b5pBA'QN32kXT1m
+3,5&a0Uh,@*!!K3#F!+qT+!@5Aj(r`Ic1EZ@YrJ98FUk'(q+a,hr'IHJEm5(6BVF
+XE-Tm@lX0SiJpa+aadrc36+K9*cKi1p3F1KBq"EH%Le-#XTVaQlBD"L+(U),2h9-
+h31$Y%4elh[HiJAY3@@-aHeB+!e1Ua-9K'ZXPc03)3bH`j!`h*8c1iX5q!bJl3D8
+0DRdj-F)hGDIMCQjP,SVhU&XT,E[Qd8(BQ%JJEJ23M5-5HBD*+X[QG'Q2M*5rZIS
+bT[e)!QBqT!,Mc1G'lIJm40hD!-5AAl'15EHX9-qZm'd58i23'iTDN!"XAKAV(rM
+ikQJ'jS!U9fa0JJ-cRT[PjY#r-Q8I+$m8-`L!3RpDekGN#RA)h-(fAM%bMGr$L*2
+)rQk4jkMX#Z%@!,9+8JfGq5K+heHYZ5S6eZGce!)TU4m5Yq01Yh,ek(2&TL8cipK
+Va1-X)"P*2V-Sp%h`hBmkS)@V-ZFljqJ#S2$J3$Yec@G`Tc4TA8k6X(&M3PeAPjM
+NRGUC%*hHeqkpP4rc5S2K%p5kDCIVki,@#YhL+1DMG&!5Q*XiKq%0"b@1[&V2d!M
+NTC!!MrTh6qR$`8N%C4EP[HY)k(p@8m`aN!#[c9m1hp,-m+e(`Sl,+VBX$$FEklI
+qhQ9bV!)P`i83j%S[&R[PrU*HlSaP92SUU6Per$,e5),i[$3j@!J)YRpeZBIa5@1
+-eYE3l@jPT5@SFfdrce-S0qFJ4P8dl8Q,(U$PkH8"C%H"b!6JHH4GbN''1$M%1bc
+@d[Y5Y6pCqFFDjLfYYH[VI%Si4@BLXl'$-DS`qcXA*RFkCNSJji"93Fa5K(Z6,3)
+j0DCSa3YI+$PAbR60j*qQ*jF([YIEH!3Z*i&"H88L&4M-J08k,c3YC[BK(E)MT31
+8KU%DFp#R0)mXp9S5[&MJ8ZSVb@8#*Da%AHQP$PP&RdhipKp3!`h"JhilM2RIb#Z
+#+@9j#1fMlqd9D5lcHc,$8iMhNmKVARZ5qAeY)Q"dCD9ECRjj,@DNqD4IFNLl,P8
+dD2i8*NB$ajP!M4kLEGq@r4"f98YPe&++bAYd(&e'$46*($L835HQ5l`4BYiDAaZ
+p!r+)Gk98+P6lbX`4ZP!%mZ%Rq984*&-4IM,SF"QLCdkKed[-a@PZkKK9BZQLC0h
+&K4CTl!I!pX4q'(9Mm@T,diA60Ki*%iL24pq@LS*U6(#HkN,PJ`35q!NIl5Yb`2D
+M`*!!X2(RB#`eJDI'`Fa6cPaSi62IZ@B+F#L[ADmM"3JPiRe'cej"X19P@'TPhBH
+%*e5d+5[&P2LA"Z%"d(@@+MrXM#)D92qP@D*(faN5R-G&BB0MHeUGLphC+NBS2JV
+FMDU0&p!pdNYNj-+X$%lD@486G411QS'mbDhmm)Tcp'#ZeiQCD'Zb*2eZHbAahG)
+-EM`D43Z,[VmppYkTX4HVI`p3a,J@1Mkkj3[laNe,h6l,,@$cY2QSNp93cC3,+f5
+bMBlbib@Bj5eHJ5GS+Shqh#M9@&1#kCl-M"6rkmd6J'1"([[2$9ZaUYj5j2b!6F*
+AT*KNI6-@i9QB(LfD8k1!K4*"DUCpm+MReY&SV(fAk)m4S+X[q3SVr6!&9&Ul-mF
+VPC%,e("H&Hqf3BJG@qJ'Vi2r59k+aVLUT@)CAp5FG&c"AlLM)JJqc&FmL-B%#"$
+%*4MbKe[kVmI,"3@de`f4fTh2ABUMBlN#8q,6D#aG9AX*hi&G'riZ&b8NkAk'#1P
+lZ"p%PH2&*S`DQ&&)&YehPQC6"D)M4(J)*9!9r93Rqb$P9'`MY+EhE1(b(Ah,@Sf
+C(Lid3R!@364@LJSLFI,aS32DZii!U&CpDb)Hr!%6())3*[&2j@(R[,P'-P)L0pf
+b@HkAF0!FJRX32`[E&Nq`*e$LH9@$A'%F3D@YGIKVAB2HB,4NTRVN@A%4'ZM2D0-
+@ZEp5@TNkKT2H*!0CbUU2clZp5X"DZNpL$(Xkaa5@Z+&(1Yff-rG2ip&MMIX14r&
+m6VpPc*ZE0J)GA'L*V9`NM0q6%!QG$p[A)MbFiNQ-M@e[6FVq[5!QME2IVHjL,A4
+r'VcQUk4hp4Vcq4e906aPpelE3lEm5A$(+6D9'lkRFfm6"VPjUrD3!!eVNUH"4H`
+hmV(,4dp22ShQp&LV9pmI'qD@`4-r[A+3!"a4894-hH31RJ'cmmSkSIc[fk10-kM
+3*GQHc2E)L*CaGj%f'$+*0%l`M[+83GBL%22c'h'6C&'))845S*ZaEqV-AdjG`H`
+Dp2f@Ue*IJ0A)'qrZSGUTTMe-klYBYeZeMj3Mfm,)$dA0f&905YJY4db-a-JfZXP
+1[+EN6Dmka"f0$4!Xmj5$[HG"fL!2@D*AI&,dVm@"Gd#)fXV"B49qq+GDG+0XD!P
+C@bVq9NK30Nra*JR1G`*25B*kJSZk`"iMm14V0G"Y$P%%jbNBdd[AF1fCD+a5I%'
+TE#SUD9pqmQMIRIXL%"MZdI#$dMRC`8I)'5lBF+ieF[P!qXkRcE$N(Pj!2(&0Q+T
+RTiT[m)[CcdC`dJ'503Yq%6pjcTVp-&#i'FKdBbJilqfQ'XqSS8G"@-#Qh*hpB2q
+!Q,M364iaEB5)mG1f@e'L`@5bc4+Qd2V`BVM&a&)HJp1m)804d-hbdlF22Jm5ZM9
+H"JbFLl5F#j2TJA8hRTGRXfe-qVBcHBYdYeSIUGIbL6bA(1lSm"!@'Rp!8`%mF%K
+XMA29RLa"Lk!HNX%I+mK`CAbP9Q5fUD$#*@JH`E@TB,rdMZ'IfPAii,F+kD%BcMA
+cri@*[Nl*cI66@&@*f@*%K4X@8!jeRjLbjjqX05@cif`BKXS1+l`RG`QdR38ji6$
+Dm@5XUl[j)01GJFZBVKK`B1MlhHB8pFl4ZfdY5j5NQ*P5VEZrCF(pq2fVF"pTJm,
+B,2N2$RGAiK&(DCT*IQD2UcpApd*!VEeIkRe1)P4iMbKMr!Z-h1I[hPeBqYm'G6X
+ffP-"HccL,0Lf4DT+6m*(8f3a@3HH,$ZMDL8fPU+JU@lVmAmZMSB&0rlm,*JFd`H
+#&5ilC,CK*E(12e%kjRSN0-)pV)rB&9qQl[a@BBDj(YAaf)JD2cFKrA!LNID`mbP
+@mlj%I8[C)@%IVf(B3[(H2#![ShDC)R"Vm%M9erEm[A0[!*YHXA0C@BM*1khZaZ#
+rqYJ-C'%(@lrC)qiJh`BYU%1K!c%JVb0i2QRq0qCh"A@Q)"LeXQAQ4"m41Ac[Gl"
+Ic&Phm*R!acV%A0%+6)`pFqSqm5E*lF%(EKCM!ldM5Sr)kM`VVp2q-'jeF'RjL,3
+Z"jD&RaAZ8Q%lfTIl4-&"2&Nk#VjhrXCV@lD,92F%LP)#EBJf-e43DDVqA4,SQLp
+jJBZm*TpTUcQ@A9a5@Pa@2"5R!L6kaS'[GKYA65ERdmRPIej6d)cAl&C"%ZhmFcd
+452Li1)EUC#,MRiVCp383#F3Ej@)%H'SchbpUq3HRR)cMD#+2a!b,mX+K[',Y30Y
+AkcA%(JFA"hP6lQdmBbpR%J25$X40dKPPM3Ba1%0&[)P$G)"8"imm4D5bDG$&T&B
+eCa)3@fTC-D"l+EqFKQZkFS"2icra6!b&a-DK,Jb,ZFN&)aFH!MZDfhhH)4A2FDK
+$CT8)f+PZ`(iG@[1-pMG8"H4+-a5$AP5DikaSX@+1FHHp(cQpQqijKl6mr#N'VkT
+J"@KFkUF4U,fS-QAL8fkc$$#facNA[[Y"YHA[L(#@XDV#qEm5U6b89!2'6rq0,jP
+c3IiL@%PU,,'*5a2X'"AQdla%U@Qd4D`!hk**6$#MCCd,kUH[80T1,`Ze"`JVmA[
+GCB5pU`pX4KNC!G)DP2e"+1%HhiS&C&9"'3m59N5eZEb*`L3*ca1+aYFT2#ml(US
+C*iPNqc8RKRC#P!a)UjJI&44KJhm,NLL*QC2MZe[8%,1V8pVUhhE*+pDEa#GA!qA
+JC!`9mGC`cNBZ&!4'Mf65XECD!6jRP*k8mIVJ@!)j*&e-,-0*6pL4XCFEMmFS!4S
+mQfZj!cfNj'kjY*6dA*!!L',Jmi-URMEM&S*lL[`HZVbfGJVMek,QY!hDRa0%Y4%
+rH`ccSZT0Ylal-Z8K"fk@Xm)0H#!K-EDAq0k,Q)iDd2B%lj!!FKRM,5C[DY-hlkU
+F[T!!5j)")eq!`XHb-J,8lp5+jI)iqLXi-jbpllG[f*V*+*T1"FHJIpQ!bf+*KSa
+"*+$9NkD(kVN3fpQ!6[MZ0@QqA1#SiRqSj+ZK#(+245VJFSUp&cVli%DY16l`N30
+K0e"apf[Xkpq9a%#QcemN-A!h-H@mQr+adZqDQU(R*G(PFjCpr*($JIA#KB9F@RZ
+![!G)P,[b1,JEKB9hj5'6,IUGNc4hPB8lqH6IpE+F6-GGaX"#6B-f81c2R@-S8er
+`5%'CRf8YcaD%#mR'"YLj-6L%NMa*3!N,@@P*`MT"TKmcX8R,-0RDk"FECZ5M@*(
+A1Q$&&jX)%!Ajf[ZH@05C9`5A6baIC'*$B1&0KCL2ihEprR-#*BbmZUMPN@*34YP
+rRUBG#&Y',36IAXAlII'!'i`B5T*ACjlGj-P3qUjVG+KA@6K@j-JNM!&kV0XXP9h
+%PV"C"d+6D*5X`PBSA%QQRdaS,F3ZS3PE[MV!X6@EqMpeFZ-BQmPBEQmZQ[b1@lU
+`-,8"[Id-Q$mmQUA1-)06!4@V`9PZ,+a[p(82N!$lq+8NeaZbbQ6rV8JCRFcJ*K4
+5%2+ij'!+-1`a#UTBiEb(XE3+M9ra2)D*&%bfYUYJS&%Z3XKq2aMeh5R49M)!8(J
+%mMDUN!!f-XiC+&r5EJZcc!fPrNAdVE2)Mcb9EdH(0P!miV-%&FUp#bTZ,hHcbb$
+l(Up"#*Pb'$l+dN0!%%LmP3$pfLq,b"G%+252EM,PTfK)U$ffR%amJq`aP)aVC%N
+dQ,lm%%HMjZZQ1kc82V3bP6E%,$$X)69$R3c#b(i)PbibXCbGH0'!j%*D#E9qDU3
+qV`!aG4AkkPr['ah&`q6Zm8a&Hh46Rpjp9CZ+([d$EK1&M9P#83l@I[k+K`bN0KS
+bH@kGD&92k45BZX31jFd(PCce9CH`4&B[R(5H[aEZPMieY(DN!!RN'`5[,XF41&2
+li[S&fG(`-3e%L(-&lKI-D@0K'+-+64I36Hc01%0&5Y`khQVdJaiN4KbZlDSET+A
+'IT'2'2plQ)['Z&hq5I#1BRVRq2CNNIVpia+A2h%UU$ejXI8``Ec(lr%iE'')ClT
+lr-r5B@9B+,L`Z%jL6[DG%%5e3I*"M+SGkL!PjS!#CSFUBD4+e6[I5+TX)CiF@HX
+GcUFIb8&`6qhfp-iVR&'*'B!Cf4j&L6k$K!d"-0`6(jmRD,@dAV5Z$BN6dQHFlG`
+XiA%biFfbGA3Q@'TE8fbThYF#G#@cZABN6i@HPBFfG%QA5NV$'j`(CBiYcTik&Rl
+a-qXTm'`j5083%laY*NA-Y2UN'EfrIRfjZ[``YmG"GVCNapici`4d*5Y"RPeCNDd
+MT-,edHGme#*b"D"B3jE,6dkUGMA"f2M2NGBbm)qi*TP"eB**)GlNHf(Mj1&J2-+
+CK!AK-CT9`&JP-CX9q8VQC825,1!9"H@+EBHXSXqaJ(f0$[(X@CffkkaHF&SPXkN
+D@,FC1i,Qe564jfrNFB+`C4!2&T4p(k%)JHDBIh8$@D[S,"fKIXAG,VQ@$-hEQ0G
++jqj5l`3%0C)BD"Q26ieYEpUj5j(lqP#aHXS8Ci-CBS5qQ$mbh8BaDC&UijJaXUQ
+@BqN$SA6L9PhX6&-f9$YCTh(NU[hIH(JLj(Z`['bc&#&Y3e8Y4Aj8b#6*9TCPlJX
+bi6!Gdac3"15kZ!&6%SqdBEhTjJTq)B[`C['GqEP)P&+P0RL[&P9"&FH6Y3(5%XD
+5I$%KXeB#[rl"EMZN0p[AGl3*DB3PdmZCd(Pd$KplPmL+LIjflj`!(C%rhEXQ(R@
+B4fK1X)5f[B0mej9-jhKZ9KLLUX(JQ,Bm6[$Pp3r#3PFU@-*S6Vp!Hb4jp*8b69-
+&d$CT&)0&A21FZTKL4'Ld"rTDMcR%KA8V0V9#!mGf8GkPL(M"JV`[GFN6*@iU@&h
+(PKSp`a3dXZYGF(Sh*[`lU6[2lYIk`[8EYp&h@6**9p'LZ5H'+j&,SN@EpVQG2Nh
+-iYMriq1'&9-JeP#&%%jcI"q@#Uc"ZRBANj,l!$665af0"VIE5`08lV!3RD8"*iL
+LDqF5`iM-Kdr%'e3*HZ26kL+NLXDHG26a(#LV9mkr`+b&qX2r*`,ippjljAE`q&a
+#qd)*)+Bm!lfpB#d`hFpB!`b(C4G@!@f)Ih9QIG86CJ+*0ZJTLD+"@CHJFfkck!B
+ZJlq#T+8*`1NmD+9e`-4ZdXlBMV8Fj"p0N!#9@1UN[XKVK,aI#DaGq2eMSDZV9Ma
+K%$LBRP`51e%HfEq+UmjF0#1jJZaKl2Tp3@S'QEHIa0kmN!"P!5#AZ)#%VZGNSbU
+G$TGeb)Q5[r4U0dJL-P-!jZ(bVF5i'!B)h5)2f'!fF@eV,F2"@'h31X,%2Z%4TTM
+#!JTbL4l[jY3#hF-P`%GHelH$3p#YHG-3F-e6Yfh5mb&f$IGhRIGlK4LdAVfR4Nd
+*5MiRZfB#Z0rCJ6McJpQS`*Kr,mlMC4qUEi0I3[JpN9S`GAC$PLceq5JCj[bZ5N6
+m"ek#4ilr5U#0,c(#LcL5SFN3I#H*pN6-HRrXH-pa,6,446Dap1AE-'%A(F8+YIM
+62$Y%kiZ@`5*f!2Zf$[YBQ)8qj0RIE4*%kH`0Jp(HSf$T`TZRP$[(M)e95"U!+h2
+R69flG,%Y!J054UL#MCEpF0ZSR[lG%3+aSdELDXhDXSp36`DiRLL5djAXkb)ZpBl
+BBA+I&MUKaTIk1NGP3B8YqqS"D@(#$i,emBNNBakq[UUHDl2JDZmpq&!hCGp9--#
+VZ"TEM[C,b+CQhhZdUCrM5(#'')-b4"6"K3AT-Pk$E$kkd#92IG9FPr1Rj1!E0mf
+XYi)j5,9fH8`LpiMJPK+jeT!!QU[Q!cCEZA-KjBb(G+C[U"3fLD!G2-&&Ql)Z[hL
+d2+Y%`ciGN6NYK%j*M'+%Z)"Aji25Bd%4$KqUF*8&K$Fce!a)Z)GS*+RdNi(iQ)i
+PcV+X8-iS!%UU!rlCi1r3MR-Mk!+cRM$QJk1UI(GIb(kiKHM-fS1h,Pj$`TVfmUR
+$a1-PdhA24TkXl,8Z(P1NpH+V+i6ij6m[mIh8qZ(-U*lrlV-9)%4Kq@BfE,Y8aPU
+#NBKiMi!P$JX0d63+mfUKLj!!q1*E$V)(lcRDXFCikZbE"M0jbfMQZDCMPA6@bfj
+%KE#cE34@%[YAAV*b1C'IB86#4+FK"+kGrU!q,ba"SHIXe))X-S4I5idbV3ZMmT!
+!rFhR'3'D2rqAPkI36@f8bY9r)6-5#f-`0lm6l-@A8e#N5kQSf(+4)NmT#Fp)C8S
+IM,38Jr#JpA!m'`Q5TLb+dIlHcZercL2N(c4TT*DIhPTfKULSQ(QaCYFFUK!VMdf
+6fBD"-4%0r)A'82fA94d!C#9FIPr'C0--R'45LdB#UcliP-kVr`lkRVdlK4i84D!
+B+I26"#Ek)@-dXDEd(%#M`jRU0H)3hCk53!NX([eLSaeeHRJZEf%GAJKe0Yl#NjD
+p#100'rCb$rX&@Q4cU+B&KQ,2ZST[PjID@mIM[9N`raEQ-RMPfFfJ`Hp!8e`@3+@
+3"!%!!%%!J,5KU6Uh66Z#!!!K,!!!@-F!!!%`!"%p$3!"iq3!!"e+!*!%$`"8Bfa
+KF("XCA0MFQP`G#l2J!!!3,*069"b3eG*43%!rj!%!*!+J(!!N!C#`G6%@f`GLi0
+)4DkN[b4RC2,[p#G'&Ba5`H5melD4TILkXNc(dUD4AADeYh`"ae8f(MfSk)LA3PP
+1c[3#,a2j``qGXElqPTKk3KGX'TDk!hVB4Ff`[h*lLUD'L`+BN6c+ph@'P!&+HQC
+-r)R0'I*m-,@$l!'[Q8GFUd@%2X2,T"Lj"'+11`*Pc2PXHmZMq,k0rdC$J%*!aGk
+V-6Z`A**1B`f)kF9I0hGA"S9eM5UU&Q0DH&Nce%$r6!CET+h4Ij+E*AKY)T4rN!!
+eeR69mlA95SVK,X6LPP3-CEEURhK&'T1aXj4@*5k&L*3eldG'S6jC&9E10a(FPQQ
+mKqIrX93df1k#Zb4FkJU8eN&Jm[+fM`+19c'+,b8P2)XA80L+X%#62HeHbH!&`TT
+k,1mMj*HCmA!qY+j18l4Sj8`$D"&6-N,Pq*YIlAa3$HJp'#hFE["N-$K#*FR2%2q
+5[N9Vi3+dQ&$A)-KC%B'e[PPB$k6*+f+Qb6bH%bAYARAL+02j[aX%p8j%jDD@[FU
++(0q"3dhB0PqX'Fhq,4qVi*G1RrlF1&NGh3H[CM$D8!!I0VHGIf#5E)MjG#k1R,d
+#@hZ!1erY&#"A9lb[6r2ZR&'[lHrT25rGd`e@GdhCrqpN[jiDMdMSValBrm`'"*!
+!LZSPm5meDEVi*LSbYb(b#K(ZMSjadYT)j4Ue,hHQK(XLGM%i6JV)#`2$Ik#q,0+
+E5-%YL2[&X4Cbqm,r5b6JAL`P)MYH+USBi-`1G*B!c8mQmq@PGI)D0*2-aqP"hLi
+FXPr)e!ZZVA%ka)V+FDTJBL#(4K!+pa+5pSC)9K$#TeJVpNrF-H@+*B[ffalK+R3
+dB1(B9QYQId@H"rAq&TE2V!2A1cDFdMJ`PHBjD0bk0EKHHU#CBr(j@aq[!8U%XBU
+ZlSDp1X9E"2TTT'eAdJ61[5B*I,4@QKA%YY*qfaJab4Gk-,k6N@Vre+JLI*qh623
+4`RM&*d1pac@LC*B-YU6CNID4fFFpA&)fU'$[G&G)q1lLPjK`@5Vp9N`4PM#lCNS
+Pd&Mb@SD6d%'YX'2[db,DT`MAr@805'5%bY9&)S-1elM)C@c#AS(FDlPQYJ#X$6H
+2CK33[!+fC)UEhS)*&*p$&EXbjDp5mU3+m5Yiq@fNMBJ*I[M6*110iP)qUGj$hZI
+88Q)JF`1&@A2'6p(5K46d3`Nb!M'0S%YTkKj4A3`TlTJfl+Eb6X!+)rdVX'41@Ub
+NSHcZY)Bq@`hDPBjqUBR9@FRmBdUdJZP)h@rEaa3!KEaaQYX1LAEYSkdDj[IZ!+b
+'b#VLf)qF1a[1k2KPC!dl4PZH4q+b)00d!HTkfL@Z2UMI5,9JBl%,ejmh$NDer$L
+FhBi*KU!2EN*9JE%MTp5Ze`MMD'*M)ZC$T5%P4,8kX#Qj%Q[`QX#H8,2bHhA'Z')
+N)CJkRc)LpFb"p,%i4RfiQ-+C6`-pCVU&P+bQH*)L5J`(EcMUTYrXi0ZaFh9lf#q
+VA()+5MjeP*[$@TYJIm-!$CHIRRHi8jEc3m52b0H%&Q9b[aRQQd8B`[5mjJdIK9c
+,p!P%dC*9!#aZ@[2`UaZV+R8##YiBMkGMh&bMqT8rl&#"+BV2GV48c``8G+Vq$A%
+imGd1b&AV[-MJTdb0i*dmlCCGIp,X*Mb06c-4%GZeQPlGm99jZe%l)@[+e23iTBV
+id+$454R"TT`UHbKAfN*HFLSmY8a26pQp$dXKQ2b"9"er"%(#Ri-!#VM`EjHBC+,
+I(+U2M1XEFaE)$q"[,VBpp%b,,Tb1'CY8$Td,eMaia%'YFMB@J$Z1Ml`KrT!!!R*
+0T!V*(U',df0@T-S"-!Z[ieD*k%N&9G'-SM6AXXBZqdZdNYIDi!Q)[)`TN`D#(G$
+llHDEG-`AffqpE%d$+%*jK`!ETm[P6mcEbQ8EZVJPK-eK2FNl1(rcf-8F[j[LVl1
+YT9j+CdBZ'*JDVSZ(d#JRelLN'-S3-qBe[ql[mdD'qIJYVLMBrhlH#QCEKB"SamP
+VB8e84Uaji3"Sia4aAeHZKVkZQ9Bqb'k*9bi9(0$H5a[bG3q-G0U$h*&*j0S+eD*
+fYDAqKXISJ%dNMbp*!9fL`cH$#YdCT!+b!pE+C%)kqbY$1,"iKhm0I1UhrMm["I9
+1RY5`*d!1h#eY)$VI@QX@4e3&p#D+FaHT[FUllBTS4LUkPKBlS""HFM#00)$ZAN)
+XrK0j)G2Ad0L#23Mcj+TPEY,iBP$!aqMJj#m)['%RT*-+'e&qbdIQ!+%*L`Zp
+%(lQIB(m$jj[2leU4bGMcIL8)kHH2b3U*!R,-1j5dGR%S@4C0)#F-1BL@I6!qUU0
+Jp3AmBBmYlF,JIcBS9pi8RdEF'%TkkFjKNc#faNlP4M`RBq5'APV@!SB3kh!TY,U
+Hk0S)EmI*f5@*,Jm9-#Jh#G,&1Gq1F)'Tf#hP!2p$Y%Z"&-YPZI"AKJZTm*D3!"V
+q0(-mK8PLKRKLkmD9rX,K%15EI1(G@-53!#QK9)+Jj4#'%U$V6c`L)!*1pKp*ZJf
+S(+,Q$[`*BADjZ+!a*(fPZ-PN5r2H@IApm@'N"TRQ08UBHRSD-m2p'523!rf0SPM
+C05DB`,N*-R84-L+K+R98-2DZr5'i%'')1l@PEAk+K(1J9SSSGAlE&i36L$k&6CQ
+&-M"Eccq,1L#3!24I428,eE)'GTLcSPc3,YL+YZ@PSQC0lck3!+FbDRXQ,Ul)b&E
+PFXb6!AmDF+V94'ImM&88ki,ipGa0@i6qSD,0)F")Pk&0fT50bU-PSQiaVBD%P2,
+XcA4mI!%Q-r#BhNE+"9m`(iRpPPlU3`IFH8$1J#f6PLBCf-qHeYL+C@,TH@P@TPQ
+Uh'"8ENi"eNjCP`Ph0#Ze$PVqc9pjYLj(Q6qZLU9ZIAVE1fE%TD`E2I3P4k$qI#C
+m+ef62J6h0VADr$b*,A"X05%SCBF"68V)T4r9Mhd"aDjh0i4mXX"bT29d3kDaCHR
+D#cp2HrqhbH&D16U%P[UF8M3@@'`8*qjHUV#GAmP`r$S8LF4q5`8i$a08PmI+ImL
+&%N0GD$`%HB%qcILq9jd93H0dF*hB!i4iKR"%6p$eTk39hZ0@d8c+2ZIreDFNi!B
+P+35eMle`YZV$K@PXFIm[`81CBk-c#AJ"KiMbdch8kmfP,HQr,P3lB@TT[pE0GZ,
+!D,(afA),PkMKRM34PBN`lE,S-Nqh$ZQL!`@XBTiT[(i)MLBbqf4b!GZjVf68i0S
+@!pLJAZdS,6$eS,5qX$f0$@f&aS8ahPXl-2**i*b&J1+h*YBYFB2Y9*8L#@q)9Ld
+!ap+lkXXXmK!N"$ELVBj%)J-`&X#j#,S+!!e+Z#&pqQ*2!iAC`CTqi@b[2-SL4,I
+-ca2`"c8B'X0S9hYmX)2Rbe"MN5NQclrR*8A-4E(YNfd'Zrf8aJ2!e,0,imlMHB)
+8U"PEPkmNLSI!*pk4+b@lGMKKc'llU&6-i@BbCPeLLF9@(QfX*T8r#TG(4+G)ZCB
+RU[)P6FTR849TMNdT0mcpXGFrYI&pR9(mh4qBbT+,eAFXTK'R$N`Fd*hSCRSH*D+
+YQN1X[T,QMf`@,"GS$*YT8@jX`&CZPaCdH`jI-@RAAdRVP289qmICQ#8#,XMhJQ6
+)[G1!j5V(',Z@JYhbqb9Te%qhSq+G5lNP8K8Vf+2qYmrN6Sp*MHF1RVXqY(0e6%5
+9b0`R$%I8ZTr6,IYm*U+(PGlH[bcG8U6f1*!!Zm*B)$NbrBK"5`m%l6eAN!"'bD-
+@BB`B,lQ1EdS@T14,)8E,$TpJeaH,PTUcqYcpE6#fPbjRk@Cpmc&,Gr%*QHc($qF
+38S@fAAJ"AeiSkpR5kq5Nfm"*KZ#*lkAifcDYS8Uh-lAFk3@,8J$p!hlS,6rE[%5
+Lql"AV#(l#LhI#!X(3Afe39Bqk4HaZmDZ'5GYR`V5Im(Y6jUhVaYBc-B8l`ME!8T
+Mrcld&L,F0hjbND[XlMN1A+6REPb1%YY@fHq8kTq434f$#c&5jd4(L[4(R0SULX(
+"Q$**jAB4ck1KVV68`hdPTHlah)B8rjG,R13#fdRdB(ce1EI`'r(#I3J'%-j0Yr@
+L)9rkmPb&Yl$i&6bk%dQSRJI5ASr$[GJ&GQbM(ieCZpf+4&84$,PN%#1e#%#mZJR
+!dHFHSLJ!D5r[cb@1C@mQC-N#-jlIf8Aq`r0')&PPI980MNYQcm@I!28J$5EM-)1
+pbc@F`RkF&RmlB+#qFK5Kmdi9U86SA(Ef2H"c2YcI580bA2IHi$Ke-,F2A0Kc
+)-Ie63bTlfrq"IiH"qCJ`U6Sk19%RTj(qedHXlDCP(9I[!(5-+2,2Cfb*#P3(Cc0
+hdJkEl#Z$1mSN1JkeiGMc3Qf#cbUAIdB"i)#K&mAaH[Ype#(B`p-G%-VrL%%MqcK
+pT0I!AaMd1fNPpQC4M+-dZ2lAb)`9U5dZcD0G2phM%rLlbUJR@p23RUAAm(pkdJc
+U@E+c,+@$jR353k8c+ZZfkhPQc)HHFHdrqXJ@h4#jP3k))pd-([YPBVc@P)H`,+a
+SK4,*Mimj1G#)Af,F((bEKP[UriFD,iTrei*[eD$F"P2Z(`KqhiCCe1bhT48*@TU
+XqQH*hZINRPa38YVjfkfMUDXj(@),9Ci8ShqSaU1hMF*5"-("DeSeCK2kqr96[US
+ThB5i+@*%21%6fkK5TJ"FM5IRqdECL,Qk[$fAJ0CK1480q#*"qEp+aI$8SrU&FPB
+01pjkbDiiFIeSZM6Yl4a3!*jec&(bhpcVM8EUr)'Hrl@rH*d[h#Cfb@2KbljiP@M
+1bENG6PViS0HKi13((!DSE+!R3dl$8pMT6$56IbU+(#CrflmAJ1+I3[G!j'C6U)p
+XlMRG[a2&S6FF5[-hJ[4MB&0!fBblLh'THH,)qI&ri%AkEl+NeCH'lrjjjpPF,mS
+CNPfjE(!KV,aejI%hKDrZhECfdQJb%ZEZQA5aMl,[90S")Y4F"31AL!0E8I8)'ek
+UM%*FUST`C-9-iTT'(6Si1Z$(-NEAk8@Req!PGa)5VcAiKZiJA6ehUCjlIFdb0`H
+PEBeP25!E`eqL3CcRE$S$13C%4Sm6@M0JlpE(#YP!HDDa9La6T*cCaS(#JAeBDp1
+Pfc-RbCQKchqm8ecEYUIJ,'&lEM%`G-eQ*N@K8I@ciH3M`X9h)#i"[5iire8!Iq,
+'lU!+i)fhaKr2V0*,i1Kl53lf6`'fZ!-N+SII$SM*X0US00#NB3N!64Cq+EP345i
+Xq`-EFYM35Gl)qkEjekZQK!,IN!!Q&Cbe9'c'&`Sh8kb1kllV%mXD(ZQlBRRMG'&
+$dqAdl!+4V`hBK,fZ(A0K&+BRAB9Z@q%Re+f`QmMG0KH9hd6[8%*`9SH93Y!DfQ8
+A+H4fVkVR[Xd8Zq1![fEHQE@pemQS'([GNNT%lTZF3hT!YdKHH9V*2Kb)[KP6ldM
+APDqJ(Z*DTR0VRbP'e*pEj8Y$*ZD4Q%%2M*(Se#QVVib3!1KG`r"FlY9lTF(bM%P
+Vpq'`Hj!!Br8Cbb*LdZ#B8ZR,NB8aXqj#I&JMQK(lID3ABY4Q10Cc'i&8LV@LUa4
+9[i(1[5SZq(QmSph5SBc1j'A@lC3%2UqC1*EE4,If+[#C%amlk2JM[me[PaC$6P`
+9e,1rmN[B9'lji0332bZlce,'R&i%KVSCqfL)3pLA[*-F#5jT"`)3IR,dHM%V2YU
+T`qf-ZjXee-M4Y)pR1pIS5AA-#U0l)fQF+f[DY840[)N9Cj-Mk5RBK8&T0[V`k!F
+TRZDj#R+2*Y0(kD[,U$3MJ2G$-DVQpL-Ha"$G$"04HMCI"pCC(QefGQF0QE8$CDb
+HAXY1H2&,GEU8bXl1mCYRMK[iUiV3jZfC$+!Uf@`4rm-%[kQ%`FD%NP@ki#,9!"e
+bfKi2iZU&1#Q#&i260@Idp!GjIjcdkIF3"ZX)#+F9!!Zr(q1NfX[Lf(#PK+ja2@4
+&EI&mZU`'Kd281Ra'hX[KE,Sp4V#($0Hhh3ik"0dXX!q!lL-YC4r$Ha@NXZb!fHF
+R9FVDV&-%UUr09lK[hjlV"k6VGmDDfMQpjSCCIRC1q2B@F`$AXK`VrE@kNP`VB(4
+XhLLT9B4qBS4Sa"-HFGiH26Z"TX,9[rIDJ)F-"`DmaCHD'jNb*(C1HkRT!QfDGCf
+8)-fl+X58kV[[l)Z%"'XJTM(5R&+,%D'k4EP0CKCCYY1b`l8Eb`BjC4@"5%1"BiD
+RdLV3hI88bJ1@%0PJK(5YqLFA(eYSq&UEk-$3qR-*6d6b%jcF!8XZN58NBE`PGi[
+9-[Tj(JZZ5NT$IK)AlV$5LkK4d4k&K1DYQdfcRU%'@6mh@AU5$&UZV9'Pkickq&`
+U*eDB&"T4eU1jXq'Ce4q!N!"CB,P[DcrRB4Fq1,bCh4PiHhBLQq0+Vr)V5jaf!0R
+rMqBp9#PDYKV`Jc*CGahpreNB2&A4B3V"%GYId`P2&jjl-T!!LhcipmJJHUU0l%!
+K6e#p[jJ4k9EaeSSAkmKRKNBYQ'MCr2`Cj9)P2U'EmlM5'U6PY3UT5k*4i$jQk3Y
+jMC)B%MN6'8FY-qXfi#qLkKIlS26F9L6P4@fU'0bAb'6Bhrb3!%%rH'&[*ij!b,F
+!R&&p)1cFdd%TR*!!S'''c(&h59,DLaEdb(Kf@cLb(JXH)`5LMrCG'!"bZJ09-R*
++bBSqp01rGh`DN!$)T)lJb&N2ZX--K8D'aI5kmVej`+2a[#N$R0HBHpmB5Y"hr"Q
+mBYqM(KKT`fHN5MQ2Rl[NDkBT@P'&"Z-cV"Gi4!Fr#"f@d`JGcLd4fRUk@YF$D@0
+9qm$&"EY-&NSdDJ!"5B5P`U2q5Q#eA')!3&+"*EKPM,2ID*%9A96al3QHRXpC*ZI
++&5N+#jNB$6!,*`[a6La0(E1`BQM'cF(ilQME%XmI*8F)',)L0kRcq&1X5r14KP,
+a8##DecE&Njl40$R4M*YcE(Cd!,9PDH[LJqjhq)50)%E)(Ta*pBJpIpcA#5$X$dU
+edqJFS(BSH'D2@)(jE*L68eEd2DM%kQMkh6q3!)FB[TkqelG*9mM-LNd+Njp'@6@
+9G'Bf6E690UfY&Rhl5$X6Gd6Kd`KP,Y3IK3Cf81'a5hU!NL(P0C0`E"@#16iV1Bc
+C$b@IEf'A5ZT0kD(!2Pr0@ZRpThBU14[c4+Iq5I#,3+1@ZQ,YAQdd4*J(iZfFI!`
+UT!NL[,Phh9Z-Zriq%UC1AI!da,1BlibB%#(4GM1V[L3YQ'fG)i*B$UDbBRU9c"T
+mV+UZPBCHI6$&CLeXDTdJcFm$jCTHJ"!-a6GF`R2jYX!mej9QDL3A%#2FbmMi#99
+5(5H2Q!3h@1ZD8!4aICXfJlLU"@HXUMKbp-[A9#G"TVF@%U2$YAh9-#0i"19pCT6
+MRCb-ml8"e*keaR%%4i6GiYPI29c@pH1VL#NT0jlNa8ZRYrbq[bJ(U#(da@[RkJQ
+(Ma,bIf"#-i*K@5b)VU4,QGQdhRRk41SG-UPbN96NDp"%kdmL5YpJaFGU"eBUVpZ
+9Drdq5dqhiSeFCq1fG,46amR6D002-F2LPHM+!CpBjX%rRMFUXH`!#pUd*5"9&GB
+EX9@F,D1[K#K*#X*,M$39b*Eq52k[Pk3QEU%KLjZjD4%ESA(@M1q#eK1qaP0FpPH
+`2j)p10-Z%(k&5f(!mC3hIUA[e-SkbNTcfJjk2-TqPB1bUqqkI[6erFSQi$ADYG,
+&CN4hm%H(T3fhVNMaY'DEf$bBi(Sr5kTacDkTIpDD,Vmq8NP2$2SjqNPj9V8cm9"
+j4SkV)F$a8KY"'(%FP%8$F3GpppZ*UHicK2m4`jr1"HI[PC,d3NZ!mL"c'U"1b!"
+eVSaY)YDj(@PSC$99f1Lj9Rqf+J@&8%D4cC08KIGfS'MeURYYpQrpXI(JK24,9pJ
+432aeKL@a8MC182eYU)aX%1)E+3)9ULU6HqFDhT+3!2b9Rpa#h0"lHB4R&hCGD!5
+LaiqMEmc2-(VQ2@P#X"%daQ`15cQG#FM,U'EbPG!VpX90kHNe%6U#+!!F'F+RTj%
+M9Zc*(R4&8C%9%Ra,-M4,6Kp*l[0VX6'CM0Z6USJ&rfqYR#pCGHY&bL4$RRGG`Vp
+aL$AE'GG"S4lXK`2V*$5lm&Ib4V*jFN1HM[hfNcS"8`G"4H@TZV`QTp3hpecGrqa
+dDZU[c28ADS6U9BNp03XZ$bfVU*kXV*!!i1Y8p!6Tfhfrb0jjHXJ5E2!AAQE9kCQ
+N"VZKmC&YdjSTA0bM06e60M'0@L-b@&kec6T,K3JI(Xdj+Tm"eaCir#+bYAXVHI3
+h2R)'9Bfq-D95lcb@I"XQG!-KCq6(meN%$GP#,K2-L['Kfl8,XRQ)B23f(GA)Er,
+PDpB-[)rPKbCRa-,XLmL6KQeN[2(8ZrVGFT3epD8dR%6bSNb8A#!FqA9$Ej-H4kT
+K5aT,BTXS*1jThXB-pqZ*EFU3!'A`6@GY5SM0j$@RQ6K6p6aNi%0$G6J"GVMm6pD
+pe)Rcd8j*)he-UPb"IM#6B3l%$+kcUrePhi%d!(9X#CRh5"G%Eqcbake0'l%&eFp
+J34h(1[#BlQ+kB!I@JDDD8ZV8B6IVM"@UG,QGdijH$F1k2+9M`EI!&(`$L[3+#'D
+I6crX*",#1*@FPfL-Ha-UU$IC[bY[GXIDUiJ2*4"bec[i+Q"IqF!@km0qqm3-9%`
+KiTqkI1r`2-SP+Z0hM(A#dfNQ2b5@!`a9jN"CB#V$GpF'iBNJ$b+C!fTEkYjmicM
+rYec+r4&Lf!m,k$[*34Uf-A+U%a[ikSUFX"-IRH6XpVV$"6!KG1l2@qLk)!*"R&J
+IB%Hja1pTAfQ5Pbp51[Qam(UJ%jP(mYAe#D"[1D-'4K9LIq#mVfphA`EehQhEGIK
+1eI$Qm4ce`0Fd$MLp-LBC@#8qSZVKi,Z8A!8Z'4P%rh5[kk0Nj#FBU$N!k2U%3A3
+rPfhC0kU!4c1Gq+ZkLb+-T(##&-VecNUl*Y[1fl#[MB-#qNMaZ1m,"*J*GII3Z2N
+TVQl!KQ9QqJhP$KfSX%pRNbMa+e1,UE$(ck@[ZJ8$edP@R!AF#S@4PPF0'&'(GjD
+5`pA+cU#KY$c*hDS@dr94!e+3!%AND-0+I(5M`4UXq+05I&TAcS`d&U8B6G1LEEV
+Lm&dkPd+V-)8)$eM8[hpd(Q$,5r![+PRd6AhA3bUClF-XX8QBleEQ$9-'!9,85F&
+%9(M[BdJI%2"Tb24A$D,*,6DlXjqUQ`C-&A9B1'2hUJZf"K2(5i%6I!Qq+#G%V!9
+GII"-MJbcb1l5@F5A4HlQTQB)B*bk2$J`+Dm&S`bd,hM+3XFdf!d0'A1a@eq*,XM
+K,SEeI%m[-cT*)1QZPIV089RcTl@,(3ehcDK*D81+4bICrVlXVrkklL&&h5'K$'j
+fPq!KqU*4([+0lQDSCmTaS)[k-r9iharrb5)3PALLGQHUI%fa%2VP0#3*j+r2hiZ
+PRcLa%-#V`"KlGJK4lN3AB)G!jG``3%(-#015IH+('kKR1hi+AV&[`&"X#0EU0Iq
+FF!4BpU0@kl9UZG-hrd(CY&2iU`[l@50Z5pCUA!#r[HFKYjp'%Lh[i0S)jH#*pTY
+NTM-0N!"ei&+M,&!F0RSY6P'q&+5BY2!kL(VJJM4feLS"3rSiG@QGceS'am-!L",
+FHeda9p*8V#SeNF!`#Y0qYMJ*,hZa-Y`+k"kjQe(,RT90@kp,`m[EA9HD*+16Mep
+J2A9`6%3eASH2LEIKMckf6RlR-kN3r[I0PYqaFK$R8l)dR!"S3N#Kp!Z6(KZK[Pd
+HA+a3kKfPGH(j21FPZ4MXPp("NPaMD@qc%p9@3GkZ-3pjPp+ilSNN%&PL@TFh&90
+T!!LFTUfJZeiVfV#q42TkX2r+TQhIl[-P9!8T+l"a3,1fh-aTAmi6Xabd,&jIEYf
+T%ZQ+C-$)INQ'JGJ&SHMJG8p1,jY52DDqEX-2KER!8B96+V"%Jd+*[YkKkJqDFQ'
+S'q[&ejGJJHlZcaiLIS-X9Kr++R9XX`VMX[qc61f1SJ!@R%qpG%HDSZ9HPcUC6G#
+&'(Gp%cC3FqJ-2Y*$@baMifc#4G'%p2Eq#%a[i)&#f`YG%ebGML"32##J3GhXXPP
+c,EXKUpL1'R"p!Br`-SGaQ[KaBAF!K4#PN!3"!!"&!"#i)pUKZ#2DS3!!1aJ!!'r
+F!!!"-!!9liJ!!U4E!!!@V!#3"!m!9'0XBA"`E'9cBh*TF(3Zci!ZH'eX!!"c`94
+&@&4$9dP&!3$rN!3!N!U!!*!(3X(8iXXZp(-krTf8IY"Piq#rik,"FeHi09PXX+H
+qVbNSXImj5m86%'83J!02008HiH%4L*(c)IEi3[$9Kb@DaNZ9#L-cE+j"D*)*rmG
+r(q0I)pYVB36,65&C4R80PLm1C2mB3lkV%ia3d$05+DF9T9(2i%Pp,R',&KYJ5,8
+pj#*e3YhJ#L0Mf&4Gp4Q%0'T!3ILQ#B-T-jY5j`%ZRqjkrfZ1lfpfq)`E8jjB-8p
+ISm4Ip*,XqE2XPr#qY-K8-r#P[N'(59M%(GA+I*(6##2)`q5bS5'#JAp@46CK9(I
+[J4*chDR4c-YSr*[Y3J3i$8me-aQrJN4@'NZA+hXiDl3flG[-G[8UNf&h,Gr29Nf
+*K`L3!1l%$bUl9K+i(`bpEC[Mc`LKjCmB,L'X1ipjTEqf,FM!f$$p6C4,@h+EMJb
+i$U$6@S'459-K3`pQi0bmDcVRLSfIJJNp-aDhkif2D1!4@Kqm!)h*lqP4eQZ98EU
+"*QmTNdd++&fjfqPL'3p'*DG&GZ"CKf!T%V$`ki1X#eSjLD&&'D`F3PMM'rJ'@@'
+hF5Z05'cp%DmQ4a+l*-&T964*"V)AeUpmCpR2h1%mSMF(q+-'Ti6G#E5R4q%"a1i
+D*-E0Kbeqc&YI!p[e,ZcFpEm'9D+(Iq#bHE5T,AD2@Xf#%arVJ@EGdqDc5""D%EN
+c(ep%!9*"`h@iM,Xl*I5MPpEe%Z*phC%ffD%B4%k4l'BBAf16e1jp!qCLJ+9i6b3
+6qj(%hGb3!+SI*rHid3rN8#ClH%eLG%ST1Xh(&`Ii$pi%ZTSN2S""dEL2,3)Z9JU
+9UA51mhqh,DYD$X+#`[qZqXC"Rd$ejC@MU`eaG1M'1IJ9@!@,rN9MPA'-PA8$Y8#
+ILi$`@eSpYb1LN4"D-b'IJd'5@'#hEA&MhaZ4'SSLLISbddS##T[rd+Jk5L0T$A%
+"m$UC#S1fCHaED)hNjNf$bCA,04m83Dl+!!TfDN*CY0LDdmQZAf'ArmUG98lIBhC
+JEJ9&HpR"2LN-dLSe01V"E3I*&pl-3m2eh1Sb)Dd'[lH0HC6QI(@d1d25#"8U+#F
+#(#&2b'L**[Tqr9JcJ1a-$NL1$I96Ae+'Cpp8'PPmAk1C&LId&i[[c,$H%$MYZK)
+`,k3U-+'U5KHCY)`"8'fQIL&'jIljFj4jK'hiEI#8q9-Kd4p#`"*TUcZiBUeG'Cd
+NB&c[VBQmb3i!1la(*QINT5i15"bR2PmV0$(`V`0#RIY[KB&'pp#8[Aqpi%$&8dR
+D*bpI#c9b0#Y+!Xll+k6'`EXZM2ac"H+j2drQiC!!%QeT1N!*`Ci6C#krmAPl)6p
+4LND96"hB8%["-3Rhl[-,0lA6[QRh((GX0BqXCCYm9GcT4J&kV*-Dp201bp(fP5E
+p6kpAMfJ-HBVI"![-U6qbp%j!IA`UM++9Ml#HEJRZeAC6`SDI#KlFf`4Vm5$F&UL
+P&H1K`LHqaZHh6@m(GA$ID,)KNfD-QA0*jNj5$K8Bmd3L9rpd%"9A(('RQ[kq%6b
+1dLiEc1cqK#i2XfTrI5)JU"+!S$$HM'rr#1A2j*)N%jh&D@M0rL@cQ#"3hBr#SI-
+6J$Tb3N0"`NE#'JQKY2F'r!)aGYq-pL-4MGfA0J$L`c03iRf4"1T'd!c9%er2XIi
+qIq"e30JjT#J$FNpb820IS9-4BdN3AR@Je6GVeFh@9T0+pll%L-DXVI%#X)NVS2R
+`ZqJ$6+*EAVNXK#bb4cCk+8aD3d''l2@(FYR8IR&fV%3V8JMG[%b'!*01'CJ(F+l
+m)U5MQZ,(@T)Y4NhmqPL`qfS0EHl@32U5NreY-X8MYIANPeG0AU%hf!eMD"Lh,S6
+6&6$#,!`NAJlG`rGVL5+DZIX3G&1*JrX3bTq5'iB4MGjGFe#fD'UP2(D4J'lS+@R
+3DRcPqN,$SRch"Da[Hb6!GXM+*"bQa@0`dl#GFhLZ!%la1,TF'Dh[&TC-mTAm+D"
+R"18K+KYe@kB[Y$hBp$#41T1mlJFb83q'BH&H@Tc3KhBN(D2T&K*aD&RBhe)q0c5
+k1FqPSp)EF4Tk%Df4IZ)BG!fMCQ954TRK19d2U@&,mkGd'rdqdP&ZYlD#(9rAeYX
+`Z&0FM&`f!24EG6SdJSiD`0,%eqcV9r6!LJYMpqDqP6MT$S'UGaMU[&43JC3f1Q'
+LidP%2VjJb64$'@2&"(N3Vfj!1Qe$*VS@jdFharZpFE*!!IcM6aecDZ+@lE@!iLN
+K,a6fZH*m[,lH'r`91Rk2aBr(0X1VYGXe,9mN&,1U2Gb,C2Sk"L11F*'@`"@!jh+
+M9kJ8%a1eJK"$8rR%lCC9F5mPC4!4S!+VTh-d8J2$G,ifVAC9HqECdXm$*r0%GBc
+IFA!AJ3)ej1%Ri4"MQic0kl2CmDYDA4i(6)Qdp3hEmB)M+i3R,3d(Ghd%Pb+FS%2
+qjbDFB5N!aYrKY#f&HSGBAYJhY@hJR8mHTr!RjNdA$C5&eXla1B[rEUk`)Nb&Xqj
+)55Eh5UN1!"dQrN3B)D5)H"ZqZKr1[-Y@Dr+6*F!4BJ&3@9Cc$-*9jlT&8+-A&a#
+KCd'&2hN1Nl@VpZei(a+SF3CA3%L(H8q3!2Dd2eQ@(k$5GA#C@[[ER9(#@C9(*%c
+1k0&(fSKdSHk%CE1ZCA1J*BR2'AIadGCkF@5rikr(SY9RT8TIP0XiU8)3ZPk*UU3
+BTP9hh1#+J[RRG`QjJpZT*NYMSYLr1T,PmQC3dIe5[p&X9QbGKm+b6["0YafcQ)!
+(4q@cK28qNcQ9H&[F*Gb@Aecf`YV'2ri#qC-cB!A4+X20U1D5EekA[De!%Bf-MDj
+0HrU,dFPk`1,C#eUX[LeE1GrL0fMhYRF4$#YH1FQA1E'JiQj3Mh8F$j(9)Na[mhb
+4QiP%MC@L6`r"lDlVR*3a*H$%c2pC'P,@fjUK'62LN!")-VlCR+TjM2`"9RYc3Ie
+[jUDX3r5@b-&lHD[CjK6*dD4iP5Q%fr'L[`-%6"[&I)+f49&4`ALCj4B)*"KFK!1
+Vj4rLJ"!ESPadE0YI3,eERRVe*M%TfP,#i6r)-!lEpeMk9,0fq!'8)EJ$1!D+X*p
+qAdHkQE0cJM@UiC`R%kI,QMr+QM''45)$Krph*,(*3Ia8P'IT@"T!HHK3GJqEd4"
+N(+lTKJCcpXJHh`"a&J,QTE(C8jQ4Yf#V$&"Z0I"2!fl8rZ13!#c1ehJqV-U)3d%
+-BSS9hPS!M9Q5LcUE$N8"l66hK3U'RGKm&l&TDm*&1!P4PQlYbDGN$1BqZaG"a8r
+53MTS[0c1TK3X)aX#DR6SM!-Z2,a&iGCQJ'@$V9#C`dfZk4G()[aadj!!-KHem-B
+GIPI(2FSZHQb9e#5AC,Dl1$9re8`k+(&"r@VFl0&f54V$F%c6E6"(BZ!hC6k'PQi
+4H$Vq@MSH*AXT(b)(e$*MN!"-XpT9D,G25SQ$EGiA[)Q@f`3@"m6jPfhe+lUKEh2
+Y)h`@4fX1AGG'""&h@ec3hPU)bVd%C#&D86D6%[YlF0&E@YL*mbFGQN"6BRK!kl#
+hpRUBleqM8H3qVh+hjXhDEm@9h!1IZaN2I4`#FZca*TAKqYCDiBIq@kJGd'd1XP&
+!-jd'FG%p69L@Xd"F"%jUYkQ#%l(9arp$2H#3!#i!1Re*28BDFk"c25"dJE[TU`F
+BjMYRk-D'(Ca'q0#NeIX5GUQY#V&XDpc!4PdZe,G&l55m6krmC3'M(0eLG`c-$Ze
+ZTVA+8SYS+$BBSDI[S4SV`k[0A8A"CGkT-CGGd61Ke8"jr8PTTaEM6K$iRh0e[&b
+,@f5[1h)2GAd1%"DqjAY&!bRp+T9R*P#+c6(DR"&)cdQrhZFVXciH4XZcfU&@NCX
+6AcR0P+ciJHcXjHm0dj-C6bC'`@RbcEca&5*CFpc#,C3-Ra$lP&#kl1XZ(k`9Gf8
+dRGl0!5&kKqbb4K5YDp2CAq('HX0[Y3RK9H8U%rf"V0M&'V#SYlm5&(MI1N`*!cU
+"`*QBrr-#-Q3'556pfD`2'cXcKhHYdLS@+0&keRBQe35"SRF-Lma8[h1j3Z+ipqa
+P%Y8LfXZYF`18ABfV&iBJNQbZ1'iidA1(RI2G666a,YZAlSULp%Ta%9QrLFHEMC4
+r9QRp)UrH&K5l(Yd1A52XQ-S&GB#aBe"d[i"[kSbIaS*c$QciLr-K-FKQ`Ukb6Mm
+Rca!c2M##l6$epilpM3dA`la2IR,!jX-jI#E2$X$Nk&BG+m)YXB$TdV2"PfeBfCM
+EqKEP*U*(MaQ(aUJ&lMDDh+Z&pZJKTbc*)&'6,L5Q`9VaRc-G)Y"Be!T!MB5#!T-
+T1bIAqL4!GI4V!3&V*6blm!23(S#emQAqC`4pMQrmQmTHf!`HS9dc9NfPiQ6[bqr
+@bS[)GK#H['m*XImbD[IJYK"r-cCCVVMal5$Ae()BVMbr-CVX-BC4FpHP)lJD"ED
+@apUBLqT9KA`Y6Nlq,mh@AE@'FdB-0bNDR5ek$rjJH0ajj64MLH%PG")VYPFVf,J
+6rVaYfVYLi&f`)'IjK2HcK+,9HEfFQ,I*ZM8Y4'c9QiSI-eqZr'TY`9m'A+I(ZEe
+T30+hjpa9l!Z[*`M'Em#I,dQEYCKZrM4pdhlY2YTXDcbBJRqebDk@RP'`J(FkGc&
+Zq1JY[b-3[-RV6,4T,PqVV*+QejcB1hMLri(+L$pM4#h"QfIaj%+XFK$AB69a(TC
+*Ef``*#EkVlck%85ck`bdGd9r'FDBfFi'"fKmdTeUaIH%A8+(qCaBAAFkV%2PNl#
+B+*)+I!KX"Am'1M(3lTS'CmEPI@bj@S"#CicPA`K4lJ&)NJ*X3c2(DV02*0#"e&Y
+!l9pTj2@I(4Fr6hk-F&01-aRq(qYrrj!!6bESB'035kQRdGR)idH,$`m-9&-qRj-
+mli$QcAU18AfJiSrB[`D@[6pPpX[6)k`NMmmKU,k"#G@F6me!"KIY0aDdBd'EJ"0
+)dpb#M4YPGLhNXQKImTdABHacR$jU2HUVmAG,XI2rhmDG#$d!!c3fUCI3Jc8)p)k
+!P`AK$45Hq$"SchXaBpf'b0H(F!YFKJS9j#(@ZfA"keKF3CdZP(lTfLTA-djYSU9
+[[-pB6YaXq,9Y8+qL"N(qpMmlM%EfeLV*Ip-I1paKGXkK$5*'X6k-*fp+bpp#,&%
+TG)llUX8XX01qq9k@P(FEb@[-"S1Y+K1'%!fh6P0pV(`q&CiEllV3`R0lN8*Z,Ac
+$p%BE408dhJT4`iB@a50-P"m08#FVkV`[q@#[l1p@bmfl'L&C!rrH10&)*arB`AR
+f2Gd!mE*&!KDXEF)hXX@bPejHcFSLQm%UJ1D9+,&c!RUDiDFk6NlUF%NYEF&6pl-
+Q!#+,E#6L)h@-j'MpAl#UK(G'l0k8h+A@hSF95mZI9GerZ6NPApph,[IlmSXIR%6
+"ScBe5Ief(VmJmFj&hIV9r1ML"+3-+1fDF$b2brIN3QBU0Q(L$KUBeE8XcNm'+a6
+A%rM5[i%jcr80UK`hX@Vj[,"0*1)4KVrE,#4M*qPEZ2+#(iRP3d2V`C@8"m,Br+T
+C'LH1j"0X-"DI&%B-XC3mk&qd9[dR'K2[0eea9J-Y"()Xh"0l(`jKH#DK@0Aah)U
+iKCCaF,bZhp0!)MULqpV6pM4S+fHf)&rfJV(G0``"$&8%a1"NaRKZYd9MZihm2fL
+)dp`CpE#UE"f26MX1JK`L[i"TS%UeEJ(Qma2(ikKLU34&T@YXQ%c8fL+,if,*"dL
+4KIR"kd(N09IST6d-f-,DX[QLN!$05TM%'XPScN'+F'8q#CXXPPGc"jPE94VCR&C
+P&NqQM1Y&I@8R#dR6cP$8fb5))mQk6lCb&qB,pcAU6eZ66rFX'm4UZHam[hM4HSh
+SURSNNm3A92)+NlGQSchm5EdM!j!!4E*p[lU%,p8K&H4cE@rkrQ&#l`HmaVE,k[K
+3YV!Vq6`(pfDJ2RYbJf9NSQl*!2XKd03K'B[b6#PYdlp!fTr[e(eqUdDLF5(&Ip2
+&'0)V##"rfa1,0F2ilYN30mr`@PFACp)K6k,d4pJq)YVBI0@DcRcJcZ(3+4S@J-L
+')2Z5qKZIKD[VDAKG9eU0$`h6"jC,(KcZf(bpdBIBqBKTbY8eN!$Ar,6SFHT5"3U
+TZ59d[(H2Z&#UIpIBfRIj0I#Z+3aiB1"K9(q-GNU+bpBMfk0b8Z"DQ"(V8abXNMR
+5f@ppHP22Zq)JM'p#LBjjiC+VYG)l0l9&m,DED,la$4J-dQ8k-S'3!(04AfXG1-&
+!NdJf@%BbpNZ88NQF[i"qfrh%e99SrQDIk!%KXiAF[rITj&9((f+K)PXN!6QMUkF
+lGeUiYH999$pjCkm9$kGU&PDaK%Ur3kLAfeY[&#Bb*ld4RhhH"IIVIZA#$6X6YfI
+jN!!&b9DTcU48-6(6N!!iD+`Z+VZK(CNNhk$Pk3H%+VEd(JZIj9*JX8a+0m6hld4
+eKBNUcJ""3CUcY&9%fPFC+2FT[*dRD[D[b8E-#h0P@m'9'`2a-@RD14(*T01N30*
+pqjG&iI*fAYr!AYfZCr"RYKmIMY4+%J+0,DQMi8I3kNil'%L68[Mp[$Q($&-VbTY
+q"SD8jrU+1r8#UUIjJdJT*mP%0I*8["AF98SA(E$RXXhR+kf5@0Je$4TI#klk-IM
+*iS4'(BRG(@*cGdQ"4p"QE@%SHSB9b!3HPq"l60fE1SK8'G-0G82[I#h6mEpb!Z)
+QcK`fVVR598F*VV'3!2ME,6I5-GfPJZSNB#iEP46Z'F%BlC[DHrbXZp"+kESk(3Z
+IAC*3b3H6DmdK"HZSI[VH0XdeRm1UDB#+ZbhI%)mIcfiL(3!M,EP(1ITD2L(Kep@
+N)+H)"3P3d!66L$pBeLZ3!)i4BL6QbC,EKIITd$p,FlK-'bbe)%T#4CYfjr2X$*8
+&(RNCP#9*!$Nrp`6L@ZD-cS[,#d+-2$p@(5#YH'cMQaLQa1PMb*8aTIbhcHP"#,H
+#d0QY*aK`AV[MM@-)B(YF5bR,Ra[pV&#dmlS[T3mS-8Hkf8,3kB#eUh(+e(#9EBZ
+A6[iPr0I#ie'lla+i`(mVPI0R(q4VcibXjl[1H`[k'KMrkN[aB5T9Fhmp$jTQi,U
+ALGaa0FmUHr9G&!qY`&rkQTJV*'hd4fK8Z0iFCp@keR!JKiHKJ%raGIB0DQ9'k@r
+q$lq[1Yk'5cliEd'4GFqFJ6j@a'CQkRA(3I8#kEFQ3dGlVTjNZ[IeGNC,DS-L((b
+)1r6![lTk8r80Up5)bV)R!8eREC(4AdU*`C+Z$IPd93+FP#MPJ8RD5,(P[BH)cR!
+p&(CJANqR+GNGkT(SS#0Zd1(R'De4E#2[#1M*j#HV4NVD)P@,!F[PpAKIZ*&8YQ3
+cb48ZMbDM!,YmraJpLq0@&DaalYqa8RGSL1pf+Xj+)XrAYpiLN@@1PGpk+65Mf'K
+eKRA[3JX#SXklC)[4ScJSeR6ca)T2fD)[kXjr`9r`0+Y"8Uqk6V3,A`LA%a!N4(3
+4C%pYM,dLb%H$`3[afBalFd#'[JKdC3XMN!$,(95KFcN9JY08heDX-Ti`'&6a4df
+IQl!UGjhVCba)E!($03!'e$j4aJ8kZaS(L!Phf[jI#pN8)m!"0"QBYb`bEl0Y3[p
+IT[l[V0@$)2c"2daCrF6epKEc8,%0dI@E-6De3NQ9h&QN)XlY0N54p+CZk%DVkpa
+aE8TpN!!FB6q!XMLJ`ak!cQFl!%BHQA8P$!8pe56DEG,jGKCb(V`K"1'q+I-%lk3
+K8(Y0P*!!`5elB-m`@D-qqK9#mAVB`FQC#N*33d1[pjV!)ch@)1j4aDd%()LKaLZ
+!j5*2+SY0hb8IT$$F,3Ef'X+BD"&)RmIDejh3T&bb%qFaMS#PN!3"!!!r!)#dSD1
+fZ#0piJ!!@-F!!,L#!!!"-!!21mF!"@Tj!!")3`#3"!m!9'0X6'PLFQ&bD@9c,Xq
+!!!"!XNe08(*$9dP&!3$rN!3!N!U!F!#3"N,"e-&U[TX*XY+6YAlamJKQZS(1"N"
+RGSJ$2JY`9L(8jLldKr!KEIrqiA('+SKEH-lJ$H6Qc3@D!XhKHQI4#BF(daA$k@%
+2#p(X2K%3Q'$XQ$qZhfVM%3e2p,jHD'c30qqe,**l(R6PcR!EVjM&DSifaEX"KH&
+LJEqqU90djX11RPmaIed$1D$AmHL("J"3%I*34XlaiDb2Xrj69NfEL5Rfq@8YDYd
+MeFHl`eJh!*PF-UP9r#YL!4SXfU9Jpcr+E8MRQieA!+KA4*F!JJc9p!ehJpYm4*p
+dR'[NMa2"l@+dYr%T,CGA$YM9icaH,*BKjjJ09'6)"M)l&6Q2,pLqPkDhFUZGA)L
+3!-Kcbk5S19rY6Pd1j'J[5FYjrJ)'#(aB1GqI!aB8CAdNrf)0VIY(qIr#K#P[hDT
+ki!eDcJb!bLe@Bfl*&FB1NB`GSa@`'JYTi%$RjkaC)8&VI[!+TiL#d(DL8V-@++r
+FeP#C[FNhV4ji4X`R640d5b%Hd-ZXj48$`CA+R-UGV5P#$fDB9ZC+T0cUY8cJJ"%
+f,"MX&ibNh--&Nd)FD3RJRS`#JVS,RP2prBi$HrYffUcUlZ@elRa!YQ0F#'BKLjU
+F68q"X&eJ5E3P56rJ3-#i!&$1G[D3!-S#kF[2f+r((*K*%eiAPPX('bl#69TVVYq
+lGKP-#j&&eq!9jRF`"ff5QhfBXRJaHL&CX1R3'G1B10LkIT3Z$h`8Kq*)U1-Y%FE
+8aRq&-d3m-mZ69ScTTJ$f"6i@,qcHrU[(KA!5cKAQKk1mpXI%28&)hjM8!95Gm!(
+#6m0TmM9T@cd8d@V[NfbL$%ed(,TL)YDd*2@qPr$ep(fqGj,906[`l+IbcJlqSCE
+Jh3`ibU45QK!B2#BhF#[IT*ZRHrXVbVE!eK&+l@bMmqh"&ZdJE-kSAPH9mae,Tq1
+6T$IjL0*d0Q[p(Kc&"!r@dTISYipJG*!!ES+Hjh[i)0p'IB(@2XmcXN*9#9[iTS3
+d)1T5CkE$jqmpGD'iB*Df#)J%S$D&T"ra,S%e@bTBfq!UZ"I0N`Z"`EQl+adRLC6
+ZFSF)4fbN99H4+*!!14PH29'6*9iI0,,4#6cNj!#,Uj`l+2rVbLjKjIQYh`HkNde
+*BkD`93jSrb5GG&iIR$V,"q@1*QNY$03d9P4K4M&aL+cFl#hhGR!ZZN1qbF8Q!Fp
+F9db!%iHBKT!!LmYI#4ePU'8&M(R[%ZMa0kD*ClHheDMS9X!$$6(NjMZ'PYY-XH`
+1&p[pN5i#PXeF9`KmZSb(S)6fPm"KD'FH&-ZM$RBG(B%KI@%(AM'Y8N`B&"LUI9q
++%ja5CR9(mqhT2erEk$0dlMJZbCNM$Z3P8RL9Pre`qK%kDrCXDk&HE'lh,D4!bHp
+@%Iik)SCi!dF$el"!9-[lF5JfqQDpr3rKFLkJCNk91*p81Mjm'%#rGP9b2U3`8hN
+,@)Yl'M)Cp0qSQp9N)XdB,NC&V2@k[hqHP0p$,(85I6XX-XV1qHTV[9XiJ9f-1!q
+r&Y2ai9(-EV`9aH)JjN@Qk3-ISfJk"ZQ#KbCUM8Ed90+DTq2cN6m!fKRll"#6NDp
+3B*2SfRN'3QA3A2%BMrMJHXVL-3`QX6cBLR34P(F[T[Pd@)36UYc!KG2k0PI+e(U
+LPV2)ZqZr[e`6YHeFN4P!SmR35Pi4MK0f6*MTk8E%DrNR`FA#UPhKkL9bMNcJhp*
+!9LX6h2l4Pq0Npl$G[MSj@(Mj@af4+e"%U896`,8rk9P[Y0*'Km,K5UL$+ci)P)Q
+65XM2[f[!pel$mdIFjJ0@+pYplRqeKCbb8E0[dh6'Zh)j$69#*4G'Y`PD0p+V806
+f1F!11lC`Cf6k5T*rH[3*cDKjdVHXL8(GACq'0NT+CMHkB,"(86RjH%HRc-ebSSN
+)l-l+fBT5NIP8J-10p@`fPbq9STmUq0)88fL0F0qbclkY@@VcTj!!"D*dAUL9H"9
+0`U)NdY'&Gib2*Vl2@KBKP%ji(3EdA6AHeXhF'V6LP3KL,ZFX&dJ8VeX&PZh-VbD
+BL$HR)0,d)L-0I4F%6lNi8ph+fjS'm(rqk%ScG(#c-53N2)E2S1*!fl#Yl8C%UGd
+mMH%0)(4k3Y"qSN%Ja+DX&FeCe&-6$IU1i#lY9,!D8U#Y!rr[+43EVZ6J28i4"qL
+++di[8C%pR()6$k,lJ4')ke25(fSl#iH[pN[T)ee@cZ(fiKF'``TFkBXk4%6HPe)
+,(iE8AQSK-q`Bm'34k*@685#Kh3!50BCG4Mace(#SX3(5AK2%r2RLZ1qaN9ZF5+Q
+MFcUCSfPQ#,$,3(3ED-[T)1!X$4*ZlpIT4`Ei9''"`NaSSQJ+2PQ*V&H9kkrSE'"
+hefPf@aXZKJb+-22"0KP1FZB-`hAcb)Z'iZSbP+%$qY4r9(l26pFZ&`kX[H4EYX)
+e$ZFAX1"5)I13!0+6@LhYbFG$Xfr5mf&`IQIjQHA+0ld39-d2XK%h%`mBQ[DGHRD
+-9!AZLTM+X(Z4"H63f2Z[BER3@FALXpchkUd'V8QI[@V#3BY!j5JfH1IPQPII!(G
+#$d-VQZZ%dMRVmKQDr1U)&P8RePYQ2%''ca&U9P(SkH&EPPT8U+,2S#BfZCmp*mj
+!PFVHR"GjC9lI&AhNBl*1jESS1%Yc[YeB-B%%Uf'qD0md38!'fX&PD%#aDMlEQ0*
+mQp&4d%P*,H!XD`+&UJ(UXAQ!ec-6X2Z@F9MHZ)FGSi!UqiYla"ZIriPjN!"fqc)
+DFGZkp%*aPmSjX4Pq6[XI6Y)9,CE-#-*`UD`"JK*)Mce642!i8[8Xp"1d+e0V(J(
+0(2J@ZDfqELISmE0d,5@k0k@mFqEDd(c@Te(jke"eUBmRr`CrbAL09Z'6dih$D!,
+Up8Ae6[+kcDpp06#QEDZ18pC%Ad38,FXVR1kUEZDiKVlA[16DVQP+1@qDB6T8UY&
+BmpE9Pm1,Q-Y-VTBaD5[G2ipf,LT'GClL0B-V(r)m@#T0k%IQ0Fp4!m5)C5X-$A6
+&QQf-CCkM)R!kU$&48E1Ak,T%`hiTbfC4+R%H[&PYcZ1Mb4LDHAB3DefL[$K23eX
+CG+J0*(CaBNDkT`2kEiXi"5620Uq63D`A'+m31@@B9UbPb++m0M2jfraD5"UAd+i
+UN4+[!I%B6AVZDFqM#N-`4KP(VXPjc8NFFEihGPH+J8`-$*!!,h23*,8M*`a,298
+p`@iL2c)[XJbir*ACEX1k2F(Bde+1jUUf1[l4B5q+JD4mY)i+[86#2X"TrX!h[5L
+Ka4diMf!!j3"F$2Cce5`r-6qZqK%eP'U8ilZbVQM'hYlNqX#HP`r(KQ#LF9iff'q
+a$ZQ&CrTmeMUR"GG#`8NmjIkS2YXT&0!C9a'pPkQ@l%5Tdb4ULb4GM)(VKQ8RJ*'
+"`*G2QF6Z)6kU0GGj5eJ+U5-D4MT#C9amqJ46K"UhqE*+YkpD8%L48i69HI91ZrC
+j%&eYkjYqRQ[[)CmfkHSSEd,RXLSDA"X9Ekh-CkXf9#,+VG9)2(,ipb@@cDC&EKS
+CK-M$Ki-Qq$[)kMZZSkGE6KJ6phlai,LLaC1X`SDA2!RPC!Bf`GF,2MahEkhLF**
+1@V'Bdd6NA8e(A@95&-HlNrZ'il$L2kE`@RIXGiU*4`-PLeiK[lqSh4eI1Gi`rJ$
+2AJElR*V!&r5+aD54UQN0$X2Vq`NP%IIf8IjERD6!Yc9CdMH$6jbGpB9SYT-BJY@
+lcjLkA#Dhdq0(Tj@A2A9arr%DM%)TX'fUdlUAbhB@-Ceh2e63A2'8!Lmr[8L@UZM
+8%edSpmZm$)S3kl1UbLKDHb(22`Y"50dP`Ua00j6$@hmGH'Nr-FR1jicN"VP8BPH
+,a'jZ2C-L3N59Q"Jkf[k2-)TGV,N#)VNC9r%a80ri''p$V5!5NFBKb,UkG5@m&4a
+jkkYXlP)QQCpG*eGpY166K$0[N!#2[r3+d&h!)NN-U``'!EbQT',dVeYcm'1"VTq
+k@&b4j*heI9fEpZS*h@Jk,m+dFLZPFCHE1(K2+)+I4q(C+1+dAB8p$e4FN!#''**
+)N@J8'FSjT!&M,I15&%4HV9`bFkCJdkI++KkLFAXk6Njd-TN`YiCUH63Qc,CTDm9
+)!`EaF5aV&Q2*%pSck$fALEbh0*AUG$b$mb#eX6DP6c6-hbk1,`FDE,GD@36qM4j
+bG,c+!(I(1PARBCp[8G4(UeVeB!Y%5+fQDS0*b@SBHI2bJ[X*SlkKkqXFPfeV'AR
+rD`[0M'H)(a$APST1Lk`Bk&p&Ta[1(ThSk-GpIMZTNXC)T0Y,V@p2M0QjbX41[48
+[rj4-m`5F-"`9NfTFjKRFQlljSrj6!fYPDH2+!lHM2QSFBlqFZEDm'ff-LeC&&kH
+@6Apa5l*h-F'a$G$q*@`H8!@i#-`@iK4ADl%ECd*4J#EbX#)R+(`mHh(R4f6h8#@
+qTaMcdZ*5'UiFbVXf3FFEd$Ie&YZYTT*ZFV&C+e`G+"TBeiJ9eNPI(k1#TIJCYqR
+X%l21GDp1p0)6a*dLHQ#21)H@TC01%%9-P@j2r"-+jAiT'1LUEG8FI4-&ab[X-D-
+TS4c@@je!8Hq$%Q-LH24kd@M58#ZdIhMee`Df(Z(I8!`JIQ9Br-[+%SX[K1(12US
+#62U@Yj1)$V@d-G)#i[Td[jdT4BK-,C5KB2BA#[Q8!ekF4TX95HI8L&X#pARRRc)
+ZF8*BplB0Ercb2UcP`'YP29IkA@3l"DA3VrEJrM&B,fi+)L8"KT12JL'([Q`0FrS
+6@+mZ'0FGi1NIhIhDm%UY-38b,,3HBQChpTJfCN,lk4h9LCKR%q1[)3j)3@9*3fJ
+&+0VXGY!ZE#$4e+cQ5KEf%Kq"0BJXlB%[6DKmU2YaH-GDpq8$)Cf'$YB)36i1JcU
+SPL1r"-T2)pE(85[eT#T%L&K49C5G(kZZlY"AS#2K5EM$K32m!Ff66jJ5rh5+Ui3
+fHC+P,#XGa*!!T50pX)'%4k[iK'M)8L`2K'JRf,9aqV2+SmcUX5QYUkBB@(NRB"8
+m-3LLC[a!R+qaQjHA2@br`Qk*a9a"kSjmjEmF"%0V6"PHe*C'K#f#1hRJAi#4q#M
+QQ61Z9+!@)I#5Zpal"U*hQlGV)Ll-Z'aI3d5le!V9c6)BC8+mmaJG9GJqM1S[#ZL
+8(1@![M[+aMeLZ`ANM08f8F1L3-6$%d&p(5QlRp*$,!-a$'!Ze!TP$")`&fjBj!U
+UYZ8p3HiQGTb0Mi*F''E&#j(qkJC`T!3N)iS0*!B4!M4AY2[MraIAPlH(JUQDR5S
+)``p1lq"24US#j3F#5)T8lUmAhdG6aT(E69[[@XaJAqRhdG[3Fq)H@N#C"dB,IkH
+3!1hb5kf)dQZ4HARGSiAETbr`3(,$M&,Gj,fXE+L%+&XrQ'BjXk#9kED@EMTb(+a
+%&,Hd1QM@5FcHTmZA[Yb8B&0F*QjS8hP)JHU!e$FDpi2&1%@,SJ'@*K9pGiY!AQ`
+0kiUdX8(XC$,b%B&%[LIAMlQ4ZX&m4aA%`he8QJqqajhU*,UE`3ZZ44B5cKCK5YA
+I2Nd'B$`X4FfZK0,4Pc#)&leXL1PcMJF2U+[!XRQTLhLqXP4e$JfB%Z[k"lqQTEm
+-0H2f#Kfhkl(R393SC`$C6aBX`%lP'42"4!8&l*(#rh)UiKJK@mKL[R0T5SAFJi@
+*!S5dRh3jMCZiij-F0#,!PX5jfcT#l09dSZ(S9KD22-1fhMIX3J$SmQ[0m60"h!F
+NDU96EPi,JR`JEdi!$CbT4Ea2cV-(ElZlKJfqSdCC"NK5H`q1"(5m+A42KmEG#-V
+c!%"$*@iU-ei*S%Ak,0M%mXShKKR)NmIBHjYU),&92RZ*Z)C-k,)9#E#4-mS!l5Z
+kQ[GQel3$FHN%ql0AX90r+[iEeIj5!R2Y8PeE2!a5m"9JqVI6P+k2NYJQpqfqLcT
+-Z(4fmMqrr$Y0N!"m!I*5"'8bM1A'RTRNfE%#eIB#DG#1m8`me!HG'TY+p,3JF)r
+1i&IUjZ(f8+$)RNSX"[S+QBNV(JlQYec(EYmHUc#950L$8KaX[!f(fY,9#S8bf4k
+1V,#R+$h!EA2Df#-qbakIVU4q$-0UNdHf[L1JDY%R3Y#p"Fq6BQ"60L5UZZ9h8jL
+IV))%cSKmHB0`5GFjTN*C-AZ,V0R9R4(aKamfccKqD3+qmdfpEB'he-@X%kAXer`
+2+p)3Q'RVjI&E2l@"YeVmF2QDJQ[LN!"Qfk*b!Q[-NP'e*h$QA@MpGcM',6Bi@EQ
+2Gq@Ql-'M$p3B4kmLlRBjLXY0HM)1aP1+Jr['YiIaDT&0Y"6b3,mF`2lcG0RI8G'
+qQiI3rXhaTVK9(fPKGA)YP8iMGI@Ph-4GpPBelX$pB,-ramNRB-Fa`2FAhM#T5mG
+lG$2JAQ8(2jJjCqQ3!2Se$(,dQK$PI)@8ALd-N85HLpjT43QkHR-8E#+&ibr8[*E
+9Epka(+iD%!cK5)J1M`*C##)HRC0feS0'b-%!GD4X$c4+'HrjJe1c5S86LMpGS2P
+e(dXPRK#&d+fQrj'[qi*pQ5$TU)m+ZlPjH"CFRQd,lq%45Xiq1iT(%kP6bLTfaYf
+$I+UKB%G"J&94ipS'$(b[*'@*FaZ0jRFNZZ[%XF9jJkSQ(A+X4EfKD+iVafLB'i-
+e%UT6X)!JdSQ$EB-F8'KZ"bNa5j-kG'GU)[-,-c(j,265-86k4UfJ$Ka3KDQ@1YT
+)CGj"rq4mp86Y#*!!TK%%ai#ABVD,Fd6mJ`A9EFQSrVN#jkM)6T,6AjVHR*TLSd$
+GG!L,P3lC9T,M6K$DrC4D1)PcUFi2b4@JD&*L-H'EEII0mb"%N!$%SJ1Fq'NR6CD
+Zm10R5h8TYRQf2#8Vcrb9'3h$*"1S3*%V$d023KqADc&ES`XTK0%B,iJX5QEh,Ad
+fYR9faC(caZ%5U,[d5+G9DlIHPPE''VpX5'3[UPjmBAcEIX)A&3pZVZ1%bF'3!%@
+T"+ZK@*-606P44I)5VaieF-0q@rE*'rS-10`!(rE*,RFe3Q2AA@[YG&!"V6TD6PS
+hX46(#HS)MPH6"3&L'II`!T&NTRd2f+f5`)-PiLh!#6Z#"C6r(G@'f+e!*VeCJd-
+8ReaBV+L0jFEljDQq3RXJ'HA`CZif%9F,pG+LCIjKRpp[5+J%!da4Xr(4hNR+am9
+Mm*qh"KcMSqNEm(XYq&h-f8MSI6&N3ClS`*HZdXe0,lcfP9+E)QIeq#m2cRk"PUL
+')'rD4kNRTM@jYq[[P#-G83Ack$p8(32-Al@ed0aL2$9FR*d1H-#K4P1kPBHX`04
+VEqDK(PZ,1(aYiXPR)@G+'ENhZN#15-Y*e2'KJ2EfdACKa9ENC!HiA'AVQ2k14LH
++M2bN8Re5F2(G-*9h!55CJMAcK8($f$##GGMM)1YS@D6-5c)k)q@4*#8&dS!G+q4
+%p)8P5$36i("K@#ClZPcq$YQlCfEfI`bTGR1-(RR*I`A($X!6RVkNA3T[dYRedK4
+9E49)VK%%-Y0Kk5q(JRM)0CQNEk%F%%K9ZDBq4E$XmF!5p'cF2DKf!"5LPiGYPXG
+8K#64ZC3SIQ31,b'*m&rR6,Ph+Y[-Zb*+d*!!rmRj%#jMZ&HmGMd35,6A5CMq"jU
+#`+e[*1PXf3KT6(3(piP'$'V*GKdr'iDU(+Mq!9E[I6YKde"hD`0hBRL`h+i`KT@
+Ea30b(NiLa&QbHmDbaM6aUS03'Y('ipd9$24FCYr0k#5+T[Z'MX[P2cB4F*kN5R`
+T5VKmeL`$R#j%qYkXDc)@EU5#+&m"![drY,dT(qd&S[Q'@eK4jN9eCS5RLKMQhED
+J,f35q96G8pp6Ld4Ee6VTf-E%+9QCrT@QQ-,XFC)ePH%)#N1UF+Nbb2'6c(Kd+L@
+X1ZE4,Me,1F95k*cGP%V*iU%bXK'Yh8DSRNjYQq'ljeqQj(UI*DRbH',GJh,*E!i
+L@)FdFTY-Y!5bFc9F300&)9iHj)bba`E(TVEdCSP22VHp4%RR`0IiI0R9V@XI&e6
+i3d+1Y1&,8Y%SHXQdH[+52rX+0MdM,SIL`458U3Y4`YZSf2ca06ER%I2jXGD+8F6
+ChKa"f9Nr3)QSDT!!lXA-NMkh*"X-1jmeHm%%(VQKHr00l[U+SX1BjTDF'fB4dp-
+'ZXEK"IqPPk4NfI3H,`PZ'Iahbm,91EVrM)p1jD6rJD5jBU-IYZSi*GqD@6Kr!fG
+F("J3MSV%Vh6FJ0$-05&'!@"U5#,9NV[QRZG5+`&TS-Y*mjReAh#jXXNGB5r`["!
+F1BLrl%,R1`JXA0Mp31K[C&I6EaiSHZ2A0a@DH+fHDDh3BG9LUN%kU+K5bL!iS)@
+CjSVP((Q2N!#iaENkkE$fU*SNr,VN*#kIJff6UMTERIc'!pkSQjMjGJk5ZBR&k%G
+&SakX9TDkM!&eS&X,CPJ-e*3+*i-fq3IFj,k$Y*1mRAJ`pfkV34KSk9XffrkpQVZ
+Y($5di%4E6VYbHiVG@@-&$'ZjYc@JDI6"Ip3haB(`aG*Ki+Jm)"0%d$UZCrNHlb`
+JZ2p-rRpK1pe!cY%P0&pIRE5SZF1I3"+`5lRDJ$kPf$[1B%@f+NS@iMA6#Y8iVjI
+D4Xl[fD*8@H&AY3(KDIm4rPJJGjMDp&fPd3YVVfAD1J`Vm&!0rlX$U5+9`3f8ESd
+-`46Z(9,&3h!L3m9f,k%0T-k9AZXGF`NA&)6Y9i9De()N!A@Li[bQL,K)X@-)@6U
+I&d#Gk,*Mk,q$EPr2F'9h3YKpDI#p$eYU)LrifTCNF`ECY9VU[f%r"fm)QmjCK3G
+qGeJEdk[KVV`r8hXjm%%Q@S#U`RcN"Sf"+0jiGBRCr)"QCJ,hF*)GT$rJ`Y-%I*[
+ZN5AZ2)KMm(V)c6$!LY+Db[hP3UT0H8VUDFN!!ZhK#TTrp6B%%X`2*bi2,ie3SAh
+F"J)JC"28CPb*DZD1bUm055qN2B2YC2AJPkfSe$0E`LY+ja`q@K*f`lPh3aZiII(
+p34AS3T9!MYpY9NCjNV*H[6a-16NAd9@lS#5FQbL-#*mDFk8j8TX4eFC[#+cQXBA
+c0L6hc1L!KD,hqJ0f`Bh8P#SbU1%(12@QI!KPijVcb5$0a)qLSBAMYcpkPGHKGep
+Ch+h4+A[mL4'Zc#2%UK"A6rdNbD8ir3PiU"FYG)T-KNMRf6UVdYd5Xl31EjF[4*r
+dX-4+ef6[AU6q&TV"`5dQZbpI`daaLT1ch8hV-XUfd2*9*bap3#CVGbehEEZ1*Vd
+i6R$jVRjRGTbaUEH-ZXdI,1jmeGIUQT6E4(G4dCI#"3R"ZFKfbi8J``fefqBMBV,
+!50ALD)i8@!X,@B,R+MMBNjHV`BXZi1USEfbQq"G(VSNQlNVhDcmGbjfbl5d6b!E
+F1CVj"IX[+LRk+qq1)H`,'Sr&)M$&Epm,*UZPCdQ0Pc`Z@0qSYl8,R!h9GIJTk8K
+,60,jRDcf2VmhGmGK54ZrNIYM2RdGiLV!Vc+J@RNQXQ3eC9e2XEdIk8DAL0hD2"5
+ZB34"TjBZC01FHl0dE#fm"0rqGZla'"ih`@c43AJdN!$VV13$BAd(Nj!!EX!aRi%
+h,)*9GhkQG+IJLe$fVkKPdUl[4i%2a%q@6(!8-PE`lm2B%CAaj'8H2BS#em65NVr
+4Kce#`iA)cJ++!2C6Ypc*N!!!DqK3)e!B2HAET1Sa`&i'DQ8pVRL!MGbD)86m*1+
+A2AKAm1i42Le6$0Kl8i8+BLX2AbLaihc&8(EZ6G4l9[6V0ikpYV`34+L())fD,K`
+QTaa-`iFfD$NRE)93ZXMT9+%h!FeGI`dTNXbhF&UCJ,#k%iN[Ce-PBDj)AD@KAD1
+(P*B08i#!`FZSFhG!k-8U$`&@F[eXcq!rcJeH#2l[Y1dc,H%U,M&PbdSR-E*'P$k
+l6qlb0pEe+3LM5Sck-%AiZAGC)!1Ma+d4#YKV@+JDIh9!Pf'a@CrdVr-5E"1#iX(
+NT&[65!@L%3X)A)'A3l$2Ej)$LYZK5F*G0jb%LImF@#[Me1dLXY(a`4$H9&j31+H
+pe&Kk0Ja$RAQh&!l"!8qU&aINNX0-+NHDhm&JZK%cHZ',CB5@BNDHT1,d(K("HBS
+c$Tkr)FEC5`VNSdBj[fa1l-,!-Am`QYqGjA+1+keL'MGipVDGQS&G%A!5`$YlrET
+CXi`FQSTTC%VJAZYG0LbC,biI'lr12#TbVd-[$"HTa$e@crk0"%hDMj!!YSM!3[Q
+)U-BkLf6d88r"6b6dQ!(C&-$mMDD0mRqbQ-HM9+'I9%FFQB!+`5C5AZX)pLl&@(9
+&BL1A*QcdRaJ*QQh"Ujk@k0Kb9j!!'KD3!,"mcFA*bYj"dEFB"k-h20LE5f'&E$Y
+DIfAfb&*LlF305V`iBmJ#JHU0lG984+%,kGH$kq%c2(9lXI%LE1`D!G`Rc(Ub+rH
+jH[KYVTL4Aqq$U`JIEL2cXT8#-98TM0[4JfcABKZ@$"$V%[#EqU84$efe-+k0rLc
+cP(H6),eGSkG-P+&dpIZq4Cq1LAm&YKUSLjN,Mlea[r"r45,K*+if4fAlZ'KhS,Q
+"-hlAI1+VbCG+K[8-@a0qD5M5YG`3cL85`A@5[B"+T@'4HPM(lk3q64SVDDrM83d
+G(Qb++#h!ZGUHR%R$53&Y(@TT4I1jr$KMd"$$q(Q3!0Z+l4'8*5*6+(AIreF[qM'
+3!!9'&I8-$RL)k*&10b"&4AM-p`B6UHE5!b4QJZS%`AZ!S-6p3rNPD#-"9Qj43F&
+AE"MV)'h`H!B3qi`644jl,6Fi5A)RBpAKQVVkRk[96SGdqb[f2UX1CKZ2Cri2[eS
+%`jJGMJ0,RID+[MdShTR2#LEQCM0V*[$M"`kRr#S5K1,LG+93Xdr2MIRa$DCD'Kk
+dBi#lV0KUHA!P(Q[&*#6AjGMSmpNFTN$b(F56Z"bR`+fF`rRGCCK(4"F&0aQpLHi
+9X8U[r#AmID6C5bjA1@4pBEk@5Q#$F#CYN!#XY"!FQ`MNYHhU2eUUVKr[X-#aFQI
+(8BS'5[hV$"PQ69QZ+$`9-+L1[T2X%[ahU(`4U8$9Z5)X*SGGJqBJ'[R+a0E"p&3
+fqBf0JiHXplJCMVI*R`AVp&V83hYeV1J*[AD!030q%9VbFU1B-%$UGBV0rUX4K"B
+4SFShN!#5B+HEe-LdJ1I0P-bkG4P6AMH6i-k#aTTAIh(`&[jN'c+$@freN3U-Aji
+ef'r)99PL$M1ZcpAPh98iHe*H2H55FPL06EX94kmb!rb%1pEVh#PYL+qR@`qj1BY
+'F4A9X1)ZSF@Hijahc(*3aCDFT3"3V*S35&hk*(%G*qNSER%#a6L-l,!0,fEr!Kj
+'6)(mF$,[Z*&#fR*S+T-@9AQF6%mF6+FG1k"[5"M&pr5SjP)%-q,MNrGFerN@,&L
++c'kCAIiP!PBBC"eQ-4`J`(J0YI[fN5Gqm'!*%BAJh*TIpJUZ@He9bhRBHG$'-IY
+iI)lFY-aF`aEaYkh1RY1B`!Dj,G-Zq0f-ZQ(E534kN3"ViYJEfAq-9A-LVT!!+Yj
+AZ[AimZ!6-JB!#0Zb&49C95mUb,*TAd,p2ICFmN9AHAD9K*-r*N'6"JqC"HNmQZP
+FNr&Z+#i4Bl6[kSRXQXMhHB5%M0ce8ejVB[FS4SNkSmGN5JqMhIE+%BN23AlqFh0
++#erXKJ1`jD5M-8EKM@C(hQpVH9-3d[&!eJ`rBJe5qr+kSmAU!,jQ8*LN&`P4A,L
+8m*IFCNq(fNIdApe`U6Fh5R(*hLZS![a"q6iKiP)HFCih'Br`VP,@*r`@JFKd22H
+ei#QE'1M%j%#`a)X8f3UVl*3+ee+UPU#qUI99k6Hr[a5[4iR`+[L@K)G2Pd9FK-*
+qT4BFNbCSQ,T0Q6aS2ZG8VXU8jE'mq5CTUT69hVkj4#)N-XQYdZ'HpajP,pZahjm
+k8Hl0'ekhSP,%arrKJmR6%LU%+PcfXHk'MfDI*Ea4S*!!89$[BS+I,8b(#ZE+"83
+JUEUhpRV`*)5`[b!pYFZ[a"-h-"*KNcU,'&p4RP6iHm3(Ua8$M&1kqdXAJr"XmmP
+LfV'IRCD,d,@1PPK5T532#M-6[hXKfj-2!F43NUJ,,Np,,maMEL4(*h6NAD-Q3I!
+mhGrSFpYpfq6J3m+efE@`[LR1)ZK$"pUmVDMYRckMQ!`SPTlC+F`p!jF'[UbV2jL
+`55dPJfP6m'BVj"XlE8hqb)PB3!5`BQqAp-8*E2prMFDD4&Zj#p#AR)CdDJJQQre
+DI3DBS(E9[k-K2AVX@DH5pqI6%mQ6Y&&IkQB4kaVpk8rIaAh@8KS3A`19@ibb$P2
+I`3$NN!"de$!eX0+6Q1k2#%(PPRa'Ij*CZ#VDRYPjK5&DLZRCTp-`bK`ke0cMRaV
+&T39E$[d$cE"($TYJiQhA-DYBj$RZ((Q1d%AIX1N')FGB&0N,!*LPRTXSb5(Si6R
++"QSi@CVA9dd(#%!X'%j'9V6(f`Qip%dN-cK-h0Ga"Ldp2Ej`H+!jYhS9Z)d0M"!
+Be2#L9%&aFG&Ha66SMeB*4(FCGN$r1R"phah@V+m%3%-IUBFiG6ZC)8`mralD)5'
+k%*Amk"RCB'RL88JL'N6N!2d`ElBMTUCPjb$ZKi8M"B54LNZU[4qi3(`m6Apq$3b
+6fq5'@[+@%a&XMq)0L4[aB!D`QUH0C0b@jJ'Vr"P9NkR#0H@CDEUj)MFG2EeUF)E
+K!*'QQ4l(I,D9#ER6!@Jpp1)a0Ke8!ech,(&)lfTK$`r8k[j28pA'VJ'Blc-IB3P
+!SaT*8$HNpQiiCm*f[q[BPTb6fN5P2*@6j1+J("!e([SGIH,Q-fdi)4)3c95diIV
+981!324bEaLXJcYdl4RDeh`dql*EZm"%*Db)8[+[$)RkI'a8U(rSrEpFqB-Y)fZa
+ee*TU,NN%%3i2!kpa(f)AQP$3`Eh!J!9jc%!-N!"([J4Kc9qjRCh%eem&LD9)j2`
+#l!br$f6)Z2ap3,4lRIiCiVJU8LDF&!4!RT'pkrhj2#,`N!!i[,G&J(!TB,#qLRC
+#eRafJfH+&QX&!6YZ5))LCPLI,LG,IG9bYFJP[e`P1Mm3q4pT&jfL"FbGRLib3ZY
+-&dJJS-fHcZ@j!Bc1Q2SFe,EkB4G8RcPeM4Fq%mB%M#qN(c$p1B1UZbaqMMl*+0K
+1kA4YVh`4&DYK+a*BMfUkVl+#h3!C!*GINITm*c*eVp33fYD22CQ9`GBiTHQ!QlH
+fif-0$cK96lUc)ZIqfpHJNpU4)e+#SHj'i[d!a&1BCc'CP#M"INQc3[1hHfr9L4@
+46P98+4[9m1D15FFZRNjDa553!,(aG6[Q(3BZY2i!)1&VJK2k`,`RHQ03I+AJedM
+eLfq&a'laqp`TkB#mJM851FUMj'2XkKl&0&dGb+"bA-E'bm[*iCeCYBLA"q0$$Tb
+'9&p8pEpJP2$MlLhi)DRmmj51j[XC-!RpfU#qkB,+bT@0[HNMU*,Kj,2Li813!2T
+%e4[8#KU1a+Hc@(6Ra2IM9kf0[l5GjphLdK&b-(,pc'U$S,CA`GV'J+#bP-c9%Y9
+8m3Edp9V0PSJhY3q",)PFA15iR!rhT(dhN!"aq!ehqIiKAKbHf`KmaVN%kC!!@VJ
+j12Q)X3[rkEQ[jP@jPU*MHIH-!GblddHCIKmhqJQ$"mimeGRZK`Q!F-Z*d,G5qje
+MG,1jA0Ab,Mb622%Te@T`&!,*fI3Zaq)l9!QJ2&2IEfFiarlf#N9C&9BBX#94c@F
+ZkE8eLC+@d"k"%6hp0FKfN44cC,lj`k@Eb3Mpml&mJiSQApVYHEA8EmQQL2AImbk
+C%8pe)(3ah#[U2aZE@`mEf)mZ31Ub5,P8&*c@F8prq#ra2!Mlj%SL'4Gh8lZI@2&
+rfKAA$"MrFmB%lA#&q3U&LB4U'KYEd4#arMhU6f*p4pX*eh4+%l(i6rNe(US`C(0
+UUM[d&2l68`jLr(0Dmp+SL%pm!JAbZr-Y0QHpB5PrbF'6+"[hpUHi*mbmq(YpIb(
+iB(r"*pf86AUZ-!l)V$HAl',dpB[biK4XhPiIjeL!5F39C-K"Vlh%H0YNG5@r1(+
+G,N)iGfhN'@3U8KNN-i+$E%A$DNf,$-9iY$!#JXXB9%0f(UlRSJk)YaU3!)9Q-9l
+m!fYq(q6f3KeHlAT9l1Nb1)&rMiMRj&8bBT(jp)#G2A$ab1Fp`PB)aT`D1("f1S6
+26c!6r6aRcr9f5kP@43340EDIJ(,)EBRUZ$bFB)Bp$DHrl'!hQ%Y-8mmSfIAML3m
+IEFL@-m8b)9pah0(ieY1bIBEqVcVNKYQ0+$Ap*8BdPJD+BeNI$!pU@Bj8P"`Pf2E
+QT5K*@Kb#Gr58CV@JmK2YA9$2Ifi-JQ-SHpUa,L*j)3l5J#iE"%33)#@jmFZeDfG
+5ZKdH'[Y+PIb18DRh@)K!($648I6KkdBF%kccR[drlc513fX%5V0'I8fedac*a'R
+kDTmjjJcTbpfMm4AHT6D4PqYYL`F!rH[k0)9b$baE3G1b3MrY6$$l@bQIQdqV9#!
+dFcf!)EF%VL12F'fJJYZfXZYQhZbBA&P6mj+R'GCL'dSf1-%0FRm*Ml+ImF'HHPN
+PrEP3K,+MJ0Pef+f*pS-$AH8-S2P#Sqda)Df$@rQh%Kl3EJ6QQdG"*bF9ZjU[Xhi
+-ZMVIe`aD+P`me228S,XK((,kN!!0H9LGMKXBG,)(X2cNCad'D3#[jiG*hb$eNm,
+1CEkGjB@XqbSS+kaTKJ@qNm&*lJUr5QYDh$PHJ0I''f*JM)Kmlq#kPEZ*Hi'+d`2
+MqF"4+p9Rq8l6+*RE4!@AVi@3!1`8rVjR3)SG,l(6$a82Rl,e8hl8&B(XpI#M)cM
+-8lFZi+MCVAc[*,"BIQ2,Qhk#B&qZA%)9FKqUXYk@Qp!TNJX!,lGd$mNUlD0UfpP
+Adh"381Y!63!r$fP0Mq)&B"rP-&@rf*@bDH9G8IFbp!he3()LEmFj[`'DrLm-Zlm
++lai03DpBX9b8RaUCSQerK"cdG@2'[SC5"0&AL)$DaAJ9r9hhQSX)1A612C($fMR
+CiP(GZC'LTDmZf%q%lJeZ$kS5VjNKdY6dX10dUEX5-0q&`@G-DUJ8f&aNYXp[FHc
+1lJ(HBlPX!F@Vrm(X%0T5fm[0&(c*5ldY1[(X'k24LEl#LaFf%EA((pN(hIreK#2
+35Rj2#FV*[$b(1XLqNJ8+1QXR'@lrBkXLD&))e*ci0B6M'Q(QUcd3)1S6Ic&T"5G
+PPl8UpC,qJ@HSBURlieK45*h&QccXmf2fl*`[h*cfpi`M%5Cc%Mfa+N8KaMYjjI!
+q-Z9-$V!SaLTM[ZIf3IFFIV0AJqH+YNYV+aQ'j&GlmY5jS"""@9(qkjiHE%J0LC!
+!MSZ09P$I(41NerEN(RQpNC4JGLr[M$,EikU`T-UMk**Mm!4!SBPA6qilBe-"Mq-
+AqG2I+V908X6!FMT)T9dd0UPG!9#!*YXLDiC3'%6%T2ZVL[!eY)c'5*eQ"kM"9iq
+!KXP-BmMdp*EFRcD&r5SZT[IM%1JqJbP!2S1H4QJA``#p`92C!f$BEkqai'23eTS
+%"D6c%X6b@cG5)e@hf-*9PbR1qhMeLVS)9RFRGR!L4NF%`dd+bS[5ir,FMEppf(!
+ap!5qAYDjMHmhHRdLi'@%c+5-`,%YEP1rEBrmh"YQqAa)S3Ij#c1UJj+jKMASeMa
+8UcBYIj%ADYrmimbFjNdf-!c`D'3H4K!8H1Y5r@B(C"'l#k0XEMaimf-NUG[T$Vh
+$h[`pDl[3e!Vl'#C@K@h!#&[XB[4f03E-lBfJQf('f$`'$4q"ZYMSj(Q@F3Z3!-#
+&!aq2hpXI@T(@ENr!9Q2-CYDdU,1qS&`CeGdlPX,(DS!cJr#GPP3H4R8#[cQSIcm
+q,QqPHb`SlK8%c'"L8LJ3dH&e'bHRNFaZC*6j(V1SSD5'bjKSp81G))Pd,0ViS-j
+rlM2*'PmMKKj!`Irl"M1fBmS9mJ[SRDGCeVQH9pZfH@q3!&,+pq2Cae6KPVYCC8V
+jCJRL`j()%Ndp!H*&i)Th$12"j1HSG,TkeA%cL11j9!Br3NV-%0Na'`(AIdh'@,@
+M#0lk"RFYiUh,jkc`Uef(M)q#T!%bpGFKeb()L[fY)-F#`SL)X$Vlei`BUE5,VIq
+dJ[GZNmddYYkKjH"T(H%*KJ+Bd'S3ARUHV&CVeBrrkcNUlEKV*XVNLSqC5M*b!T'
+0#6mfji82iRk*JI#C$e0E%(9X,H98ePL2EVHeiilFCp,hCFIAcqQD,d'&R2BcQ8(
+k4""3jhN`UN!Aim8DXa,#hUJK9XiAPU0cXPG-AB5#mbcr6lZ82CB51ir$41b4eE,
+A1@c"1Tp(r@rKS@-I,4F1a`5,`E'3!('ir5`8AFb8#"qCSc@E")X[ejVr$Xp8bR(
+J!Q3Fa#H+0+$T5#Dq@*Je4DY@M0,j,Sd`XX5LT+Jl(ccmG-aXlc,U[1dSMNLDT,'
+&i4QES@EKU,c*ciYcq4(i&eY`2e8[(p,US+fUSRd(#D`UNYXHJB!XHLIJ5q@'NrN
+4rQUI9I6$h3T"8jrDj-+kdG2M%*HR06IbE,GfC2GB*h0`UmMm$2MTLji!Lrj+INZ
+&),G`!R!D,bb*XP`1aj9l`99a*&qR36bLT+c&LYBF-FX"@D"UPJ$)0URXSc#mNp1
+CGHTKL'AXq$'0Y$PaJQ[a8,9F9X6Bb4m8UTVI*lVK2lh0pdhISkc2i)qkS1U@**[
+E(2bfV40k`cblEG)4EY6"[r"c[JcK3@4T%I1'bNP2`rCfe"8XimbQ%pTe+kB-cH5
+mK'5%)H01SA(5Uiq$,VjZHL#Clr9181&b(AeejpS[X-+QVE5k&c8SGPrqFAA8a*0
+a8-1I5PPMT*Fb!K(d1#QCFq)Ba%9'e@T*Q8r"`0b!$kJcXAR@+&%%C6H0A$Q&GBA
+'0QjD,YAB2`'Uhcec-1)!5NqedJ-VLq4K+i8mi"GbEpr"VYUJFS0FY`k1BlaYpiG
+UNmUaDPcY1bdNMrPCP"3DYT!!AUAATp[Tbb,4C`fC5BE`5q'U'irZmP-ej&Q'!$Z
+6eH'b!X18[LJec'G8+E#J)CP)rj[,U"8i@Ap3ic`&kTCdRq84F&T!9,#d%qPc`F5
+XdZ3I'8TQ#F'bk'94RU9ZckA"U%ALP)HC@6FHreBRLAi6UM4UT'M+4q0Zpm$+k`b
+0MJ9KV[U5iS1'+NJTUcJHMDaFMbVAhIfeU@&G6@!dj*)YZr2Fe-2`8fPQ`D9Rr,-
+83Gi),&08RI#P9#2ef54kSP6JCFd*rCae(5Ke-Z(mi1#!VpULVpFN@-!,0ShSq1@
+&,M+MiqkHXL1C9QjUFIP%aYVQU2(#U#4ZRTaE5P'-mX(dh[8G1@Rc5jD2Idh$3j&
+k"X&-lM1!rR$%-qIr(IaG$pRMZ%K!hU2AqN@dZ[EV*-3[4bP2ch0F)!5Qj2$DDi[
+rT*dr@8I1CPRQea-"(4VZCpp86brNpLl2NETkcJBESXPjXXFI%(*2Q'jJSUUAkD(
+V(k9#[LR3U$iYZ`+@*lU6h9epSA2QE#!AKb!LNrleHq+DC@k1iI+Y#(-4Xb[L@aR
+kPThIX!9`eU[*Af6LRd%aC8+G)*ap[$FU0p-G(M"f858V2)afR-)$lEM84f[%!QI
+U4eNE361!ch555m1b(dD0N`!ZBRl,6UmJ2YVaKIJAT8,q'-V[+b2QSH58kCl0A#,
+EZAiqG590(llL,)`ZFXX+AYZ+#kjEQe$'AC@KE([-$G"(l[i3)2XE+FRXkTe2rXN
+N-0Mq)3AIHKTPDed,A5jH0k+LaRRiZ%@Y!MS!CJ3TElZ3!+%D#X4q$CFQNX-I6mZ
+(rqqYZ2eC!m8P@pmBdNG86Z-`"I)5!`-YNPPr"C6D%AmB`),k)ErhGhN#!@S6Kh6
+2H*KPGmZVNI'c0!aKS+!$(3+K+h1P+(M"3+h@UqLbI&Lec3`(qB!$YKJYL`4V51l
+kB[eYJF!fa'A46TLqRjJIcmcd!jTN[&+[GD6U+D@FhCp9DpVj5($JaQ)*H3T0P`)
+FeAQ'$Mqk`KCfAlVfe$pT9"2(rV13!+1-1jCIN!"'Ch"hYUU29-Edf%(UeTp)QZ"
+ZPSQ28*mVZ2[,cDSpXMd'$PmbJ(H-j1Kqh*eKjlR"c450H$3rM%+X-0i9%BBl$8'
+cBE%L+PV#E'AXB4&eS++1Tj-4EJEF4$rA5Vm@A5D,92[ULe2T+6B4E*8c8Mb!kf!
+)V+9cqeHRaFUT!6+fYGY8MGS,NH!5KIG%pVCP'm`SAZ`,$#Zfj#650m!LNZcUqM0
++#CJLI4-&*Gr+!(cl"+@-28j2fZ0T)RKHj&FJ1+YMNC[h`jD9J32`!a#ATDQUc`i
+M3B'1LPX@H`FYSI-'i4q%arj!S+2"BXGeV&1UHP3'6I-Phmh@9kpI0ESXl,PE$hX
+)iAeb(CBCGRA"SCiKSP@0)&eGQU2l2iJcka1AEMCV)9*"X$E2iC&5MHT8)5'EY,!
+caJ$dN4RBL!IZHVmi`9MV0%-*m-eTh3N6&TXC-kqT`qGQpLJTQ+q91FbRFYkjqPK
+6#jjYjGiHSG#G`$@8D[UqQ[Spp6JV6l5FTL1bAlm@lILq5+&IJ9G-!51,1l`Gb+G
+,6&jLem!B0$+e4ZBcV-k24IYpLHQcAafk8K'aV*XFq6R'*(``()rIHRh[NTZ$rPc
+iB0(D'e6'jbECIfbZkJ(QUNj3TGT'[#h2ajST4eQI1!dm4l)iS#lB91pfLch!CC,
+bUB`TJA$N)-i6$224eG)@jIYS#22VU(F`%LCi"TAM0F-RHElQH#pB+C+E'D"T6Xl
+mGK+Y9VQm-MMMhJ$eJ!JePf)VLp'4(k5a!H[(015-h`TLAC!!qNf2ah3mF93%qCm
+!YRG#kXfrQhCUA&f&XA"k8Gm39XKie+XV)aJf3#VSCqLAKZ)6J&9-8ch[)!%Q@k*
+eF)15X6"[CJ#YQA*fh%MkXj2(lGT[8(`RP-lG6EicfF`2hcc2%*+Hfa%3jd"'JX(
+E[B@3!(V1BiRRKJ&D8hkGDKC,p%6bi$q&$,Q`@i+hBib6Y*(cG#!2V5"N06ZH'"E
+!+ef[L-KZV6l(kqH!0#lL0,6,"Nl1kdd`,`V!#N$)@mDfj,4*%HSIQ3KVch$daK"
+q&`9bqCaS4K5AGJ@iaLQcqNdIESam-B-8$9Zj%ciG4b1q*llb[M`e3%X)QB)24S8
+V1ZceULkb(3Yl1q'R!Pc20iCr4K(mR$`Ka!602NDSRGKLDh+QHqdZC%4lSKmTr38
+Uf+jLZ6a8M&Q9'Q29Qq+-1d*Q4hM0j&X&RSBZd`NbD)4Y-Kerf#&&%9Ri#Hf!iVl
+ZcGa4j4KC3BL,TA`h@0UG#kZl39Spr*5F+Z+GMD8e*MU[jZT%KZ08&MTIrhTp&('
+UA2H'59aSr,$&D8%-AH)#(B8'1Je9)Gf)5AH99MpCf5EAK,Pm+IZhaj5Cjh(b1Jk
+peI+V(+R@+ZC*IBL",[A4d%#HF1K-ZRr%-8JM3INlVdMIhD,m$iq!iZb$G0NEJqX
+@!LBibiB3q1CaS,22Vr#&,#45[!flm9!CF(a*MI"a9IrhR+RpBS%TlbpL,`1qUIB
+YbPKFIRb"9q001b69Z'5[Hlaq3Ec5!c!MA40AMSa23EcH!Cca@rr3M6BJP"TX,AC
+`$VmNZFPrhq0H!6GL@q$9EYPp1ND`#lK+3-##0aMPMNQrik+Kk*!!GDhSbELhC2i
+lmdAU-6$-*&KBkP4X(1INKVcI,2Kpm,cH1)q4Pq*!-jlP`-q1Hc&f)IV)jjq6pS'
+[lBIf[Y'#GCHRiU`qG%!hQlH'J-5I3Zd6-`6CS2T+8a!-Ta3X6IGLHTC2a@1Tcf)
+jcmA8+,jdc1c9[#2B4!ME'l1Q68%6-mIl')I"9mI92Qhm!H4qX2E4I#-r$MLX5p`
+K"kKS[DLjFY@dR[iiDd53!1"48P%(l6-BSXP%Zr(GrZK1Jlp+$aHP#Cdp"Cc&*Rp
+TXh*MQi9P[CPG0&1dT&Jm0j!!Qm1"6"LTD+V,(IaYE'VC%+2h0Z&AqB!8j*6"&'K
+VLSd`HAe'rSPh%L[QU%Ppei,'HEb-+,VmD3#49"FK3lPCQC2&q,NhKBkp9NUQh@,
+Aml+@2kI'*DdhiMe8a!YAF&8ZP8kS#KR"KdU[e`+k5BjT%`Kip9eJ*qbCp@c%%rM
+ERh$N(QSNa'!LZUZA)bkJ)N`QmK6a%`8eq`NqlbkJY3p,(hc(Ur(V[VE0H!IV%jm
+923N(`X+)C3dlRTjk[Di,G"FXN[qUHdR8d`C%LMN5m%)&XQ(F'TpbFDU8U2BI%m1
+8,&F3p*jrU0#q5RPYRk%j-p)+mIbFF0f,j%QL%SC6qdIrmG@c5jEc+A%M9[[FlX!
+X&GdJMJ+1U'R5F&[KG1&l&+Z,iDKhYEJVLel!ejDTaadaV3)d4,3SqaT5fBT)iCD
+rR1Nf&GI#m@T[GdSJ&Cm3jc#Y`jTlHAeZXPG&b@*S,m2kBNqpV2K5Jh'R$YFh"Y2
+9K,-PDG#9B-DH+j!!T*4fac0*b!c&3adJhAeY9L2l+R`#i'@')aL1&P3b%5f0CTb
+*dQ8f#Y+!KFrAA#%e9E%eBQDl5dkNHMi["'"C'A`UmV5h(A#LK`9ppZ6l6U!C9(i
+I3HXP,8"R&1@Nr(cfbBqYaGKQj$&'"KlTq,`JcV4NaS%LXTH0hh%(T[AkceBa0XX
+ICp9NB,3$AdQj'%#k21b%'D-'@"$MlfMlF9d+kSq)$VbdfSA(P"[eQ-M4!1Jkc81
+f-kBc2!A@r1FY,EYL,(CZef-j'9*JjJQ[#F`Xfq6X-q6VQ84dBGYj+*PVh@N&[b"
+m!Yb[AS4['TmDGQRGLa)$EMmb+d"Z`,A#[-+($f)c&p30D+294lIfZaP9,GQ6bP9
+VDZDVEq[RFa9$AaP-T#CMKNN*V'M$k3AYkK)#[dCI@8J""ADkjh(mKNbC)T,h-l#
+jXMUi+D&2$(@RZ-pdpVdbp'G'jF)BGVe%)QlI&mN0V"4-4mC!F2QrTU5)!Lpd)1)
+!(S@NNDk3!,bJpE3hD1H'Je`Q$+4reCBhBZ)ihliFeU"m6f48MpiKm(2p5CJm*SY
+LC%Xe`[hQa!ZK@Da+#pj1Tfeqe#bce8V'[h9AfV4!GKUN'BE$AkAeq@9r)S2)!Bf
+M,Ia,H8S55pjDmh6+ddfh)&iYDm-1GMYH#&j"%f,e53V4%kAhq2+MK`k"I@'EJ`p
+"K*pea8*TlE48GM`T'5e'&"D%TY(N853EYpjq`89*Q1+$2A4YX`X2l*GMZK$eSA4
+H`IUQZM9T8GAmeGD&$U-e,9M0B3!@ECQjj-rB,55m'h-d"S!da`*lqA8Vj0["rp8
+TC64E0)bK[cC8h&@bDY0F`-NeaYK#[80Y298&q`a(K`PCaSHC,jX"1L)(lMAaU(d
+FNrHMe8LNE%Zb9*4aD'XEIL#THjj(Y3(jH5YJKf8!Gj&VA41,9a)pdb*``mF`SR)
+j2MYFe39[4H(p9R&3me8&r55B+FHkk@MB3BP#bfPYBXbV3b9hT6)4f%"6QrQ%3("
+E'NH,@lA*jR4EH$mAm*hJq'5)ZC9*ciH(ReH[#a`[ai0rf,UpjNQN@ZAXUlZiZ`5
+A`ehdUk8BU[IEi'kFaLN)f-cmcb+UC1T0er#!hike[m&95MF,A2$Q@ra&EQ+9HKD
+j'Uf66bCZ4b!NhHb,3q"edT@icIkl$c8-88C-HEZlY3j'cFmR`hHIS)Z2d`hDaK!
+I9!j$IU%9YQQPZ,fK"TBUQ$jQBe-iL6HSHjEZIHr'XE*VQidM)[[h''RXj"&a@,J
+bG-i&0HT+kFcfd$2*(0fG&@#qYGKZcp)LR+TUCc5%cVjRrIFjKLF*)8Aem4(aQhE
+hMpE*EQf99EN)@jY,b-iiZIK34KM)qRcNkAk3!2Y9+&%TqKcC63G,1BC0kl@k9SC
+#f2p6[rV*1rU*0F11j1&NFBN59XXeT,aX*(`G8AJ$H`RF%Y9-5RdJKLk9`&Ab2Mq
+RN!#2#E4bGB2ic%I8p6N6@Vk5GYR#ME!PZa`0RG(II!lc'Q!82*&1K@r3!-5)fj0
+6"[e4b1Le`aIl+pYkb2063#mHrM2!d$1#A@`6!X&r+kb*F5TUm)ab,HS3ST3iGlR
+J%Ei!-SpG6fB![L%Y$Z[Z@biqYA3'hS`FjqG#iiRCN!#)EGSS[%p3Z,2eieMe4lZ
+4$a0PF8XN0"qCFkiUT'%PDHerL4Da5QX2,TMIc@H&bq,rFLK3)#QcSV6"2LJDK@+
+'GaFUP#QmE@feA6XYKrNHA[LeK8TADeFl!U"LDQXr&d%qJ3GLU*2PVBSe8ZAL[!K
+Pe"BDA'mQEj-EiThV`1SUcC`-laqV%V5aj3IV#$frY23"MclAMdZRPi2`6EpVT+b
+3!*!!J5k1f@"H#hKAhhdUaX1"LU!L2!V-Jq@+4%`,0R"B[')Q+Z1%XBY(KCI!jdG
+iTAY)qR"pkZITN4JUm$pHaIRZ"*U&$Fa"ISRqJkJ"4C[f(1`#['&F+4Nq"'h"idh
+kPF(5BbUjk8T4CV[I@G*SL#Alm61)X3GS!LVHf-YT44h96dreUJTPfp(4JVk+jTp
+,jIeXrK2A@PTPXC!!q"KM6MjZS9r"XLUh&(aYHJ'jEP#LGhFl[LZM-`TEU%cUB9c
+2KCK(QPP*r`f5ArY#QSSQI@IcL3VK5AfAVm!2e`SAe%YrQ#4Yp&#$d60$VJT'3H3
+8+8'"Ub#DR+Z1a3jL&6m#VeijFE1afD1SR&4kJZHk-Q+ikI#iH&Fk#F6MUQ`L4rV
+p8p'f0i0$&!46"S&lHUF6Aj8&FJ22m%akdieVN!!r4BDF##fNACEK8eIfNFS@FRb
+!Z0i4T9!894SjmlGabH`kL8VeNAY!@3S6R4J5JRXJ`YM9K`&F0pS#&!'UATdf4+X
+5HN%QP!'8FR1U0FM*@lUGM6#B`X$+a06JF%-hZ`PX@Y1b[Fl&X5cUhr9Y0ZihfAq
+@&HDM#mMKPPp%YY-B3M&A11c5JD+"*`8F6F4k*QU0!5@59A&Gplm3EjCBVS`j%p6
+ji6mj0rAS(Z16Zhk6'I%5RqVHKB8`&Da`IM#%"`SA"-1`blUD*6#T%1JFTkUIh[C
+ErrqrKjej,@dI8Y'liFD3!'U3!'2$5HcfR0@5ASiJb(m`##J$N!#3!)S#"'!Eld5
+Yp5a$J`KHlrB4Xj(Q4DfNJZi-2Y#'ce4"f8S@4kj6P[K,L('"XfHd-U3-qYV3KCD
+pb3Z3!'Ue35p8-cbf`2kN3(d2-0!E-*DkAT05YPTmP@UL52!rK*ZAiYIL-Lc$9[$
+)4#p$$Y##%&,`GU"8J3(k1*SZ+TV$+H`QcF49m)4AJCa%3EQ5&1pdh%RiC%%+-D2
+99$kc,2hb'JYpN!!JcmSfjM5q9bFG811dTZe-S[#hqHRD(VS'r$MNqCRe)aLZEE*
+MirM)366CD2'(5EPm-5b[c6&pUBh`XC0JEbM$l)kd&m`XX1+mrC@mRK6'YE%kNiU
++qRAF'Rb-!DX'Sh@@9MD9q(9B(CJh[[3F3R"8b,@SIr&c8XR`lSAVMb+DqCNV,cE
+&)RY3RAD'ApXSZ5G6hJ-NMj)&#Kbmh#Ar*h9M1rfS,[mEBbfAEC+EIIH&XQjk-XZ
+EI9p*"NTkh8CC(hPZBb#9,p,@4Ni@eEEZqN!Ncf6k23j[*STT$bEjQJ`20D0T"TT
+k$GU-8`lSZZ-JHepEDdqkr1)Ne9!erE8(@al4VaXcm&4UbKXVq9r`dZmZKip)8f0
+ZJ$eVdV-fEm9DCL(h,ffKia!eMVGBG3Qjqb,d+%C2D5jflqj@-0`HQF("l1)i%Pa
+!ZR"T@DXUB"fS`bA02SG1jAqil4`XB1,1%59cB`AMMRK9kF$%+CD3!'"GSV4m9Gb
+Q)5r"2(2PkZ4`*Bd,Zlp6'SUE4klDpJ!dG5&cj2`#1HFb4bKq4r,EJ,q4Ld3+[-E
+q@,KQS#PGB)I2+6i(25JJk-dqI[40PjGMb,e9BU8PjY-S!RXNF(T@a*8UlI!0Ul)
+Ma!M#!FeR(-rr9@Ge8rT8cR&X6"30CMN'biqZJL8R6ek662a'19-6h5Vl6f5RE0i
+6IPc4C`mkcI#q6VjTbRKq"3I)8+-EXPL8D4V"AjIhECrTd#Hr*['PH[mIHcAk'@X
+2-0*cT&afh,f0&MjRJN$6q&YFB6LLDSp,09e@h('dKc(meGDcZJr4GFcYR-r`,i8
+[LBl(%bQmFQL&HGGND1bGV)fS6!cQAS(Zah(A858MNPK!Ce5'E%CDma$FRj@CrMq
+lMRN%d`Z%!IhVr1el(8N9rfe46jj-$DTZr(TCKd'mM#%DGBBAJ8(e3VedLmIcTjk
+Z8QrhX0#GK$4"XDQh0j*E%bT+rHS%$@h5K'*QP,@Um#iVXTrpQmQ5b41VMDi$0%H
+4&*XIpAJfI'$%(10+mDb064"5PG43jZ34ZJE3QT!!X@edA0+A1+,SHLc#!N,"pJ-
+dJl%F[68l3fNPV+[Ah[0)iIX8BeiDf6hb1PeaeSI%2%B#Si,R6ACS1h%KPiCb$`K
+KTp&bXbrb(S5S(&f"FMr"A8kk!c'BdIV$Bbfqr#8)SBcZQEIJ2GY[)$bBYG[cNrl
+!D!Vl8lK3QH)*XqXJF(I'RSc,!rkCB$S4qKKd5X4CdFP2Nq%GF4)K,)N*0%&p+DI
+A%qd@5Ge5j@r!'Xq`42F-8"I81+@#a6(QC5LCVa`TN@hiRd#j"j5Y',1D3E6DAl*
+ZQ3G*80FRH!0@29L3!&iQb3PLcCGVE-e0T!Li##m[%(J[qZP[QJ!3aD)HQX19mF"
+IT!B0[eQeZV5aP#ZCKE823S'R8PXqKf2T5%B0V0V$5+QCLHZ[`eU"hrX'LqN%i5d
+Iqp)ISCkM#ail$CbB*5i"kAhKf8F2FpSqB,JS61('1mRp0dCBKqMAr,YlDqK1pH'
+PQ@+#b2F9hNM1d9"!eUM"[jH*SfJ5qEET2fUJ(NU)$bkh!NZ,lAb)!)d$1iZXYd2
+#VI5HHhJ![2UiYB+bJ[Qhl,$#emcI@e3F!lFT0U)ED#*QliSf%$"&AD$e![cj[qM
+"eqIQi2Z8rMcaQI&*"Fal#(0ZRq*Z8BhD&d!cHlh&*K)Dr8Ld$RkV(Y)IU%c6A6J
+S12UB51T!![5ml*Jjpa@peRUVSP2IH!#PN!3"!!"$!"#i)pScZ#2D-`!!Ep`!!0`
+F!!!"-!!6bAi!#akj!!!LZ3#3"!m!9'0X6'PLFQ&bD@9c,Xq!,RKYE!!"m0j849K
+83eG*43%!rj!%!*!+J!#3#3'D!*!$E!#3"!m!3X(9$qA8,*!!8NT&S"6e"mU%bYA
+[Y1QHX&BMjQ2ahc,$m!MIA$$R'`VL@F"A4pDH)kaKa""@D8%C'RA`LF4NCHCM(6(
+Cq'LiNaR8%2m4p5Z`YAR`Bm)BX@"bF6THhaG330G5!cVEkD69VGF%!%,"e+8,`$l
+pV*PjG4R`R3eDNISlN!"qd5Cb#i8Y,r$"DB[+lC9*bYc66$Hfr%NFkmV#h6!AlFl
+I!kibBp(9a4[JB@kG4rjYTq6[59V*FIMU"U(hK'fhLKAZEF1IEe2q(,JM$YPAKbY
+#Q`*%JlAK&88iXK3%UiN*lP&92Z#bBBX2HCBblr(MfqPG1-q9%CN%eSJjfpmq6CL
+cJrLiE(e"lcq!6`fH8*J#hXRbA+jKUI)aZI#TUI6*$pe*[bbq,)FYLHHYJfB&+Z[
+'bm'kJ6qFPM-+3Y"dI"6DAe12-,5F[`Sfr6Q%80,PQc`!'2(P6ERC-lc$BH$@qS%
+X4EjGh*Q[bEc`)*dR)'H%qDdkHkh%1'C$KDk*b$dDV*`REjF9$fElUrKQ[d&4$eE
+B%&PpdQ'6JkG@Z+aH(rj`3JKS+8DDhiIFI@&eR5)a%ZHmAX4T8,ha$0kdZhIQkTb
+b3QRT-EqC`N1BXCLl2RDd+@a+3mUTf,)MU-i,"MG($8NR!iHQTJ6kajfB`!Pa18$
+FNKerI)QK("6Nc*Sr2V95UFK-&UMEJIVAlpRf#ZlpMc,+BabY2jcSDQl"[(0d$XK
+Q#@UR0UrIMcN`5Y9@YC!!j0AaK*V(Da&CY[4r%!l-P+q-(!lSV9bf4b3%pFF-YHK
+h2i2EDmQ&@9cBBjJa15JP`Sh)e$NrLZX"iNlTj[r#+@8@eAaqebY%eE!,eL9l(%r
+r,,BLm-Ma9(Q01$URIdJ,DAM6hP#$Z#*d'ECGKQ[6)KX4Z,-kEqh&cUN6ZT!!3rX
+bB3XeEXR6@,"SMY2l!9#R&3RkJXGEJL`"1!YS%XLU"`Fr9HaAbk[$Vb'G4H"kLrY
+k40H5f(ck0[aKZaYYGCJGfileS(0+6Gk+E-R0LXG,K41`4J0HGJKY,(S)8`"Vmj2
+hYhR$[@dI((9RcB!-NiM!Q"aU80ASqd8mM!MCDfDj$A%['4,$*f4pZ+%F8fIe0N4
+GG-FKCTSI3l8j1%F)d`lmAQ"@DYUkp*d%N86G#ek8*RR%9qh(ah%4RcdF)-`fk!-
+%5eaMlm9Tq2qr"YUC)N4SP,-86l)U5'#4Vb3D[ilbJFe(0X0+3$M4T0Eb1'kIhdX
+hA0P1[IKS1!QEN!!eb6,pF`8b"i[Bh6K5BJhP"V'Pqf!2N!#291e%d6`U+@i"[!9
+63m+N9hF9P,jV6!&@"9QDkcC%189ld"!)HKEEDkqr9NGB95+LTeY@%%&aI-M4)YK
+NlqYc)ZY)iqmVmF`+9$+eLhPp!Vai668U0#h28k`[JV@T,$I`X[k*F0[e4ebCX`8
+pSH8@L0`"iL9fQlKjU-pNE2*F12FAkL0KAk#8P3@$de-E#YV`c9[KaMbTke@0YaP
+VM#c6P%T&&+*$LI,4MCMXcaXm(JKq0AJ@2jqALJDL('F-*G!FdkE)RRZjRRJVabN
+dqKA4D2U["iR,!!i%0ED4Yp'M23qe`&2%jM)UMJS,2c"e81J8[kb&`E0'&cdJ'0r
+$A6ET5D9)J-K%$kN1TV3J(kiT03iJq5B6AER+mj!!VLlE"Ge6M$#Rmie5,)eeZV(
+UdCllh0)&"G0J!1aE!@'PQ!0dCDG-Q9Dm8NX3rkZaN!!ATJIpX-38ClaVFMd+,hI
+"bl*R@Fa94QFU4D9ejhYU9!18U`pY6VHITrYJQ@,9A+Y9qXlAS-`3bX[-BS*9ecA
+0!LLN@'3,eE3k5e2d#51bDjr$5!"IaFI$ecBQ3l85emcTdLpR@@ILlQG0fQF-q`B
+2-X18!58)f)PCr%5,-QllXmYj")2JbIrBJV'Ip&a2"NdAFpX$`,kUk)mG6iU`A"V
+q-8ehJ&,llIBR#DaRch$)[!fmb0[cI*L[86EC'Z+Z3)(`9Y18IiZ"aU("k$q+&0Y
+2(`1M6[i$m(T,GVM+L4cQcY*Vlh8X[1p#@QN6m*rHi56c96Y`f9E4$V"*K*iSK%I
+04rVr%2A+JP"Ql!U8,6eLL@19Z2%A8JQHRYe0b498D%b@bDi+dafFkC1TbZH99E,
+`mRHkPjFAS+F29LZTZNhQEr6`5NY+&BdmhIc8"p%q!aU$c$K[NY2+4mb#+29KXCi
+Y&pbeh%i3IZH&Dc)1!54"mZ8l2BlL#HB*1MZ*AT%#Ma1,SN[DAQ8fQ%IahNL8IZC
+8T+eDpA*#lbIi#3MJG)1"SfS)pFU"UZ@Q#,FEdrZ@R4Fm-[)UALb,jc8AE189`hJ
+-"YTji6Zp*4-ELAA,)bbmIEKrBV)D$`VE%%pDap[SNeG%HPZUV"(1V'PB)PqjNE4
+'"5H(5X84!9mB!0jj)kUk,cU%LA%[Z4pSkP1JhR*&iL'f#U!,F,frAaMGb`XfiA8
+!f#jF1C`5Yb`kYTD%+9EGKijM9mh4Mc&`2,,8H"+dVLjll&%prQdUYT+2)h5JmEa
+A%+me'e`r1`M[hArd`6A%ANA,a#,ED*5NF!9M%MAi8%Z3!*)UEFT4p-TpJe0!S0M
+9HIIlhIk-mXE8@84X%!SSANf`%'kq)HILTdk"b#!B8he#UdCL%S6L9I6rFiM!F@#
+`LhF06SJ'b`&0#4SVj9p6m#h+dLN"S-E+#NQK(YccYqN6F`d[fpNIRa4Z%a1T8l@
+*l(pe*p!KXK65SI'c2maSbN`GPk['iX*IHT2IZ-rArrS"S)H[H1b8)[%mB!+2e*)
+0ZjQc3MGl`+MCT1AFqTkF0bhkH'K@aAHC#Aj12K@'`9[48l#U&)FI3Q%Q4SY9hZ5
+D266mJMT5mZF#jd)S9d!c'j5`I3*$D5')fj*@J+)Z4Y@9#DD1`'434a2dB*XGf(U
+&5CYU,eMpEE$qE3d`SPmEZp'9NbNhY9,YBc(LmN1@Ql#iT9LVbLrS"MN[&&0-+@i
+"'id`DMc#jA!LQC9SIlfTimGY)Elq8#AL41jLe-9adhmNMmVIfZl60$Y,&5f@X!!
+,S1Ei[XAR,"j5iL1qheVA`-[YFHiXGqLj6JQShhhkU63iHj,HNUi@dE-6M+RKHGL
+l8(c0H%59DLbB9kVZhU(5)4ZllqRlJqm@f2"rehpYEV)h&X[&LmMa@5jJeED1LRG
+"F0Hq8j9q[&%md@Nf$I08-Hle[)j@Kk@8K5@X5DQV%(VJ+1@ES2S&bhBrq1[BQ8(
+'"I%XkHSrYP&PShSe,jme$pm'NT4$9Hk(lk[%#pk$m6+a)dhQLjBVXcbTh6FrJfj
+HT0FYPf##pYd93ZJ8L6-e[bMeJj!!IjjM3Yj"VJ+lpkA$Ur1!3crK0Fq"V1ipj+B
+HK396h!e4bL(!YIX['jc6N!$dj6Ip81k2Ulk5caLrJXk%T,cN-L#-+QN("1GYd2A
+AT88T$)UGT,`eYiqL4&ErK-985YMP"mA5)Q(LP`Ec9ikChK9NI8+JMYd$aDdZk,q
+TcF+1pl`mNb!D2JpA",!PUI+h0aZ2m(88X`(d!#9FZF+,Rr6+%c0C@lp8a+J&%!5
+c1G"QEc2-KC),21m3p*R)c5d*3rU&m-58Za,(NXZ4GeXLR+9Mf'504LFUd0)-p1a
+2#BD66)@-aNAXd[LiI6qBUp5P2S#M`cRNX"k`GrAIdqfh8,iU6r40TlHad-`'+#!
+,Y5UJRZfKI`G$TB+0*kh#FA,&@b(r(lJ[E",*,cMJ3jS(rD3eb#`3`h!8E@Vp(9N
+0@-AHq$G((SXXIBble91Jj"IFBKpTQmAB1kQE3,$-RIV+33JBTA`0VfiJR*!!%kZ
+fS)bph`*da+0`f34UkN83lYU1)Ja&EHhaEYlG'jP*ST@MB!)mcEXQ')FXl$dDKIp
+H0)TSSI*l[S"l()D8@r@-5RjZRMj'lcfl"f8"@Z-bUkqr4I@8mZ9BNQ!8-C`"D%*
+lhi%3#a&l2`R"`A'@XddRXYNUq,9QMGFVS#Xi-lrcf6)(Nb%JVK92a!XNKMF#E,N
+V"Q%"Xchk0*i`)G,8N!$G3IRR&ffECI9F`eaQ&f$ABbLTKhGBjM1r43R''d*+c*1
+F38MSR1e(ki+m5MQ9'GN1"G0e'2bj96%r95`*QaSE[SHH*TU"hfJF'bjMYG,L&qY
+JThHkaer)S'NIBhmJeVd&)H$8J!$KhU+*UQ+Ci2K9I&2"5hB"(,l-q`P)61ciJ82
+"#(TF!&5!J`KIPpddXMC!*l$Ehc00HXhL,hCqG'cIe$#1I!m'Uj4["SqTp29$ae(
+4ErB&,bPKA,!8dS49a8K%#U4'&fH)j%HCb-b&rmA2N4XlpA!Q$!cpedr4hdfjGd!
+`-X9q#IT'rjeaI'T23EaAYi#b1c5`hqXSD@k[98lIZ`c0c-Sd+L@GEe9$VX*dIk&
+4,dPdd$dAme@Z+L1UD%3l1R)(&Q3B'rSK2lU&3%U$IXBm-SR#3q2mJah,DB'NZD)
+YNYJ@k#cZ''VXT$V"E`jH9NS2Pm&@S'h)8d-BHeU(%18dej4*VCBm1[H[laT(%09
+H)UKJM[#eK@RlUZHa'fm(Kq-c*mh"D'ApZ4EU1#M,+*EPF*Yqli&ClpA#0)&a`MQ
+DSP$98Q4"9&%Q-6!mr(kXF8643'F)l6FB4T!!bMRTb92R3'(@(8$i#3FdTS%fUU&
+U[Uh2`jT$(4(KjINdGDi6Dl'T#,Y+#iNr,"j,9FC6*#PUA'D,&02UTFk5qS[B$fX
+8[[`FPU%3*1&GGLdXFcq3!!8$AF"08GlKUVL08'MP6X@3!'+lkZY)l$LBXC!!$+l
+"i8%UY39-ICVm`V6a@4'`Ci$P)eedifadR$FA*qi41E#F[VD*j1[M%d`'4k%d'N2
+a@$ljQ3`V!cS*2e`%ia+PG5Ei%*JHIQB[K!i@B10+-Q&pG4I&@(h3)0CJb5jie+*
+iFZHcCSaXqA28+ANd+X(3F!2VRZ'AkcDP[jbV[(D%Q32NQp@K6@9E&E10QqpSSH$
+(6KL[4lKCe&a(YJPl$$NimDh1U%Q6C1TSCYh-r%UemDdCA1C`R-NjP&`Iff0JT$-
+5BQLXK0+m69Bre[Epp"e44kNiT"&-aV%+#-3Z4`Up4Qq8Sp[1NhaB6fIA+piSb"3
+qQTbir@dbTeP*fmNbJRhV2k$APS+`@18'mdGHl6jM)()pZA"SVAEqXh)S-hY46S,
+5E@KLSpaak3#8rKUf1NfXLINfhci((r#A'UJP!$GU"a)LPmA)XF9c*'-VeF#Vf8h
+6jVCcmXP8Dh)F`X1MjIUHD0FLfK%06S9lbKmGGI&P'BZ"B$CBB-RZaPDNY+J8P'`
+)P!85Ub#4[8YB$MQI@,L#LhBHSh@PRIH&Nb6lP,[(E,'6,K3hL0lbRQ*-#k,3LCU
+3!"D+K)5dZJailX69dL&kJ2A06KcMDPKS"qf+YfiG#+!F#E[$N!"KEDM3V5p!(#+
+[hF-fleVfGZ2TSQ'6!ZJN*UY8ANp"%[-hVRL(3"Bkl@P-%,NA`q`8"r#&(Sl%1*f
+*Yk@QRD2q%l["XGa&dJ#DF[-)c!KV,rp-TdQd9&rejN)MpLeZJ)+ZF#TIDLV5*UH
+2,MS!C"34Aai622T@!LrHG'ZK!fejY'fQCTM@(fmaj1rhKMAK4CkDbe#U[83V1XV
+(VlAHJDmNl$Z`d#B4L)!c8QZBSX0"#fBcX64@dYi8V0%jp@$Ea)E5[`0LFDUVc,h
+50lpIT4'I(k(d'-dKL@AddVlG*6fkmk8228qc$r9[b)TLMc!FrX-V'IMDJNbU`K"
+pqR$p&Bq`rd+h,d(i,Z1jXdph0pN[+$dq-KbiTPI5S9TRa@%&l"J8[VM1B"&j*Ee
+(Z8Gjd3p*36eb!BJ`i1i)Q"qaGc3r`e@MT(SaG-be)6(kr,@@(),'+aXY86feIdK
+6LmKMRiSY*6%Rh`[8[#[[aB-Eiq)49@b&,@LPf'*bE5U6YJCIMSqhRjG*220%1#m
+#M)ZN434@Cj)8iIEE6#X0LjK21mY'&6,PD8Hl!hDTJeNqiAAZm-Qr"Z8@JF59P@9
+PdIHRr)+9@HcTK[)r6mDP,5S1F*@i%l)8-N"e$L8e,SfA@JPEmDSUK`RSKfk*3)N
+pLr'``VEQ3'q[mLhFRBIb2F'r#!#TbIij*Y1cQk+N1-kXF4Cfi*9@0iUZAb@T2lX
+QB44IKeb+"jfSh"5Q2aerh8Rk@krQp5'eKRQ)0$eaeBH'iDG21H`A`U+P*6(L4Gk
+j)L#%8NhiG)-GdI0mX&QG+LTjY"&"fSQSJVh$pX'*bfiU[&2r'kB#N!!-f1YH#+b
+&bdp*PU,T@$fQK&AL25'4G[kVXAA04U*101F!3Tcmb8Tk4r[32E,lmJ"k[EMLii*
+"I)EC!q0TDS@A!Yq*hFd%'aXGU%V$'BVfMdHS%"cNi-eIAkKd(GTZUkB!*k!@%5B
+&!ie(0[5EFp6GSD$TaLqR1RdZ%'f"LEFq9jl#5BSrjfI)TA&C!f0G[B%N)Ck0k-#
+V+&UJf$4eIi,fLRdBS#e2CPIFJVR,@ZXiaN"aKSAYH+TRi[XaH[V9VlNf-UIC-ei
+pfAdKXQ"cdH$dTA(bH&UGher5)6M!l[,lh-8*"``r&Zba2XLHU8lNm'()#hK%GYG
+eYf,2p&NX)qfi-d19CMpGfQi89+0p)icDXFr#I&3NY!M3%(Pdr2AifG4ALGj`6De
+*EC@Klm!"jQQp+fY#$aLc@`L&+@UI(EpA(*RMfGY@hX4Y`La'R&5K9Lj6VQ@jp#r
+@p)Z9C&[9$aM`K,m-"peJ,MqUL(,ja$3m208mmFMr*#lD@pHhI'G6pAk+@T@8dCK
+C4!+[Y#@RLGqN3'VJKe3V3,mAc!803L!FQ')f"`V4DY3c"rV)044LqDmBhq#A$p-
+-B"0HlmC-%'#f#4BfhDaI!YSdBEjQfd*&ZQlDcH9QA2BU(5md,&V[0%&(b*LHJbH
+rM846XlS+"N6q+a`YM3R[DXAF@$d5`h(Drm8ZXqITPPU6jk&J-T%GVY(&%`CHf38
+H5`FFJG`Km+LmT'6ekKGS[XXJdNc0!P680LBmXQ8D#02jF)CcCEdaMhr54$U18j,
+9,RYkGM%%8I'caJTa!F6!2CaLj9,3[h(IHEf(KpYY3A4!9TAV4AhAkH,6r#j+b0E
+!r*`EG5KjGKGMBrLcECJFKE$VUh`1M$#L8%MJ19ahU48$DkGRPZADAR#hMBCb$MC
+`DNR24QF2fd0UZeEQMY"6SQJblG+(QA3+*`YUAU#D!LTTGA*!f8qlF`)jFEX'Q'D
+V4hkTkDS0$T1INi``CYl5#Y2kCh)+HXb()4Q*aJDbBP*f[-U&jI8A%B$2`LVb&Fi
+IGiZii1i#TA6G5Lj+m3P51Y+Y9Kbd"5TM35%A+fdLY-X!r5Dd*9"JJdBqGk8)X2"
+![*PZ$q6Xr"@ki`rbh8(8qp"GK'[G"Ah+fcQZ((p9R&!FJR$"a""P0rVVG#Z86%-
+iK,3&b(JUE%1AjR4Z9Ga$4dUKqGjFe)5ACGX!i&[Ha$FmB0Z5qb"L+ZdRBi'@K8G
+6B*9QXrFk63a%Hi-4GXFSB-K-L$R`[KCDGKZAC4!HC#LBEH'U-`RlFh415pUCZBR
+33jkG(*R`IfCJ,Qf52EXL9TrXi0j6%+K@@5&ik)&$*VD[2Le3h#$*$d1*cZjkUI`
+M64Q&dS+D[kY4if#"KR9-m*UbCcd,,IG'Dl&qLj,6Ui%3D2E+HQUb!q&F'[2j"9`
+dFR0-A)p)kpQ,f8D-6Iai*,PBGEU@IN)P%0'8S*i(ip+*q)r`$A)`ja"HXTlb%Re
+MhVS[V$!K1TPh3IrU&f%Fl53''VNA@XdU$KpYQm1*lfpa15(dB$eM[d(!!rU,cpP
+4F+B6E+LD5fN`@c#$!JGh"m"$Xdp#C1rk4X[V&HAck-2k)m&bj6"GZqjXYFN#Vcp
+3G-jXF9RR'PS2CFPQ`BPANdL',k0iXZ,@!0fbI+F"E@SbD)3b)TDG`L1lYMGL,"H
+Z(3dHIf`IIG)#LJc3(4`QLdBMe$bQ61+aq$hG!-(k@)VCQ8pE)cSp-j*%5qh%D@m
+TiYc)1hX0Dc)r"QZjYQL,GF9#2HU#j`hQLHahfK&3`R-$Z!M3DPHQdC2Vk)Sqc,m
+QMJ*U%!hZ2E6@`qmS"H`iIq@KJib01KF(!DI0186$Hb!R(6MZ`H)#4Fk4mS-`9``
+D#`*ZB52AfRd*j`j4[(kE`P1)kL[H,'M)0D5aDXDf3q,L'ljIhXdfVR6GR9q@NAi
+NNf5N'Q23&q`S9PG9SXEZ"HbRMU@&!Pj`BSQ1JQU)*QLj9ai!YL20RN*hZHG@4FD
+RV-8T%1ck2Q*[FXQ@PPTCUN3H-j6J'm8bBQNCZ9*%ICcqr$-A(ii-Tmi(9la0i!a
+T2GI$X6a%*,[Hle#'M-ljS*!!HHf+A)p[mD`F*rjY3!)@!Nd!-(j"2HQbKH&#ePH
+m9$1'mUA'lTbPNc9JJcm5BQ2rZX,X8DXci'[jNlc!-H*2P8SHrHLLlKNAY'$aXDB
+,M9m0[P%9hlii5Hc#,"DpiiU2i)kq"-A2UHkD"KTlSiUSGIe"'dpMK`3ai8c8jpm
+*9210TC!!"38K##-3"P-N`!0"qKVkV,MF,X#085c%%(,$(Gji(ND*P@)C[ejC,'-
+CE-a#Vij%[*hmK'3c9#G8`QaPF'[Y9[(("#i-Ma8T2CKN%V-'*eY*G*)f!b(F&6)
+CVTK(@'&Aj(G2fKMmarFiUh0B0B,p[hJC`M!SZEli'+"j`)*A4$UHI5UAk5BKT+'
+6)%9EETZI4"J88F!))M#P6fX!UJV'cI5GhJMp!HIS)S1a6#rlUkRcQjZiZJG(NB!
+TXS,TVQ2i0C'eQK3%rhmQS3UdpSeYBCNLRKpIdJi2fH)SR&GamS*,3ZZaF%UHDf`
+S",lL#28QmhX%#h3[-qqCZ5,M),3qR"jf"[fG6hbkel0JL93!j0b#Y5q@H(m6BFK
+eMXG,,*Z@Pj92db(!'r1mmaq268YSV$d9FmBa45%-ePKb3'BBRD9Xl)BJ&U280aj
+e@mr[R`CC!j80)UNbiBRGb(eLeLmfZ#[G#TdcFqCr9eJ99mG&l!JL1A-r#5*Ea+4
+[)A,crH-,1q+!bkrb`Ee,i-aK4BULK42G1',!iq$XJHGKD@AC&C5(85[kpCp`)8[
+%PACEIMl@f9SHeIF4VXIKlA!L1'a%4LALVm*K9A*5!%&UVpl$i&1XbraK#12rTSi
+MkfjRNB)HC-qcRSZ%eS#p4U204B"b%Gkc*q"iHSdXEPaAHjhhakU#-9PZMGkK%e3
+#iGD'[A"jj1NbH8[(+SHiN8ih$rC%!1X$#ji(Gh0QP8qX-Z6K(FF(`B1A1%3)j%,
+TVa5TLXdN&SXe)@rGV94%1E&HQQS'J@pfrC*BhVYX+l"DBlFqB(2qcd8b2*V60di
+ARYBl4S$ZfNMY-TDFmf3Fr'-GKlZY#MR-`ZbZPki"Z9A"b0!jlC&`H&L6Y9CGK4'
+kjb,ZqhTrX&l&lR%ef[FGcfa-6E!XRhBh)*NUMd4bT"#EN!$$$%XMj3'8&Iq5YLb
+)8R[9996B9c-RP[GaX6KKAAU6SBQFD*@NkN6`)lYhq-GDU(q9Fe(9Pq2a+pC0'1+
+06Yj#b8iKXlF`9YeX!j3X`9N5Dl#FB9RY5QTQQdc@i)ca&0T[5+@,3NJM,0!chZJ
+aekKVD9'r2k0AlNAX@cS9fZ*$++(I$Id6"'$&pFcjR'SE@5U([jfUJbCbeQ[QTrk
+`qNX!0)fSq!C&8NjIcaL1-T394XZr(IXPNmbjfY)5I0iSPeY$93hG15mHZRZYIqp
+pT@VQ%bK1+U'&Z+GlSmG,+-)R@h`DC3jS0D&jT6BJDJQ%KBq$C)rMKcHRDF&+TUG
+jY8S"11YR$RBfIqLFVej!'e6)&'prA5d1NrA@)ddaLB`-ZAj1THRFhK35ppcMqDr
+3*)h)'VG+("IXYVG)UIT&Pm'KEP+mYTm-6"8l0VfkK!C)R)I3+96r+@eRQPbZ!V@
+m$,1C1YV*hN`q2CDa4C)1"hD&4j&9q+32YTEbJPD&6)9J`Ue4rlNLHQh%1!UM5`Z
+b2bmj%"+9ZUPTf%r0-GT[T+`+ll%b1[GH$BI[GaGCXeNVYHApL4MMk`GrjkYMckL
+P'"G[DF8"1(,3AE4hdTcVU['UF63VQkE5,YjfjQ+A+N&HFZX&l5BB3UbhP93C(Vh
+Q!*!!P'XcVSrJ)2MDhI#+,Pp6Z9EYT5e&D#A6P4BfHJ0XPEU3!+4d(CqjfEe+5[T
+E$%BiC0E5B6e@Hm3)KhM"'6[S3(9a"H1,)j9NG@Y5`r&,Q4BPADRA")8``@UF#2K
+6a8d,-PkGm)k+HVlLKD4+c8Lq@3T"IlRTM3aDZT[P,CUMmA![VNA,p'Q-[hTdqEV
+NUkQj-MqIKqrDX9m[6qm(kR`)#U$RaD')[`aMQiNX6@[c6HaLUKXlce+R@*mqJaj
+a[ZL6X*++!kqHjY$8#m3KF)qq-Z%"S1`b#$d!B0Qb%dFAc"K*fc4l9B9"q4!ajjC
+*N!$C%Z$&q`$!k*PB5G5S1cE!"r6-N`,!PD8HcCeaj%KHCYlFK)!GK95q)EXVC*p
+m4iRqhk@c01&8eZ*GfCD'-mXE-Laak#pBHRP@%mVY%LiiI4V3r*("(ASB(TX,r!A
+rQG0-4QEqpP@-DIT983QpQleJFd+Y4B85A&l8YC+qEmmQ3RY!-rb!2$@[9+3!TPG
+C""jS,A4`66j(0Y8$(6iD8h(cFa1p5B#m0"mpBpM24RK@(H0ZB&Y&jZS1d-Xh#Qq
+h`0)!5Q&$"NP%hESGQ0Cq*&hfVhFppB$fM3A9h6p%SArADeZ"[Q(@Z1(F)d`X&8B
+mPUrQB'3Ch(JCmJDpRI60hNk)H%5A5lY-eT%DbFJ%p@ULHCGLG59l%l5V1+l1YL"
+Vj5BD-8N,Pa[*jJca%cPh-K#6'TYepeH''2QMDFZ0M(BKdH&#Bf5I*15LX%C60UE
+JJlYAd52ELYYkFNHD)0`aFiQ)clNNN5$9@2Jk*E'JX@FDTRjVcj1YUr&qD%mK"dl
+Mp-'L[)P8UC@QkG&cDKpriLT'lckbP*N(60(`@CSM2F68mBFBL-jb2d@9ZNDK2-#
+&X@VHM50K5[$YU6lS+@0225)&3P3-N5P6@QH)cfC$1*j*UT!!F*1-!'BV4@f2`16
+$j*'jcG@#4aim5Gm0ce%23bS*LR3JpQ`k8chbi+Q*"01)NP(ZDPf'0D4a!*!!M`P
+Te!bFCaSCe8CGT'P*j((JdqJ)"4Z#,m*b,3@ZlRejJLN,AY(&D@pNK*b)T)jaBH#
+RDHrFPd,LcX$Q,phmlEm%Rm1&pJN&DKK`%@9Yp4j$F,VmY[#4J$CQmCq#(HR"k,@
+hY[p-QcmjCNG0HIHL'@qr4qdB[qa%B1-JA%mh@8QYB8EJa'B'(ECTB0iilEcTR"B
+AEQ-Db0KeApNCaZ*Sr'HaQlBF%8Hja9%(&[jU#kR`BkA09MVLC`2NZ+U2c(8@fBQ
+2(%Sl!fl$'Y@*ejT*q4CS@`mbj*D)dkMV4U9"jSfbF(4lPX1'-QGUfX9[@$E822`
+fqJV4'jLp+b`QLY(8SD2FEYY%'pkj04C(Y,(lLaYeD6P$"('c[Q8i,e#ES51*ieN
+aP'mY[1YHq,TEj4irq5AK,`$eHCV-E(cHJ8FbAmiq$BkKPe3@mqKN8BI-`h2+`qS
+,qA,h#KL5KMjeKT&9bqCPC#jaD*j9jNPhFbC@"li36rAb)MXAdcHCZqUUlJ2CBb"
+mm&8rKbrf'T9ka[*YrK!SLr"DD(%SF@EVi#4AaD!#eFrlH!-40Vmi8,5kGdlG,9&
+rrSEPPCLe[)YTA$di$`9f#*,8lGjVTIUrQ51qmDX#HYA)lV1Z)Ck5+UL"NQR@NJq
+85d0)U[k#pYadbJjk+eb4'&Z'1)V+@jSk&*BKCB2N[cB@BR#Z1+Hdd2c)PY3P#ae
+SemSHr)3El'i[XZ'Im2a[hEHIAUb*ZK!#,b3HRAiNYcGjjRN0ZRXQqjVmaNc--bH
+ErBVXUG3a9TP@B(ed3Sh'm9(pB1Cahmacr8miCG)KI9JJE@hXL!'fpcHSA!94Df"
+[p)%%Q4++f34B&Q)VS+Y'[rMHYDF-),b6Bk@al-'P!3@VaCk%%6066eQZ$Hh2Y0%
+pi&FRe84GmhSeD$mRKN"L!KCYJE$$SRFjG,"Z!+@3"!%!!$`!J,5Ka+Qh@5'%!!#
+iJJ!"$Xd!!!%`!!a)XJ!%(XF!!$*4!*!%$`"8Bfa6D'9XE(-Zci!!!%#b68e3FN0
+A588"!2q3"!#3#S"`!*!'3X(9(r(GKeJVd0rI0G5c(rZ&qH)39'X#pD,Sp#64@B"
+*bj!!1bA*X!$h45M4#Upl&elcXXe$8r50`$F,#8T0bhNTqfT0rL[CBY+KBXcEc!,
+Z`4$@J)cf`Fje)0&(kI#)6XYRq%PhJXF2j4diff0bZ"TT)VeBVc3(V!p"+2m[*kT
+(G0P8pM`XcRGR`KC,+Bp,F1#DET4jDY#QFi'(bYf6*$IA8H39Ga!d,3a(#4KF2*+
+C0j@d#IYb#M1b`Sh'1'e8lfM'f,%#,b&BmLbhU6Mf6M6)lJrZiH[l'Tf$QV-elZE
+i@TVM0@N35!T6cLPR+3#Qc-i)b%ISaffjhM("ZCYC#SFA!YN0f!+H#E*@rp@FQGK
+mka`bQV0-b6`GK0#hed13!1F8I`Y4p6&m!*hZ4Ia9d&04CQQ1`Rjr)PKS956c8,T
+a`2#ZTP4NaAF'@XHCF2I#IE)%MYYam9a(#HSX02'%lpj#$q+YMAU[3Y"0ZENldLK
+&5NDa+6$lQf#MP1Ipqd#$%Ie"*"`)1NP&c%6$Tep'`Lk`J5f1+DN1j3kGi3kjFHk
+5*bSccReA`5VfdmU%UcMp+5E6,mMd,l6U'E(P%#r5SlSSm,H0qJ*&DGMNqRXS4I1
+)#Mr9cR"lYfl4ZTiDX#9q6flM$IRLJCl"`P$4l!RLIYNjGCN[rLL1fkcf`EelDC*
+"PEVhM'2T*2%3E-0Ec3m61,T)!J*rr6@Kb8Ur94Ycr(&DX#)cemR[([)@-P`+3XT
+'9IHIEFKKcL%VlAhP+jq!4,k,$9dA8ihdZ"AjGB33[YK*aAjiqTT590NCR`TDR58
+qH8R[c)5NJmC'eBBSV4DY&hNCj*!!4BijPPl4mIFYcj,G[BlU4jilZ'FNN8SkmcK
+KMjkJ#5kiGkeijh8,b,q2h[Lh0UbUA9D3!$*iD'3#jhV(2)`qqbHYDmRreC6c3Xe
+KPJI"cL9+XF4VSeDRk0P%C+5XV!26a!#fm&49QkZ"V'm#&ZY&SITUXGhQCFUNf[h
+-m+BJRE+eI-9DM0IpY,c(EE(+JedXl2,+@8*N#V+NAf4YPHLdZ*)f8$LDJe13!&b
+T@8F1'dmmiSfFB!Ue"QRp6kI@-a0[EcJJLke(j`I9d(Y1M9EM(A4X&Ej2FbZML(K
+CV(j@"HEa*iKC)e6f[Gp4JFprT!aL[3Re-$Q#0MSQd'Z$$Nk-6$J@[b(0d,Gari6
+FVdP&8eA%Zkr%rf@(VcbPkYRKGaZfMFGDDI@+GTKfSJf!SldiNS(VYQU@ABXJMP3
+61V[bF$9mdRAQ6@B@[rS98G"`1DddBj!!hZ%e+hq6M&-I@S918Vdp[LFGf#i+2ST
+&SLp+3&,G9JhLDqiDlarUI#mbCJC$c5DYFGd[Cqmkh)@Gmmql(ha65-b!kNH!#ZN
+P!'p,J+(*,UF5fBN2M9i1R$ArU[B0IC)PRQ`@*c@ZP&B1EHAJVAV"h,bZiCke*F+
+)!MGBHlr0iIFd,D&6S(,lL`lpfN6Nre%!&Z'-p1qMEEX8JHYm+IF$2h&ZPk`U8F#
+SN@jSH3(KMm#"1+)5AS'!8bZLXJ*D$9VB[")A1CiEZp0V$c#L2S%!4'El`HUqX%a
+PdC9IS2)5iU"9C4lC0bFp+!JLBCRcdj)A5@TJqb2qfN[RdHJXZ)-T8FP[&S5ekm2
+QZp#PI[TdjN"US@@XBQZ&P-f8[$q@G@-UH-iaU[&iJhcYR@A%T80A)SGY93Q#C+3
+Q8hJZ$YDAL%4,Tm8`GBr`X(-Z3-ZB(Cp-SSX-c-T'I@dUI@NhlX(qSXb#08r$HTp
+IQ"IS$lYQ@0Q0r0%[bRNm+pR%[$mmDq3#@2rX(Z`09jEUV#fAX5Ej,-j0%lNhr'`
+-HSKi%N'5c6F5c24cjP4e-$'X&@'N#F0k8`-X[0lM2-hDL'3@3MqF**j&emF,J$V
+D[!#,#MriKb,D!ElY%UNHZkMJS,qkGeX)`AVk3bLTlPbU90mF5%%d)($mBCD(ihS
+@[YaPBcQ91h+'V3X,AXB2"#[FQHIZ-T@''H+aBUp*-+8rHP2JUD4-MP6J"mE*Ij4
+)Aj`+T-dl4NQNHmRh)BZl[D)FQ@"(F5-IHGdQ0b+F,5fX1UD@a#(CfhDlJlcrpVh
+T8LMSfpl#JVl)*p!6'0bkN!#+li8Iqq(%PB[NfHH)M(K3`pa'P5bk'BD$I#,lp!@
+5+FQ"Y#J-lP%%+PBa''hR@iE3-E2F'mq-FbmB0liUhF4"j3[UXj0b5%1jJ-3$mCP
+(hG99NaJE2U+NYbjVMA40V+BBUq8eI(cTA$DZJI-DPYp$5Z(fc5qrr5KP#,pAYZZ
+lV0GZJ@iBa[pkGB0NST@[YP3P)!h$IlHd(LE`Iqj$9rQhXM!'f158*3rrYSmKeFD
+GIqH$fX%IRjjeSQFEeaq0ac2H"fC!b)CSikCY9lY91JB@eqIS@Fh4M$5E`05q%48
+QHCZ'9GJqE'*'15m)-TQ1Zhr'A9ch14S[bC3NID0&#r2+B!hF[f%a5C(,fVV,"iH
+SbC%PG%2K$#1mbPR`A8DN[1lTrlf"RSVX*f9&41K4EQl#$B[1Q*U(J(-B1%6!KUf
+QH(mHa5R5EUZ'**,35cH[SM*`)i0(K"b',,`&rAdXQ`ja!0MHVJ$G#F#@%hA5EQ9
+#8%%h!rVN0F)LIA6Lr1C@(QCkAeEUJ@E59MAhrckb6j6VI1k*3iL,!hFIDI8dHAE
+Jea(#!+EY8E`r!eNLF,eIKEXeX),YX%U&bQdqJZ(-F)$QmC+l0U@jF[Y1KAGYEk`
+G8eCmkN'd(I[KpVdaA,I6B0k(hRhP2HIYMVGT4-rifRKeUB8Y)hX%#[er59`D,q&
+N5$D*CM!8$GUSpKhEX@'Y-GT'd@DcijbpbGd!eCFH,8krK`lL-RY)95m#+(efM[8
+mamGiVGQGI5-c#,M!M42CZr9lY`b,Fp16p#X)S%#`K"0*P4c[iZUi@lQq'!2Pl#f
+19FKZr-E+[5HcF#[cS5*m1HiJIHQA3Q'HC$FPj)93Xi`R"`"C6F2eA0@"JT1e85h
+dI-*"j8kZm'5,MT&6$+bc6[cHa36M&%%+%cVEN!$+2G$kSb2pR"5KCB[[GV4@l11
+N8Pra-DYr(UPZ3+69C&+KrI2ael0MefV3!iQ,VTaJ-e+P)Y1iD`cE!`Y"Ck8Q)Ij
+`+(C#h[BZ%"D23NUC',F,i!%4U@6PdVmV%jdCUaM8B`RU66BX`Y-`5"15d1%mb1A
+H"Z2Sj'16-FcfbJEpU[HZpbI&`Z3RN!#`+$LFFZ0)4iI*B`mQF0@Q)J2hVeQhH(%
+i",PqR)%"CE846[@F3'J2"T!!C95Ii"4ZNe,-aJ3aG',r+DPJh-#kaKEj[4-r89E
+E"1d3G84a#dENhh-Gi(GBi(DCV83ie"!(4GiCf2L6Zmhr$l9'+l(J5)6K4miNX85
+VA,KKmf2cErPCFI6A!mJ"2ee5#,HVCBjY9IFJKf$BiQ[HiEU2R-er`aRf$+31&S$
+Ya,Xi"d#i(f-kYaE)cdZrHeh(h@I8mAVEbEZq+&r!r%ARK8'2(-!TATI9r$C6iN(
+5Za5PL5b[Lc@L88*K8eNYBEi&I`24R%H%MS+I-BU))TKFpTjepG"B`LlS52El2U%
+RI9fRh`26PUMPqDcK8%rhKk-!1SrPVHmdRPHCS$#0j6#B6YFh+KP931LZX+)'BFd
+L49`SJ*I`r-%k,[FiNE3GZ&9iU(9XJ!)f@!SR@XbQ`9DCL'3XCYm5m!a*2KRP9k+
+aNR*Q+G6(XV8K*l9KA!0kL@MYr#6Tc+b)V'r%'CVe#Z[ar,rUX0p()JS8'T)-FD0
+PAYZS'@h1)LL"FV'@b)j%PrbbD3&dpVC@UJfXrAdaH*r3RAdq-qI8ch3m$*Uci8$
++,I1E!&5f$VZN1!ME-IC'Y8KeTKdJ8aN,2$N2m+c&FVM,bNmhITmqc9IdXYef(S-
+%I#$e&@)X"-5L[r%RF'qba%)K)Xc@P31ifT`AUA%rRf&LS'9C%`Z`QfTRJk%cP(L
+XpNBVUI%GKjYHPSCA$P'!iF!QQ"CE!a"Kb4Gdf9@PEF2XH%QjZi@[U"G"[+CLbTC
+2pC'&-3i@!)AcB5UNQY!)$2X8VJEkSNE%ZB5I&U*,AhY$PVMV2%8i0d3k2i#PTF#
+(Sk4GXGHY[*A@AdKe2E-68YJaD*&10)G@L9,*jH!(f&*&iXVcIj(R'T8P#&Aad&V
+F(jcY8`E2+-8FVr0b8YPh`m4`c&FM4)@q,jemlq00k&!DQ9&EpYaE#E#0,[2`%Z&
+0*G43MLMqNNX0%bYl8P`("DB48YfGG@8SMr)S*IPN%rC+MAD)$65DNDPBcmr+R(2
+V0cf,6Rce$H)J1j!!PBF$mkVblA(@U&V9*CUEL+PD-L0p%'D5H+QD"JL$H@laIU(
+mF"XeJhMY2-JjaAr)l0#MJcMJZP)4lIiMr"KqpFPTCC!!A()DYrrf1,1bQc'YG'Y
+q*fJp5[K4)q%B014PfiPk4iX`*hVjQ(V[)M[kFPR4l&@CjLY#%`Y"*jNpKS")[bb
+C1TNbP`%TRXK!Z%RjGE[F"iNADi1`X2S`U$`HP&6lM+Fif!Ae@YCZjT'-hd580QE
+`EZbLJ"KG54H+L6-q)V"#i&p3)i"%+S,+[2$U!EF'$UBC)'1V4RXch#r1SjbNEET
+QD%amC8B"#iDBS1+U$095BRANa)C&-U41kU6UQJ6l4fib(!a#-*HVLGFkiPqEJCT
+`LfT0l!fNf3ZKT4JY2*FRah3e0X1YUJNQ`d+TaBNVA8SS#(ra1frB+i-9@lE%pX[
+F[R"*ra)35(imh+aSY$J+#AKCZUiRahCp`lm`&[XKUKQ&`H,m1hFB`jiDE16q[83
+0GCpf&,@A[a'04"60JIF&KB(Z(Q!A,CdV3,!Lc'Hj+XKbCSjBIBKZ2fcq%Kqb+8X
+IJVL*P'Y#9ISZJk6ASiDL+i(&)d@0iXBL%J'GNdJKIcU(qXPFR"mLkElk)c-R+K6
+1aYpla*eML6YXd`2N#BQa+$pZkH8,j%M$eDKGq)GD3!Rer9H,0i$+42DC`'L#jX8
+IQXf)1,EX@%RIq&cVV4B+&YXAFQF5k8G)Fc#TqeNm-3GY-k1pfG+$2Pabe`jr+("
+,c#ZHf[NSkIM5fq3#("9bf+@1bN@I*ME'FKJep`c2XPPJ#lA`AL%S2S0CU&8dL+6
+N5dC'9&H'%XXQCHD5a9IN*kP8acArm%kZrGPm%V@5MjE3Yp4pjl89NL&&DT!!bU3
+ADY1[A-e`L)iqIkbV+NZ3!-`KLFK2@*9!VKUUX+9aK(SeSiNF8"R!#kZbVTC%iqX
+KLpM&`0SH%(E0c[8+iIM9b0eDTNI",@+e5`+@cLYl0[P!kGF&Yh`HR$pVjRb4#[A
+ab"aLLXbCqTY4)*Mak3UMRFIiVL'jJTQ1#h1D3%S%bEfMP3EDjjRBQ[l@FeH3!$9
+QDEAYZ%`3"$Q*6YK)CI#+Cd)H(N6Ka"1dM(Yr"0PC424%*Qc+h,NZ"MMhGQ9V"D@
+4!r&(rD@GY@q#VVZAEY6KJp61XDh4mbNXF0(M(9PpH$-2`)CRS@,@+k&1T*ej*8K
+pkA16J#r[J-J[)&Y&K@-hcK)@X#)0HJ5f+(aB,ZmNY[AS!6pedJhVG8%fQM*F0j-
+1%,N1jQKU,IEb0&Xr`eVeY@5l"Z@U*0q6+DSD6eLG3"'!eBBPM9d@GB93*D8c&hX
+*Yifm[XCXGJHPe#9l`hZHr4p1*NlEABLq5M3ph)SlG%8E5f0Li##[,f&SUUBZa#Z
+,*f8&ajU(f(e3+[#(9Uqf-j!!iih,E%2)Fl0b9CLSJl"`+Sm,Y-i5ZH6MkYEkKKZ
+Z%ephme@&V",!V3+Vfrleq,DB,1U%M4*kc2!j`BFqANiFfTNdEeDe6RQ)Z"b)I9`
+XI&&F[fKU4ZIZT3$aLeGjc!erA'%4dJ%I*6#m`kZd!B$M"G)@$q1eJ#RU"phe2(Y
+DAUS)D'-HH#&5#l)*2@!aN6'AHMX)lkBI)e5X&qJ(qKS@1mYf0YIZ4l$`Q!3fP%p
+hNKr5(!d'FqFl2RIT%f("rE&)"&ReH(pI0E3S$)82TYJRQ9(Y1++FN`2HG6DMTm8
+qI"#NLf5)"YHR!!c6ZKb!-Y`NKe"UbG$&'e$K'RIKV"HkQ4jV`!TNQb[lIDSL,MB
+F[8'Fka+kG,0"XEiZ$hq`Kf#!ZpY+d@G6#mr$9(P9CKA,"6Fp%eL4m*)iA46Mq['
+Ti39QCKL8!JCA8AfUSX5pFl&dX"iYf#l5%d+rklHpja9QZ8iH0HFhk#p8'P(NqcZ
+PhC9h`L)Tq3ba5DqX30B))(SBTQ84[qbr5i2d6,F,&JX$jXfS5QYhprDAFP%L699
+LjJ[9(MJ"Q4ZH[C`@GDd4V&0K-`"XDlE,#54e#1--Q31PGjkcABc!*906VqX0V6#
+C#-c[PMD&5SDEJLQcS`,i61X4KMj#rjrm9NlS+"28XI"3SQ6'Xb""jrN-q#C,m4G
+)F9$G+0QPMe-P@`[`Q`YhKBJV"6*$MM"Fkkm34RCFhbj*qr#G'(ZZ[ck6cXLb3)2
+2FVAS$jZID2&3a',dDRGd9+,1jXj!$Pre9jaX1)E0hcJh!Ea8L$kf%2AibjKSYUd
+0h8NF0XXr,HQJJUeEBYGHYT(f!UB8!5faZUV0-418G6ekF*5X5aGXlkDA8-SYV96
+1)cF*B[@aIrb0c#3pc6%$lRC&p#ALSJG`8fH5aITjaY&Db%*Y8Q4+lrVHTF`e+mG
+J3eJ!%Rm&08&Z%"idD(Kb(c[d!GF)%e)Ifi[P)0rcArF%-UG-'PXc9U5(-M'J`EK
+4CqN9F0XVH%kd)*c1)lh!8lhqcC6J+TR(5Vi[rDGk5$`DTQZ4QclL9f1HS,RK`5-
+C#$MND2DY@DK+9IXDGPDq64fk+L5r$jc(K)3%-Ka8&R#p#AX9&irbDRM5)!&`XK!
+U@Ne-dd1MAB('8+$(QcV!bpFL"+DUb+hf2Fa,)dCI$XF)&kb`lS2jh3JL3%Z4(lp
+cI)IDUCpAV@!$1!G(YQQA8%58,C!!)2eV"!4dYV0FQq%UVU,h*$lLC-G-83rJV8K
+l-jBBf%Gp$E"P2RZJdq!ic0I+K"Z4aceXh&UR3SEkQPCc1GCjCQ2!"iX1,f0H!Hf
+&C1ZI&e-*VYNVCaq,3(YUGA+CBaVMjE0[kIaN10*'13BeLY0*9NMABMB2UITf(AE
+3+P&Vmr!Ipp1#RH6C[6bX23)[fl'MBqi8F1TSj@JQFhAYKlBE2ZJ0AXelCi9TelK
+6+G`q0IJM-ZRMhCUX!FJm0C**KQb680ZH"Nq)Ji[aKU*`T(6#l@SSTJq%+ki[6d9
+M[Uf4DidRlLLZ69[["3diQ*hZ-fq,l&9M%2iPk&&JUjkCB`iEYjbe*l#H0b['Zj@
+#5Me)DE68`k0D4BiLR5rhIijA2MMYKEhM#PlQ3Sd3JkMK3""j-S0&)41`&!Aj1pi
+HQM9"ckR&IXiLXREUGCQ@)5e$XRbHYPeJlM##T"04Kf+)KBQa-iU6&,SKV'jc4QU
+!6+"EAciXJ"jeE2V&4Sc4qMZ2"G(ijhT*EbGQ&T!!)*0eGG%6qFY(R#EPcrAfpfU
+U,3U-ee$edL9)YVrlTc$5jpm)SEldkIaV[-a6iXq6!dLMl%NCeK4Hf94ZA,CN@VY
+CE3mAqe1b@lG@PNV,1RCQB8eMF4,*B`"F5*qh$A23MM%6'2j8Sd`V6LFhR2%+@pp
+A1Q*APbLI-rc,[fhcLk9'leU1Eja1djNqTp4b15aGF`2&LS9D`UXUEIKYj9XM"D-
+blrSUj29R!JaCkZRUVJa,lD[)@-eE(,SDTaHBPFNmBe&)ma'GPlKG2IK,48X6SfP
+G"I+CShM!(HJR@VDErULca0-6Ae4N5SAP[j)0%Yb5dAVPld-eDCZ[JkaEQfF"425
+!0q-d2-!k,qAI41r#eJGJBd`GHie`%epJ(UdD)(jUqe&XE[@DiYMk5R!AiUYLZP&
+jE&CTVI9b`$N+SF6h8amQG3#m4i3k'[TU%pK6+,0j5bJU(Z[LAI0r"b#Jk*iG+1H
+YA9'H5KKB$#SSPU`jdDEM"'Q"r5SQjX@[)G+DlGl"1rP5Njpj4Td#k4T%m(!L4@M
+0Tpe3Sl&f+SSeP%[2!C,d)!XH!@(ZeI%ZfVYfDG0M)SekrXVD@J`e#cm#5HG`@4d
+p1&Q4fqi11GVAr5X[HP0bdU$!5E#a#BdfLXlkZ1SV"q8'I'6qjD3JZI,LlPbHP5N
+rX@C2*H4)+lKE3M[%rDC2GpZY6f`fYU#8a-b'pN%$al"d+9$LeTHbX)d0(djPVl+
+EEbK@B(a!$PedGf35iQm[MhBqG+iUdLThLR#IHU#R`SPENkSU0D@V$KbPPp@jV+H
+I9pfMj6edd9r4$#'N6J3dRRC&ij`dUmXN&6T)p1H()lMY#UJkD6J"6[T@CXXBccL
+l$BQCcXCapCSCQQmKcfIDB@,FdmFN2q9$@%HPFMI-qSCa80k&(ML42813!$G@&1J
+%aAdfcBIMQ5,8i#a"&BadB0%&UVKM%8*lpAapP)+eN9(Z1@%2fM8PJLATp9Bp`1Y
+d#`DR[,N-*T,`0J)dmqiJ6H8JBeJIM!k@CSMqRN%h2&`BX%J*a2lSVE(bb8%,"p-
+UDY!P-5EcQi3Hj3fMF*%DR2B"h#-2p1MH"qQEFC!!9%Icj'F3(S$,"I(qCFfD5V5
+Xb(hM)LeRTaa1jqr[HR2'TrCVP@,kN!$!@f'8(BC)r40d`ZFHqE5qbfbXCe,R6-4
+F*rJ2a&KSiGl-"%9q1k"J6@5L`RAb-3Fhi`GUiIa`TJ'JAPb9B#E5Ni%D-RKX'`T
+([2)amID2Hlc`4fq4a!PkmA&SjI*l!ipP(iIMN8,&eQb[b-rFIcEUC,M$U&,jV[q
+RS1ScZD3T2+6HCfSkR#KX-aKjH5N*-M"q#5'P&hRHH9NaSh*ImlYMr,mjF2Nc+`@
+P*X1D!Qc)59EbYm*#-&,Sd8JP$fa@1LK[q585Q!N[%4mc%AG'ELQ)@h4"`J9Pd0"
+1&P6rC+Gl*Nd'RH42066iH+ET,p3j9#2N)[T0[qB1Jl0QMXi3VS'2XhQCKf[F9ar
+pB8M9ZN0a*#kZh$,&p4eq68U#hkd(m#Y*KL@VTJp[!aQ3!&ahL`S+qB"#Qj5em%3
+d8'p+V'hV[6%$i24+&9$DbM-XdPe26r-)rU*I9`mkUBGr*k10$H$mVEaBR%kVKcp
+2T34f)2KX'IY([@S,+5EDDC+)dYiaFJFC1NR0-8ekqIN2,`LmZ1Y``b+m@NeGbF4
+VLr"(E$ScUR241-,8iq8V,HrSXjCN@hJ[r*r,1[liei8"eI#&VAJ1($QM-($,6`V
+m56SbI0F@4SkL!XGM-)$cfC)`QVTYdbYapS)hl%$LEbXE,BUq[1'Kc*dX&rcP'85
+-b"@CD6+ifHZJXU%LQYJ@e3qCcfT(dTXS'N-SY[Z$Y,CGNiR@emPTZTJiJP5rr*p
+j#Y%06HijFYrZ((N4X[CZY0Er5N&4#1Ur%DcX&9IpMqTC@`[I(#G396)PFG+I8j*
+biI$$qcTZQ4*aP8K'h10J)9YTaQApKLRR49!$c@%VpKSNfMHVjG'[j)Q!d@*%PaG
+B#db5URPiDTbA0,lNDAAP6XjK%,`a2DIhl,U0TL-%HE4SV16#ql5bV9+r*rX!qE#
+(m@Q[dL&r`pc8m2h*+A-C($V'Imb$j0I#U0-V46+*5r1Vj%N"!SG-H`[3Dj0j8SJ
+GT1rJrLm6h2)TG5X-6#)BU6@1RIZ9QUIVd#)`BYTXN!"lcr0B3l&KZ@Q%,hI$beE
+lCIr6Q*0d%2`BN5L99D('10`SbR)k2A``Bb$jPmrS(ZU))$MNIPU&BGBV-bERCaX
+3[KY(P3dJqRP6fej`K8%q9'1fQD#Gf"@Sk'k%+8aci'aLGYrF`L&pe$cTiES&R[V
+Y9,cLa5p42HPYFfcdZ1J*IU"6"h2-LLB4ibIlLM-+jbh`'"mRc4aTc*JQhm,a-jZ
+kPi-#QRp!CaQEih!eqKTDLJKlKLBam`8V6)`cHjYjB2!pHUV(RqV&"r2'Al1Gh([
+5hU%BRP$m,IU8DEP1!bL*R[5S@Y$Lb!eP#!MHj0UjkRH(-$,1Glk*))$2GqjBkeV
+eUDr`+iIPaKr(G6p2,lYJ6*%"i!pbkQ5E+a!3!`Q%I8dDf!&i8(VblV8c*AIZl&P
+BL-'!-iaRl"YCLAP6"eYP2Z3rY19"lp[$h,rqR*ZY&GI@8P3k)A0$D%9UX9Tq309
+TZ%IK2['0P--j1bD`MjFM@cbDJhD$*X*6q$f'`L"'"+0N#`4C(X-M$mp[BZE,HAP
+6#!(h9NShIT[Jdb5HVb4qQT)KMN*9AFBZpA0+AFT5PRHfZ"-C38)RF8T,IGCqA1L
+PAGkI0!Dk,eNE$UqPU&kERp!2jhX+8(L'cQ[NC1lk@,Q-(LL,bih%8YD!*8*LP*8
+mh[5"ic+Y@3BC@!D0`@5j[[0pPQrARETV%qp'R0II(P#cS$T0FY,N[mV2jH'b363
+GU2ZEH*hmE3&QM4C+qmCX#2R[dd[9[9pGmNHARJa$9)R(rdHUqX*%epFrQBEl6Z8
+E%h*dc*ANML,efcc*a"5jicR$"4S&pl)ledh),jQ4G#&qpYCUlB40+4'&$Ddi!+S
+-I@'k#C[j9#F!I4J8*elSFF'0MIAF"0++"T%U9RfCU"U*kDEd0@-G3[$FrE+A[2P
+Ql"IAAjq*a)B8LC1R#De$30,AjJa*A$m`8[b("$Vr9j!!h(j-4X"Z6j'*"@#dJ"9
+)AR(cRfTe@1cBG@m6Ai8B5'pCi,D6HdcdpJ+$iLaHTrT'J%2l"cdcDH"`QV#U'p+
+m88$NU043+F#6"lC(+Q8hiYi!K5C)P%%[%6ppehJ%e8LYR@NGp*@P,%-,`1HSZPc
+(&*+6YJ!'Hf`@R`c[R1N)XTK4hB%@mSJJ`LKZ0Tf+6l'5YhSFC&*)Ibec[CLKY*U
+VZI9ea8lPG0P"4Rbd!*bX0*IM1`9!Y2$UPqSNX"Ur`(GXf1Q,`IPrlND06HTMkD*
+DBDQ%5L$RlC'QLZDlTTTrAQedXV@%fDRQ'0cT2V3NL'hrUQ*0QJYl[q0()pG0-H2
+,21i#506El-4KVTP[Mf"aURGkZcDSqlVF-,XEj5VpN!$TU)mfM'G%qUZSkVa4Xcf
+MaFN',)9ZUJB'$JNmCG69HC*GXfdLH%'ZaCNeBmd`m-HZeSL8mSSApb"i"[h56jG
+,j9JS-HKk@BIZip(jXF,RV)dZYp6JDJab&YV5)HSJJ!Pq#h2N$2M5%!+Dhjp6e`(
+'hrK4iDIS*Kr`6R,Je&SX1LY)$[*0TLrB5fhS36"VM#Q&-MMK5YBbk'eLNXh3E"$
+6qP,QV4ilV8R0U[lc,$LaE&d@"F'l8Ci"5cAHSqQNMEA,+8[mch[hD-X3km9DU@X
+D6+KHECr,8FQhPT!!ArkeRBh%q"AiF32qH5(VYpIUA011%@T-@CXefaAQc"ZpC$c
+ac[EY(#-d-f,,QX22Pf"Iikha`F5@ThRd200VA+5cSMhKU%9$rMp%qMY3S2a*R5k
+am*-f*V@E08U&-+$UdiDbbBl2N!$2*[-8#V*iBXkE46Kl(3*m*0S3&Z68-3Hm5`i
+8JcPfehQQar#HGD$e@q!cirlTqH6&G5M3BkqrLcd`erB3"$F@G"dZF1QVq[@Vi5U
+U&JTDT*!!-GpmCflG94U0S6$q6DfmI0&CJ)+NcTmi2hkb1mYr"XJ*G%!-BICP$db
+6dGBSf'beEYA0m-0@@UBrmm&$"ik%'4TGdd&NBj[aJQLBLXlEIr0k4Nj+N9iMEfN
+QJf0K,XLI"21PC()M2,#pJmI)D-L%,Ti,qfVXi80[XLSB@k9e$PNBj5R*8K%S[k`
+0fAGMVH#-E'LINSQ#2c(q32ZJ&*E*KFd0K)K(TD@eaPCk#e10P9i#[XM)9XHP@GM
+e9PA&#-*M2IQjS%p3Z1B'@1P$ia-HIH&Eh6[aI9SGIfT!`BXlpUrUL'aH*)JiG-9
+H($`!3Q1T(`(e!cMU#5ec6%)!a5b%l9qrE@D!q-50-+LR,a18amcBDa+@`epQmE0
+Zdpi@NNVhT4T"b,@E'G*k62',@G!,*+bcl19`kD@0(GD+1c6AH0F`+5%BVFCe5&T
+kBA*EjFR[j"FRPr4V$MQZiXIYK%AM-6BKi&6TieZ4ckGP19Ra`@lY'FhI'Y)-`ai
+6qrr(`E8H,8bebG9RLNRB,Gi3h4Ebial,3L058bDAIXXXkV*Q69IIQ6lIJ[I2139
+A`-I)#)"A@ZUUIX&S12*2A!8NUpa"q0T!-a`%Ed3Q`%iRB)09((b[86rHiE30N!$
+c`L"IGef#h!kB5TQdA6QFpQhkcb0AKMAV1GFlUC+USFUqH2CYNal,(aK35MjId)I
+kA1jkJ2E*FI9ZcbIU2QKQRi9-EIUP%10VUkchHSG@qB@PZ!8eR8CXS3M2b"`KJZ+
+3!1HfEk-MV-9b1'$@ZN0b4fd(HXPjQ(lRjr)U@hFFX03UkD`0eq[kQ@AEEk2aA+@
+eh&&4F!P3RB8-4'26TRmIBmiPhJUHLMq,laqe52El43h+q4TSA2MSLP'qacFKKBq
+rBG#i&R3$HK305I'22U`)eBDCB8M%kbZb`,'1Vaa[p%9KP-5cRP#km6%mNRRZJh[
+flr#$$!&Xc!,i#QRB)d2d!RF`5hRD+ddYfjPrL2ARYm9iGl6cZ$YR4iG6c-R9dI)
+%M4X'$8YBP-mRX9Lh#$(BF'MP-r,"F#DAJPp%#"iKEMjF!ck8*rU4M#ElBkH96Fh
+E8ZH46d+qBDRT#l-AU9fZ9`-6BZVRMZQ8Qk2lYM&HLN6dp!C"dVUMN!!QNFXfd+B
+%mrc#PE@Tc8CcN41hj0S+9`[0E%mf9f+5p4DVT+-p[Sa6#ZaNE233(&N#"*R`0'G
+Hik*5A2Imblk@rNXY0"j8VX'f5T,Zl10%l"S6#qPD('a#*(1C"QL+q#aa(#3&2I1
+e2NUYF!Mmd1*#c+Q9I4ad24GS5Gc,*DKieI68mE3NN!!CF8&i!Dp&+DdA(Y'T0Na
+pXB38X[Rb@NQ3!0S#((Nd8LZ"Cr21'+2bJb%!Zlm4BTGaq(NjQQjTXf%,Li8`$BY
++JS,T'pq0KXT,f6i1LE3"jG(!H4AQ*8mPlKj9"X(5(Q"ZEqpcPP(mGMEqdjZBc3e
+R0J"%qhKQI[m9JbX$@LH)&-9P"A6)!69!eH29f(ak&jbl%0-ASq(5SlK)aJ5A)2`
+AXP2m6BR%6Y&B8-[c0!R,r$!KUQ'XPR-H56cj'eEmUP'8'K+iiEH`pqCPiX`)2h3
+a,5P+rYT6+QD!8h"0)9Lqj9*)#0"(*+,F&,1@ee%@1%Sj5fbM-EQ)6"#YA2%Mm3V
+(!Ni$CKr%krXqHP[E%ilbE4mj@C1Z)r[D98GVG$mb'"HMd@UX,LD29)dI*B#4'"&
+&Yrd5'1F#Gq@65*!!GTep5+DGU2pHeKj3#ID$0!C%8R+8XL6NIN%1EQ%Zj5AD&c"
+jKj+M96qR5[Fb+A*$)GdV-)L8q''bq5X)0NE$ZdkRE0hXhGMMU9`d8-b#i,6XMJ6
+aBQqq$Kqr#TbGQraBj[qjX'+AF)@ZcQ0GTSJbPJUk'*)jZc-cMUacj0#Sb!S%1PH
+Lr!,VlfD6Ii8P(T)TfQA*8La&Y!)V*05bZRRNLQQ!RFcVH,Bbl(4DDfPAEABpBZE
+#ih`'&3mJ9Hc#P[!(01p(hpAaPcJ),Pa*YBMC!a@JNE-,i"dm91NlM*JFTemMKLY
+@J2,rj0e$UkQNfmeF$Qr8'CYZqDGSUGP968SBZqNP2dU*FH5KqKl8Sbi0c1f[#FX
+Y9&3e(AUaIF,NAVk(AANbcla)RaA4c$hkDKVNr[CmJ3C,1IUffSFkeQR0AkNQLm@
+Ua[PLZ"5c"$(BeTba5Z)$`AlcF35YA+,RIE"0Tf%aQL'G5Kp0#-SZq3XjQpYKqrU
+Z'"22-MIUZAiDIJVG&S%6k`A$Y"AMXDXIVH1&e)K)1(V3L'IZIDXr8f5E"1EQIF,
+j8*V"NR+lP)eZS,mF@`V9Em"C'mA6UIr!5q""CjAIAUTD+MG8T9-Vq4TB@h3G6%5
++h"@1rFa(4Sh4d%FDIML)5CNC-Q4*GAf1jZAB)2!YDH%Z$@"GHcI&@H)UL%XDhq)
+DLLIQHMQ48p3LB*E`1iII6q9XSM)P1f',9+F%'#!YqX'R$NbY0!Y,`RA+PKXZHUC
+VJ#6K'PUJKb3"1bPBR*p%mmk4EYR,fb-UEBr19Ibk1Yr2akNAp9SF39e3UZ0$mLF
+22rr13m`4f%NK11T4Y2lCfJB4RPPD1fPI2eq-KL0@X4!,B!B-EdMR!HM13MNXqcM
+QZqi*VTc5L,GVL@G9Q+CVH&)UPZ)Ce6'rYZCHc,pI('a&&p0lQbq!6P4`'jmYM69
+)hjpSLj!!mZU3!%ehhppUG%*-0rK'Ur+cP'Bj8b"LYIM@Ur0fVTJ@AXXhr*aiSB0
+1I2`jABm-HI"&lRr9j,Ybr1Q$NXU`4Mq8aeFP*!8lkKKKT!0)2TqUji2JcLeNp`N
+)mH!DQ#4ha,2d$"ZNi&qL'c[NS-Z6m5iljR,lQKG9)0eckbeMlJS0I0jk(fZjYU*
+8b[&jHN4`SGHbiTA)6"Va%$9eACU-rNl"mHRiG)&pT!9&q"3V&1[ed21e4VVBfJ(
+#da0MPYIPr'PIB,p@$SEcHj&-DKK",N5F2hZ5Zck#RVlP2dTAA'rd#['!Sp(mEDj
+i2VYcLrh5M*F*8k9NZeSY8`f%CK)@&23B1-QPlqfJ'!eQ`UCEf%MPC"a-`Zr40Ua
+2Q$@Li9-'TERGjcQ)hAiTPbA'P--j,fDlZ5Vf)Kq#r8mhXcbrmZMrA-UkDjf'T3f
+%i+X&DchhkaYa5[Y2r%''J)5C"`di'5K-9ZP)AULV[a-l+[4YV,)FJbL4r2R6FlH
+ZXB48!B"kGe9Pf,2C%0f&)Il8-KD!1rp`j[XGF4@)6@2c[KN$%p2,EpZ1aFc8P[U
+Rd(Q"ah!4d"5XDN'"5X0lkQ[@3Z1L6l6d16$6l5+hpU+%8+fcIr$2d%XbAA2l*!L
+Y20b,j#F*Y-QIS*2D&@lcRIA&M%RMcJS9QR*1j1R3KP*ICpVB$bd#X+Mj5%UGVH6
+%C9D&4M*'Y"Dpami+-6dkcb&q@m&m6#G*dHXm"jmN5BlbRXJIcQr8i6Vd"F0ALjd
+rhH6F5a!DD"q`biRb%[GFlPRJ4(H%@kZZ"fhlrQGZSk9Il#krXF#KLRZeXac`0Vp
+Jk'QI-AS)E,aj(Uf#26R3$NNFl*ZFe0kNElF+)jeZ-rBdLA$fKA2h*UL62)-ARMm
+(`LL#IZ1`Z*TpQ2IaiFMkN!#$[9kABhY,RD)A+JNRQi8`A98p9iNL5f4!,,h4-4'
+r8dcTM-I8ScB9U-m%6C[A"L(D6!EQ+(5`)k9d+r*h[GiqD5CX"KaAIXL[%2!Kr$!
+kc52EKr$#9(l,NdI@P%8(p8X59bNC,2f0B$EZf!)Y!CH,bRc$0iGD+P9@0h-RF84
+*aaMC,35rD0-af)DTA9hZ,HhY"EC+RdBei`+M2ZjP)c+qUG6bLaZ$6+ZT'[6j$F8
+V-NiK$CA*6fVGeLqkHEC@JIC36A`cNqL+&8'N3dKQ`h'MQPB'*P",GXA(VX($Mb9
+aGP1`J$r2rUH58QkeN!"I"#)T#KIPBdDGjPmJFkJ-QAI583`eBMUkdl1!M,8QEh5
+KD,@QMq'HNS&9+1)cRRCj("dlZ@bM,bk8)TLT&+KA4)YLC)0Z3k$KU"F"0RQGl[X
+jcjMqB(pP3qH1MIf6ZjbP8!$JbT+qIpaN*)2H0d&[D!HKR+JSUZ8Yrh&)1@N#q5f
+aYV'SpE-MEDfk8CI+E-b0-k2iQ15afA`884+49(pS6A!Hm+q6!d9`QXBN"Uc1H(,
+ARCmF8*P!$cm(lK$lG8HILL%'-JpZ#`J9cpdF1C*HXerSGRXB*`PLLD[F8YX&0aG
+R$Vpm+Fic,VlUr3Yd9TY2Xf0*jYQFUTM)5V88kHr8Z&ipciSh1[)S'ihH5+$UmrV
+H5@C`P(S$-a3SY,a#DVT'5q$CJ,,Z!fK9[`2Dj8pIf6!9I5Pc!!H%T`DI'k*mE#I
+Jl(*LDDaBK3KC*cN#9@#l,+F&1I#!b#k5MF"MKjdlcf2SXa&UG*M@XX@PQ!&qR[+
+TADfDK6T!`%-%phZHf5L@[6m#Rb!YQT`A#!A5Q`L08aMBT(09dGSQ[QE&jr24Zhp
+Nr)&h3rP[&qGi)80bdq")5*6T3qk0pkDqYYVQl9'hFi![4I-l&Q+9cpM3KkSh8"%
+hrd@XBd1CddAr&hB2J*Dj*r)0-I&FD@b3!0&N,V8cQPCZ,cZbd0remh+Kr`-p%XV
+VGr6kV$Tb(6X`kbj`15mY$3"j+"*VV#B4*f''eE`#2bFFfr-#eb@&"N'&XP-bd34
+1&8!-J*6,02r!P5+C*bNiBJ4NqGD9iL-)ZXaMN!"TB3JG9G9U$,4@BYf1Lr'(&P)
+3-XqS!ai0YFSKT"1'C5HP'IYk6L!%a%e!rqbKX2`+!`RH-aYBi%J`c6ehpJDKAT!
+!A`R3@!JhPI3I('q2&Ld`dc#@bfVQAMpl%MFC--)b0j6THbUGU@!TF4cNB#"Cd8@
+M`fh8m8X)[5iGqYcm,SZhLPaqK-"q[qpeNaA[Gfmbmb!a!%&B(klUL()Ld9ar"mG
+E1UC&QFDE!XZ@&N6cKB@28$G93mJZp$!3Ik+KPeSL*XdF"hCC@&HVmem+%%hAD''
+&4*Flq+Lq5VSSepP(h5QYQ6"&!C3DkHmThZk[`K%IiIABqSb#GkDr)4pH6Z40'#)
+Jh#f9H1QLTYK)FA318MU''X,q[0SUHK4F1p*pKG![k(8D'ei68Q-(+kK*e04Q+pH
+eK0$$U5DQj0!`)bZZBLmU+4pf-8RpUH(m0%f5q[*hkidPG-NSek1QR%RK4M`r*Pf
+Mk)Z%bl8pSd!,AH,j8(dQLLcihDYl4pF56cP)m9R9,J[(j[[N,V@@2BZ84RGci*[
+m5IC9a586IUSTB$9kbRpACJMAQi9qN8'FHi+i!#RI5RB%9TEY['(fM+M"&-Z-)b&
+K8RTpdVebHX%`rPf+aKF,(B'lBHA(E%FpcC&De&f8U8YH[2-6jVlRIVTPELq1FS9
+4,JkR!Lr*S"1G1H52[Q*X%YhR3qi8CFCNKFhC*$)MC+aNP4B&L0f&cfPY@fMQI3J
+N!63',SBNkMf##G6eXSmZ9C8#*!D'J$%SpIIm4fAVqXFMX$1IUQ(3U[ilVBP"dFf
+Y&R9k'jF@M$!fI-GMkjk5UU6f0V13!28ZN!#`K%cK1fHcpa%c'-)N*3(*PKE%f@A
+!$e-aD[6,lqX8jB`KXGNcZ4&cN@NE,1HrVpZ0kU5HJ8ED*QlqI%p4R%$)TbcpV2)
+([)9hPD9@1Ia2$bpk&)"i44h*1X8mfTeiqclLLcRYAh%bJ#deaBE2(0r8BUdfQe4
+(VU"8*@J65-VRX4cPVi9PADfAEfY8BpZa#H+3!+@3"!%!!%!!%,JMfVZi)pUl!!$
+F(!!",&d!!!%`!"$kD3!'SDi!!"cR!*!%$`"8Bfa6D'9XE(-Zci!ZH'eX!!%h0P4
+&@&4$9dP&!3$rN!3!N!U!!*!*!6S!N!-h!*!%$`"#`G8,I9Aq#(9[MSa5YEUl5UX
+pY*Q1mZC@MAl29r$e'2J4rm[eF[LMC)4Jl&H"X@*aBC!!jGX&-%,"e0*&TEMEM'a
+Ap)XDl+*0iq00A"9P3fJ*)FB3UC!!TepBrSpBCMc#ckdj0m'"Lm60!02&ifLCTr8
+a+"T`hr)YJNiAa@28a4a"+lhPV[!FA8-p%VJCZ*+X,i2ea3QDM5aiBR,`A!!`+"T
+[R*-l,1@FSqjqr8PU`,B-fbR1'QZ-9FV6d0lI`IrS&KbhRXCrqIkVmhJBVX%GK0p
+mNAUT1jfjI-$!!pJHdTAiqd'$a`KbQ9KQ)L9dl6A-[Q6Pcc@&51F(l0kP!a8,TkY
+8YB%hBrGEJ#'KH%S@ZKFTQ[,VEIciK#P-69@fNFm0eCrVHU-d`@F-QpT9D!ZlZF%
+aMN1c@4KZmqVrTM5G'Ul'MjA[FbRL[DUV2Yp+Y$mjR-ib"#Zm-C3'&CQjF-Q9`Am
+%429Tk8mp`)Ph&N)e([fZpk%YA`Xp[ABec)&kIVciX5(&)2`V4h*ckeQFGXjqLak
+R5C!!XHL@)"6qI2-Kc'GaE'F#@A([T0q2Y1H'$2feM@@l!rFK6d[L1`BZpUYp@KB
+T10jjXIbHQRbYZM-Z1@j-(J'j#[rfQAf#4Dbj#bH3!$GG'0XcBAFaFa6Jl(M&jK4
+LI6*N"*VP2&YDb26LM[Q4$'-Va"b(fA8eQ&"+B9a!a,TrGT%3AeDNhF4#RjhfHf8
+de!"lMY$[C2-ahX1QA--49D!TN!"!@11j95Y$$@JZQArN+$,qC"@6S+APebb3!$m
+V&Y*)#XL`&'XmRb-Y[DE@!["R39LUF@-FjEYGQDA!EN'qR*HTSF8RlY-Y*bNCGUe
+)rTX939pR+"0IBAq9eL#VQcj9PL(S%(L9F03$bX`@Nj1S-Z(m-Ph#M4P*)a&`qM"
+22&4[q$8RGl$*l-qBqJ(EhcE6Ib-h,EGa(L@3!'P+(N2LcU[*!"-a9FTV8E$4N!$
+1(1P,8IS'Vh852crEYkB0)hB(ZF4Tb,SRPAi5CNe8N!"jh&!@QN+V!-"8lREclHa
+U1@mb6!@&T*5MDrL`rVPSl&#lNBYIb!9S)#9J[@L!r5$#E5h[,I[5`S2aEj*I[K[
+Ck2KcrCdH6q)#PbdZ9PlP2r+SYdKKKK6DG`L'p0'fLXV9L(RqCG"`CIj63PCUZGL
+rI0ia[caIb(Rd4TTb-)PS("1mPC[jcJEUA2*"99Z(LJ2K6k,UYHb9-BdY4+9)R6E
+C-IEdiREl1h2J6EQF!QB5jB52E&rmbXZ*FVidVY"mTKV%mYac#!E*r13!XMLhJ40
+JHmk2rd4V!kTJTEIl4X5*FiJPBS-AYYe1YH03cHF*m[FTpT(EIB1-#6X08,3b0&d
+[YKA&mlNiXDfNRd+fSlr-m+m64E(-eqK+JkBiL#d@Z&,8D"#A@&)M42qrBqR#
+ee$j2DAT%,bf)IqU-MRJ1*'0'LYY6cE(lCJA2JYP)&R*+qr"Tmc32L@hEMfJfmbG
+[Z0SJC3DHLaNSqlh!bf9EQJqU(kf1RiA%$1++F@5,S!KC@b,NXe*B*#IcSV5VCUF
+0+5dMLeH%er@-'V4CH-Tj*ak@HZ98MBZFB)3J!D)eDr5d"qpffpm)"QDd#1LJPk`
+qTYk*pi!dSI%J!B0%H6(fCZGP2Np0HicFd+G*%41XV'X5JQ@`pYNh'Q[FJ[R-Vl6
+d1K0-$MM3H958i"fle8b`AUj2G"DYceiLAr98(jRkh0BGY1G3P[r*c1emqRqFYmh
+hd3ChD#m,rM0HYE,*icdiL(SUHZa&qm!0MlDKS5ELif44GPAGfpEc[kh9k`F2p$-
+TFjBaU,D8ETkSF,hqQ$P4XEU88236KM*k*I)1am8S`24qeb[63Kld'3BB$m'DP,K
+G*-PUV!)VP%[LM&5D3,EphQS(r(UkIbPTeEqG`134R`Lc8JfmDSE,bhU*+34ZNEp
+![2@0H-a#[1%LFJVkf!J(QN,"P[XX4!`mlI2e$'R*Kej$i+9Rdhi4)kSBc+F$YVD
+95AdZL,mJa`ijS!j#)2pmL[lCIm%2QiGbMK1GIBl`lf-d[%(e8NlIaIVNG2XY9I`
+r6&9X2kEmU$k,$AJ0`-c!bIED2QYCr*CT6,5BQkl8dB8P-&lpU6lBYEhiH[[5FL2
+AhaKIMhj1DdmF&+8G1rFaHFd[M,4KK68YSHrJdf@j42``r84Nfq0k"TrH$eJk1RR
+F`6$3@a9@1eA`AhXl"U&MlJNPcelaib!!X+ZG9NkGi*LYqaq9L(rf2(YFKhDcamE
+3pd)Z&[5PYH!3T0P5E+E1S8N4kE8cMMXD4Feja#@VGNC#LK53!'Sbp[R1KXTrY*H
+(aiHj8q[FhkmCBFBCRCbGQP,EBq6IU(3dcTeh#R!1j3BMK@PMKBI$eB3H`1("B1T
+$Zq)V`GN&RjNC8@)269$ade5JTJ#c*6IhkATMT9[,Y@irJr0i2bZ0h#T02FQ42+e
+rF*!!P606R,I`32"*IkhmjB6j89Z%r#e24Bm#NB8i3I4YX2DU65`JK#[j49m!Tb'
+#C#,KJAJL41i8SIrlX6LbMMjeaIQAf-DTI*c"2GEG1`(lXI(elDV$mYV28VcBEcZ
+Nd@-cadT!3"rHF*DA)ThbDP6ahja&V90&'NbQ0U*(M1AMYa6r#ZVeFc1lj#TME$S
+[TYK!iU1Rmr"3[EJE62ECb0VEBHLCr3[@!9NND,U@-CCF,FIp$XL421qf&Z"Q1Za
+3(hK2-@Ki%XM"$SRQk%mf(Gic6D*-l&8HRc"J6jir,dZ8TNi8V)ipheIS*`513h&
+Zr4)b9f06&-QE`,MB3h$(r-lGIrdSKaeGYiQB5mbYbhiLLKZL$bXC%M*kN9mPpXZ
+2U[D+A[,GBHkP4[Ai+h,841fQ1hPVHPrlHpjFUaDfeAFH0Nqr6k"6Q@TTaY0U%'P
+i$&#)%B%!4(*d#"rMUDY#KSBaXM4ZbIrea!pj8r[`ih5eGh(EZB*(%Ecj+`+LU4e
+@pbdD(A,IrfDC'6jFAUhP`Dk''bq"`0@3!2'UT2%B%j!!Lh`MACF'S$(I'*1P!F2
+$Qr)*8MlS"(Vl-[dX8M+$"BZf5e6)DKiZcHrD)i42j,RN'bl8QjcA[`b6effTJpr
+GdpDD9R"Z5[Y0"a6$FUTQ8f,BN!#,YV1hCQ$eTDEMACAX8`XSJdB$266P%2J8p3U
+cJJJh(EVf+9(Nh*4J-99eU4d6*Ya"'FE10miEXZNI#eD$rfM!R&DLVNGmr#@$[X'
+XCP#`p[rT#`rS'6ZMT4aj`rhEeVkV95#3!)FHK"V4T3VL!kMGR1!+XD)%*,3#Qp(
+cqN`hXp,0DrCG8R5ffF,GG``r%!1%4H(-lY[S%HFb%0(ckcEH$mD9VPcm2K3X43j
+,56qmZpKf')D8XQ68aKq+haZS'Kp%S&pj+ep51Rfp1S2$b`@C[Qp%%Tf0P6e-GHL
+IYL6h,$5*1kY*[I44cL5Q'CR03dZ'UZaEk6"El@Ld8[im[ihdkQ82NYce'ddY2M3
+DrcPh[RZ@0[LdhZkId(X8U5`THChbi5UHTNrPb`Y'FSp2!Ufd0)TE@LmVG'#mQSY
+cHM&f&jHiBa3h%qNDcAQM#lC#D@1KY$RdSpIEe!UE@U[5Db9Ypa3B#6(2ICPbED9
+Z+m[mp1$K[B2-MT!!rhp0Z&qA&4p1XC0r6e4DajG1&DfFirY-("LN"0&AQQ*'YIN
+09SHhf&a[R)`l9*Rqd*,j&+3@Nh[i+(PfIF+i02`,"aGI*XBl-4h-CAS%3EUq#Fq
+EH-q`AJaKEK[D#1m6k1C2eQ&Req1e0RYS4S&BbeSHYr$H`1e82'Bm1d!B+BM2Mh,
+UU#GkPS-HZAUrFR2HJ3F0#EKaT8S)Z2K!-T!!1ZV+j%3$&r02,+JE$QfGlpEVQjA
+!RM[E*r"fa`Ma@%,XY!c636A5@4M(61-HI9,(eYBMIc4NYr&qE'3aA!dNkhrB`I-
+"&lYPqBUGE&'@CJFMMCm6+N'AdRiCqf0(Krc%MTNE`@0Q5B[JYf6E,%+kapcN6(p
+CXdKKriRBc[YkKS'QYRXqr4cF(C6kh53M@-D3!$RGU41"FdmDd$j*L$K)%#6N[Fe
+E333L$$djTVZ!XSVRIA89TYA#fhd044KCiDfU#!X4*UNR!FEU5jZT1P$%&J+`[&F
+&[G4E0mc$6X8LDDD45i9a+,Z#F!bq+qDV%(1(31TVq41R-QD9rQYZE6TZ4'X"['G
+pZXe"pkJd0@Q'rVA!)XSh#pp*Ye&))3eh94+L$qN%''l3PAbX8HjKCV5c0kj$"-U
+%&&3,k)[@'k#90L$i%M3P,,2Y0HCUMPT$'@l@mVQ0mUQJb3F)h4cHVP#iZ%S(JFp
+V+%HCD6))+jTYkR4dNbaQa3k,Uq`!l@fc1[HI1j0lS03R!8CN4aC2$RCG8ZeJmUh
++(-SICRFCmdES,@),Y6YIeA!)Sl*#@cJ-#[6G,TP2L#fDE[Ua$Pe'Vk56)!#K(@-
+rLbcV8*!!`bDU"A$QG!jYc1hkYL)!4M"*aETbIlfdKjkT9h!4X)2E)FY'!2PUY2k
+M2+hpq8$Z891lB2dF6S[#63P#Si'4%Cqb,9r1$&cXLkd9'iGU[B[cp%`V#AJc[89
+NN!!m#P'D3[Q3!$LdXJ&aB`-,DTKh6!C@,fh%Ulfb!bEXDL$`,,V1F1B6K4)d+B+
+bi,8TlchY-4JfJ$1!X8pURN'P'mIl(+j+HX8!GRdp@B!,UR!I@k$M`10kG,fV1HY
+`KiL!DqS%8C(%3+CdJ(cm16ErKkNPGTJfeFEjHBjUNiK"p[DNG#(I055!bQc#`Y&
+TY`RkMqHBKPS+a'8%9pcbjH0TMK%R8jkFLJXUS5Q-d+$'+XhYF42dmc8Tl",M#IV
+`kC&-BmJ(PKjj!4Ed'q3B&HhV$liq&6J6Bb%(j3R3I3L0DLJ1dr1*[I60-+m!Aba
+1h#K4UmjR@l@P!(Ai#JVKVB&3+,S9ME6k0P#miH'ARGH'`pilLI9&&+jIE45'"9!
+U&r$$[4i+NqT%5IT"bT291cC1Rj!!cFqBLUAP)e9)Efm09Yh[*'NK#V4T6mTYNH[
+Kid0RR[P%K`@bmM'fPkk9#DRNB[DA00-iBjKH4Y3&BE44,0PN)ZmJ(fZe$#G`d[9
+j,I&i$"rm10H6Vak!-RF4b5#YhX"-eE)e6!UE54&jH8FHFj%Em$9Mj)`V,(8cEkG
+6Q!8)"YIlEGPX30Y#L)020K*YQ'XI[`K!i-Yekpm'Em9Bpb&p1XlV1cfXkc08cD#
+8Dqh3GKE5U3SY5U`DZF988BZ2,8$P[hITmA)M)qpV()%AC@8R+@bjFmQD"4dEA!K
+6N!#)"GNcPQ!Ea65X6Jh[kpDF&jM9Z5NL46qp-I!9BDm%*pG'L!i4#[@&l1k$&`!
+5,E4meC)KXI1*[L#SqVlXSGq08NYf6j[*(GZa[@m'h0(KiRG*j1jB!Q8hkp0f8TU
+16BeFq4lJ#-,Fj4I$,-6C)Gq#P*Y#PrCCB[qIF(M(4Gk*L'$Dj"Kk&h%F-,TZQTG
+6+TQA2lH[@*80DAIQDc@5mQf[X8*R8SjU*SR(MGE0(IT+22XjRYHRYZhFFj6VJ*3
+XSMhKj6J+0hB!J6A4RPfa,dLAbh!)JeRmY*f$YZTQY(rQ"#SDeKP%rr3UNXCf1Nj
+l)R%(B9ThBEae3aD%9BU@$JemikpMlN!,[epU5L%NH4M+KQV#!(*["`T5MN4H,`E
+6Eh)YKhQmS+QP0PLREIi)(GSbjC!!+$hS*kC5i&E*b[m9,3TX0BM!JD#X+Ta!b8$
+$%#j0'Amlpa@M1mK`3LD+JUdDUmVl#EIk'9iB5!p+PZ1)NDBk[,FL*5)+cFRlbdL
+@*AIG*D!i("%hZD[)2FmXeeQcFVG2T98`D(ih*[Jq3mkSTmS)RYU&%VS'`6flY@%
+plfcZXGMKU+%kmR1J@0P0p!&pa%$4KMY@EHYkBh[+HD[5pB9-+NQhk,jTLrqIFB#
+8%446'GeqjG*'c$6BJSq)MEV[i*Nh1hQ9`E)%QeT0&hkp-q**#C3'6MG5SU!!qDH
+PFh!$*)(q#N2i1!`HfKZQ+QV1AmASjR"$jJ0*l51X98J1V-,`I4DMJjV$T"N+$U'
+4Z'KGKV@+r%,'IKJTbf"-##"q95$l'%Pk[l@[1p*d&2,XXmVP5Rp8QS'`XS6Ae%4
+FiYEY!jPTN!"ZA,*FdMpY&(m*KdJf[iKEY`'IJidPC-"Di9G3fVc[eED[J`CBI#R
+Q-eq5rj`)MR16)J(m0DQUc&k([45p!-TBr9cB!XCV#I4bZNqITYaZ%"-5PQSZF1L
+G1f+E'*+P$%PqTcT+i(T"PGj-eI@*h+fNGjk+X,+`ji)#VVSVp%"Q4`Fa$FN-++k
+BNiq-,Dfhp[VZfbX(dS[l*X([V!fjc4Ha-USb*AXm[GX!G$Z8L-+-ihMXQ,)[!kb
++FL-@)fkUR"3[Pl0Q@405Z$mkIb@Da+cmm5dKRrk0U"l-)EEG6V#6%,aYq8jUEd1
+c2[6d$QS)24!e6I'rZaf-#QfVUmeB@Pb'FKGcDIa03@lM8eX[G5I4RZ%-TUUKr$r
+8Na#DlUd@3qfmBKl$r4e+jdmfa`0"8$k[eGhl5IUB#2a%U-qGbNd)I38[)cPLk&G
+'Xi3YK*6-2d5i&XrGR#9S3b(1aH!cRr#`dTdTlp@--c)*pR!iI'421*)f*0*`0Ap
+J@`qUT,M[MR2kiRdc+"l(QL0iA[caYbi$bKq29RILaq@A'&rJ2IH2`Zp&c9YUZ(k
+j+a+bFT&fE-KrE9'KBVPS'CE2PlXQM!*ErXU60["D*Kb9e98Y4G,rPCX"Ce)%&m%
+q1pjr@-0PK8jSY-PQ-6NF"M1E%-D%4VUBZ4b4!`L8#5A9&BjG18&1brMRcVY8e[Y
+q-U,f`p@I,A-rLac)Yrk*JTAQVB#%iIleX!fUlYBQmBm3Xb#`'+L0+2Vdb2""f6d
+"QSBQ)Si%d8`Y228*LaE-rDrrj2-!'iKG,-6r`8BZqT&23*Z)S9h1$rAMX1$h2eQ
+MHMBD'I)#N6Hk4*S[kZ@`**Bla9YHG94k5"d9P-lU$KAK20TV6T!!!JC1h5Dd@M*
+je!0pAM0A`"frX[9K6VpI"A3q"G)XbmmDLX2B0ZP#6qX+Uk*U6jdlLGU`ERB4rkd
+IDedYh8-4VfjT*mj`lDbr#FFjm0h!L#9Pci2lZ%pd%!39fST,em"fMRTbqNK8T9+
+"6Y,N*KU5HeX013hY`$aimV[BMkDrBXSkNFeBc(#NIU$a%rNGr!M+kF&X[DCThXX
+SHH(c%hD#*EbXeLDlpa"3@G0QDAam'08Z5Jf@h(G#jR-"1D@0#9+[C0iVQe"''Qp
+#G@kT4%fc*h(ibjAY`#$qerB%9T!!hbF,cal4,V'U%dCL5V`kbD'CLYZN0kmJ$V,
+'r44IIZMbG1KhRMHV&dTUkJK'@X-dS")I,#BYL*!!HmL20US*+3KD"`-V$BDlp#E
+2Qrpj%TVD"&0m&FQ*k'P3b8UBU&*Q$FRG)"9)rP&iApDf0SZfqXmJl+Iiij+PDD*
+rPTlVL$T`@G(AP+RAX6T)26bZM$40l*Q8-l,0elkhelp&TT3GaG+&9PX9%X89Z%D
+fpeSYHpXl0mb%"aiFL"A-Eb`qp3er9"!!)hFikGqKKI*(*(H3!*R[M%pqP5pIPcP
+8cX9!*6*rpR%hECB`d(J`T*cbNRB[[1A@TTP`lFQc#Ej"eVV3#*`$,jD*T4m08(m
+V5Z8p&@rH"hUZJ*5li!S6$mH803Q$ERJi6iDR`%$Y9FqV,36f3E*9,K(pC+-i+'(
+1#*-*!(5cCIk'eV$V1l'1b5B&mQ![9iGIk"&4V%-Z'ZB(ieSGJN*"S3,$qd'A8!S
+(Ek#5KQrpG9BN$)FJYcFVkCa!M2550)&p&p)p'lc!F9Np2`N98SM$P#IbJc%cmR1
+`mTY%XlE%m@N3,BBB#a'PEk&((%4HRVVPk%Im,F5Kfi9m%D'EL)m[(ahjXRR@aT`
+Y62eJ"BmPHX2qM`Li!CcESF@$eF$1DqHUjB$UheM1-FIlA+CidPQ,Hi&pq"PP*E1
+GJ0JH#4%,j3&Jd6[@6k"+PVkIaA9Shb&&eEI@i[rMYHefN!$qqph2,$PXBE+QlU$
+FD[&D1A5S2a(b'!F%*ZM86NQXG%@p3eG8dj`Xj-Z!6c88qDmR2hEG2('UmG-6Xc6
+HEclFTiL)bk@%S`Pf!TcjF'-ECaY1ISa#[QUhXj9GX)dR,mRrY-E%kpq*NjZ-See
+K'F8NJZA#HlA+mNMX52(b-S-a@Y5$J3q3!2VUTF0ai!FpN!#G'JPFKXL4YU0icm6
+$@L`GU*k'MLhL3r6q4A`,#1dPE$kVZ(bDpBHP9DPch%X4@9p!Tp1kd3!99+&AX6e
+64p2)dM+#NeJaBd3-2eh1J6r)f,bL*`N@$4(MFirKd!`qPSI8JME`IPEMirVF1UV
+3Q`!Be)[-2D1ea-6deXT2AZmUe+rCESGBCk0P6Hl92V)EF5FC&mU2&!'h#E))l6-
+ecRL8B$RL%C1Sp-[9X-IQR1X4Fi1Z8e6pd#9iXDLeAL9Z8hLTB8R"H[+X(`p"PCj
+%)Crp,f(A"YP#pBQ9K`(43Up0E!,8Ym*BKAeE0$8"rY,0Aj!!#Kp#5%JU,ZK$5Gj
+A[3N4``VQjkmJ-+C2!'MXSBKHbEU+MpRh9I"k(5$MM)aa"8ba)`1I5i"130!hm-c
+rQrQClRJ-EDJD)331F"AHr(k4P(1hJh02BrNh-B%62Jd8bXXcQjpTI2*c49$NZP&
+P(8FREhlF8HTZ2JAN@E#B5eG%SU,q)p6qqa"BU)$aqPfU5BXIiVe9K%NeYadfUN,
+2ceGpIJSiT-#R,HD%pJTTG9E8Pa5Sb4if'%dVlq-JT0$"AKX($P`kYCJ!154($61
+AJRDJMIU!pP#+'rAVkPDK,224f5S"kYi##XL@RU*e$3j2F80*SI(rjb)`LcTbVG1
+HQr,'H`$LSbeh6GpJ98cH!R**!F(TUcSmpkV'9Vk$aGQNXh&U"ek,&&e*!)%,SRd
+#`U&b@a$J28CH(GPU%!T,D6HUCBYr&CR*P)rKb!`NR)$B+%fRQ)Fe658RFLIR8Y9
+FVFSZFC,2ZbHMXIb2rS2#LETKc(6jmc1eZ+XB,&GIJF&Qlmk(a6X'hBk&PDA,24"
+UhMPA@aiJiF%FKBPI[(lFK2-66-Aj!82N4NYk5!kq@TDM59Y[fjm*Q%F*Pf4K9kc
+fB,1"rDKCY3k+H9mSqhSp*hG3'TpK2"ULCUdCJ5qq*Ta'!c0EfH3Hj,LelZMa%@-
+*4*!!LlVlEhMQQlR`D4%""e[MG(MHfDNhBG5S1(jY5C&dqe%YMTc%*&#PJ`*FJZ+
+`MK2((l5Z'[94d)LLX1G&@PjR%AHhjMh@H"9A'Tr+2FbkVV+deM08p6RE8Sl$62q
+"+B@02AKH"6RMhdf(cG-hA#KD@c-IjBY[Vkj9f6+Y8`bV8(QNMS58d%fD1$jjC"r
+!TRACafmrA[)G8Q9jSb,D`Bp$f#YbUKAELT'K,dUch)EF1,N3%XKXPZR,rm-D@Pe
+Q(qla9d"N$D!&Bb#!Y0*8kc-8+Hf)1`%5%aKcP9'(ClXqKViUq)r9RkH9f@FY1!R
+XfRRDU)A&RdmZLVp525#FYjYp%Tk1e65ESF*JhVIlC[[J&0LJKlbfB!mEK3%lFbe
+Z`3&P@$hfERG6bVRN)@E2)@@HmXB)rmX9mim&8$aRk,0iBEM6[1TA8hCpV"PGbIe
+Y`%(S"VfcUV`&S'qQ((HMT""-bqPe[YcUNjj8ZUCA5CKHSRVI5+"%i,!SQBQ$ff+
+lP6&cN!#dKbcMBebi-TXIa5hKUBEB`p3#$J`J"$rE[Ibj5K&p8!FrX-IFQp(SM4%
+5aPrE1j,K$!R&cp+&[H`LGYRp[Tp&hkFK#lj30+-)F3+&0d211[j+dl+T`2*2&HN
+6X$VhK-GppdS-aHIlK+*Rl@`BKk!,k2P2NA*UL&3D%VZld$SSCK&VF6$)a2IUa,H
+`-N#DZh1QJKI1!bc-ilPX"0E4Z1R[GK`4Z',!6m[B"9qh$5Pl$%@f0B@V63PNjN2
+CXqe8bVQRXd35PS3a5-a,I2Na`T'#3!i))Bp0%43!TC!%!3!!-!"!!*!*!3l0!*!
+'!6!!!)0Rrj!%!*!+TC!%!3!!03!!Y[&1mlEa6[-!!!%`!!%YG!#3!p3!"E`U!*!
+15@0[EJd!!GZmD@0[ENe"3e0"!*!2J!#3#3(Q!*!$J!#3"!m!3X(8iHr%)(JHNZX
+l)T0$PMe1&X9%h,U"-`j,RCS+U(NFRSIR`'$MA4ifZ1eNp(bc"k[8Tf29`V5Ebi-
+dlUp1aif&(6j6c4PRTLP1eK5a-h2EPVY&cfClKmZkIGS2aXQ*%PIPjC5M%Hph@9&
+a(ZfDKkIUBkh$)JJi(L3&)ZG6@!#PN!3"!!!`!%!!N!N",)d!N!I8!!#,Z2q3"!#
+3#U@3"!%!!$8!!,GD)G+h@L(6!*!$e!!",Si!N!0b!!@JdJ#3$NPMEfi0!!(EMfP
+MEfj0380633#3$i!!N!N"jJ#3!i-!N!32!%,"e(hUjNKc6hS*X&!ZqFG%dkqC`#&
+3,a$2e2#THbFLNpi5*Z4VJD@If`"I'V#EIfh'MSlG""q1a88iE&-14)Qqr-Mh6Z)
+ZSeCSpTee"5pRNpe,5q3Re3-HYimLk883BP`hF8paMJYi,IjQFS4aSC!!3[jdX&9
+S8p#SmYla(hQ@e-dU3+@3"!%!!$!!3!#3#3%YT!#3"h)!!&"[rj!%!*!+h0)!!!%
+!!!'253!"MNN!!!4X!*$cI!!"!*!&D3"M!(d!R`3#6dX!N!Fp!'!!miKF9'KPFQ8
+JDA-JEQpd)'9ZEh9RD#"bEfpY)'pZ)0*H-0-JG'mJBfpZG'PZG@8J9@j6G(9QCQP
+ZCbiJ)%&Z)'&NC'PdD@pZB@`JAM%JBRPdCA-JBA*P)'jPC@4PC#i!N!05!!%!N!9
+Y!'B!J3#L"!*25`#3"33!5!"R!31)-P0[FR*j,#"LGA3JB5"NDA0V)(*PE'&dC@3
+JCA*bEh)J+&i`+5"SBA-JEf0MGA*bC@3Z!*!$6!!#!*!&-3"R!%8!V33%8A9TG!#
+3"3S!8!!F!4#)'P9Z8h4eCQCTEQFJGf&c)(0eBf0PFh0QG@`K!*!&#!!1!#J!,U!
+#!!%!N!0p384$8J-!!(i08`U6K!'ME3$X#h)$Y,)b+b[M@dhH@qpUpkCZ*YH!-3"
+!!`#3!lUe$)!!#@NUrZ!"94)XqdV)@`lMjA1kK9'1XMr2MrqZ)$NhV"Vi%FU'0AQ
+'BU0RDr#XAMm&lZ`,`,#T"L)i6&Fq[H[,VD-C!m8F@8XE1!X!N!0D!!%!N!9G!(!
+!F3#X"!*25`#3"dS!93%6L$T6Eh*bH5iJ)%PZFh4KE'aKG'P[EL"MB@iJEfjXH5"
+LC5"`CA*QEh*YC@3JEfiJ5%C6)(C[E(9YCA-Z!*!$EJ!"!*!&D!"k!(`!YJ3#6dX
+!N!G)!&i"*BK18fpYC5"TG'9YFb"hCA*P)(0VDA"`C@3JBQ9MBA9cC5"dD'9j)'&
+bC5"ZEh3JFh9`F'pbG'9N)'*j)(4SDA-JFf9XCLePH(4bB@0dEh)Z!*!$@J!"!*!
+&A3"`!(%!V!3#6dX!N!G+!&8"%iJk9'KP)'CTE'8JdPi`db"YBANJBQ8JC'&YB@G
+PC#iJ)&"XC@&cC5"eFf8JDA3JGfPdD#"MBA9dD@pZ,J#3!bJ!!3#3"D3!M3#i!0%
+%#%0[ER4TER9P!*!*RJ&H`!)$k!#3!p4"4%05!`!"%Je6#TXN!$Z+L)S9caE3Fka
+%E"$e,$pr2qcARErRlXi-TeMBB58U@)999@,P[r%%XDS&#l*P1diJqC!!(`&8**M
+k0Eb&Tph&fGe0dXKkNVep(bj$h-@Aak8,&[Q01&G2PI8,*$a+MT*"[ZKdYI"dDK@
+D)Mi&jNl(,(@,TA1"CHpm&"bi0FV-TR9!6`FK$%aAP&QFVF'lCA-L&paq$(JIm$a
+!SNrM'Ub)p-`20hNS80Z-b('VTjc&BeY4ZFc0eZQ"Uj3hhmRl$1Rr92r*E3#3"$S
+!!3#3"9!!@3"N!*-%!Np,!*!&!`"%!%J!k)JC9'KTFb"KFQ0SDACP)'Pc)'4KE@&
+RC@3Z)!#3"%J!!3#3"8F!@J"E!*3%!Np,!*!&!J"&!$%!k)JR@@pe)'KKGQ8JC@j
+dCA*PC#"KEL"TEQ0[FR*PBh3JF'&cFhG[FQ3Z!*!%$!!S!#J!YJ%F"!&993#3!``
+!)!!)!+)"(!##998!N!--!')!NJ$`!CJ!K999!*!$$!!S!#J!G3%m!)G993#3!``
+!4J#Q!,S"eJ#'998!N!--!#!!#!#L!4`!J&99!*!$$!!S!#J!VJ&1!,9993#3!`i
+!+!!S!-)"T!#)998S#J#3!``!+!!S!*3"%J)!998!N!--!#J!+!#0!4F#!999!*!
+$$!Y9EP0dG@CQ)'&c1J#3!`J()'C[E'4PFJ!!"$0"4%05!`!'G`e9$8-L%K(QAQi
+3C#dC4'Vb4#3,%&QVTLBRYcf,M1"fjmK*Yc06mTPrGlr[fiSm'pr-Yl9!NYA1l-R
+N5GLq1j-4NZ9@j)QXb1mIN6q6RmQmfGCf%8N@%l)h,FNL+%$L"rp1@BD49%3iU!X
+lH1)RGL%XdS$Y8-@K&RB5AKr2MQN-Tdqr@5Tb%b2*lEeNEa2deYr0KTa,b#P((lQ
+rdKDbpHCeqFBN#8XTDGMHT"F9Nj*A@5m3r1$*iF)A(Ra+`bCSd@*%bYh0[UE$mLb
+8Z8NZL1FKb4cpaH#,'S2Z2"A0G593mh5B(ilNbH!U(HDq*03V2L&LN!#Glm-GLj)
+350pE&JffVadV0j9c-)PcYTmmT-U'cCf2[lLr"Zb,Dr,j*UQJ&eL!@HMeXIT'U5K
+XK+Zi)G(%4'NH4P'P*SBS*l2%Ke)*Td69NE&*%bSLi2'$"P$iBJ#e%QfCd)!P0"&
+UFSY0QF0BUD3IT`bXGDL,fZ$B!U8fSh08@--BYZrp*)$#,J2%1@+BZ'k&r-qa*h(
+XSZeGPi*0bi'TkX2@JbVR0)ahG0E&J(3EJ`[@YV@,-D*-cb(Q-Y`6mPcZfjMcBMp
+"cGLljK3Rb&aVTMai@-PP[RfUT+62k1U0klXYd-Kcq8@f`RZ!4-@X%K,E)89)*H!
+)2HGQk+!L4L(61rDKE[-93T%lT4&h#Yj6*Gq@)$NpfZfT-bIQ[*a$ZHi9U@$-fpT
+GbR)EqIHh6JN-ELhIr*F2iT-R9S%)rHb*!9X*2'JQcVG5aT+bk)"66"T!8Hh@RKi
+MNZDb1RCPrpLBBZE'f'*+5Z1k(+rRjMiNk%bc`$2Y2dPbk)d[lP"05[[rh(fm5+9
+i5KpCGN!BDPI(P8iGH))aB&$'@AMak[HhZkICP"IAk`20U"30ED$cl3ANPB5bhE"
+dKJq'UT!!'MJ$K%Ef[#TaY#Qi5[JiZdp@*Ek(V6S2"5LGMGP9XcSTH`kX!)Q$@e`
+Lj!Hc!YeF"G@qBdCpV(kpX(EYJl32qi0AAhd*'kUV,i&`%M,25lL3!)9HJTA-Hq-
+JNiRVb1C`%N0V@&,9LJXedG30VZTedYBKmQ8[pD@$C2LX$T!!US[$LD0[BBPS9ak
+e"Bi4i"NpQ[B5,S$!l!aZkDY"[CV-MSM(ZdcHrYqi$lHRmXQ0Uj1Q&hdZmV+6dc$
+Q@CReZ"0&fVV&S"Ua`C3d8JpM+h9[1peJ#QP[H2ESABrbfDQ9EXl,)rR"Y(aV,(D
+K,&e(qXHCLJYTG`ceq9R+jqIUrhj)D3VcIeGqcX4Q-IlfpqABR&9R,NpTEKEkTP6
+FE&CkmZ##0U6Epj,8cI&CH25LN[RmcjI[Q)F-e2@eAFBV*qph(["`34I,9E@$fDI
+YZ+ZVJh8&%Tl"cXY,fjl%2ZKNB,XDjI@RH3*a"UE`8,`*ALRF`jGi-!Gh[Rked&R
+$@pIN$J#3!aJ!0!#3!r-"AJ!"!3!"!*!&!qJ!N!18!*!$2!!&"#"[CL!()'PdC@e
+c,J46G'p`'dPdC@ec)(*PE@&TEQPZCb"dEb"9EP0dG@CQ1JY9EP0dG@CQD@jR1J!
+!"b*"4%05!`!-3`jG#kZ#*$lU%1prGjb%8-8Ke%4U9$M4)k"mV`1cHE"X35+++e)
+@+mTLVcDH@@K*2-mfY,@Gq([e)E3@F+Y3`CU6#q4l%rB@IfqViqmTMVm(#i0NeC)
+kXl[86Qa45-+m*-Y)P`SKT2Fr)CeBA(YZrId!$HEQ0$%"*$3M04p9j!kQI8Mr1XJ
+2KmNe8STE4UDQIi,S@Rhe[I@qarqjqdZ#CYHDLRYFmcXRh'Fqe)[)rKRQcr8Z)jY
+$mqMAB4Z*`8GNQ$3LNF,eb%X++LNJ[Q-))Z%`N@8J`NC%+3H8XKIX1QSI*qQMdQD
+IpGLhEpjV%lmY1l+5fDcpH'C-jhq['[`3jSrETKXX9fHMKlcNER4riBTCqG'#)HT
+h9+c"*XN$@Cl+I(h)QjMblcphCF`KE5hCkEmEJ'dKrURKM#aIRB*N3e24C0KHQ)T
+l$%Br@CYXcVBTrfSiNkeV5'3-b4AlqD@&QA@GlC-5"V-KqeISpU@)!9VF#TrPGVe
+3`$j(GLp+(M+%)bJKr&Sfl6c(iZ1Y!9iHNp3EPSIpCePFTPi6XLqMR56Ea[SbUjG
+DGG,V$qpI@A3Hj0jCf4[JHkF,BhCr0'i62[6hH)6PrqmTD$jIpH[T![HreCf6"(c
+N`HmpTrP+(EbH[''!b&!IJmY(HX)"[R"cV$$bkT!!BFkfqZ%`*Q+HH1mQpFh)rJ@
+qePkBpb0ELS5`[FqP*d'Lda$-8qj%Tj%SG+&FF'&0$-QD@&h34--"6@3i6E!+&5C
+N6k*#4QZTHTiUAUNT`YdPZGKX@*2jFEfX5HRlGNQ6`Y[fJLBRhkjk5j-GMr1P!HB
+l[3'Qm)HHJ"HPEDQ!T2NIX`%2j1DEYFhii,)JXp(b1Mbrp)q9Zl25JF%)$&*Jm!+
+$kJjf`(I`)SH&YIF)dciHP@*rMBUa4$IDcXH3!-q&V(Q`BSJadb$'CXSYUpXb)Mq
+,Xi0GD)T&6U4-SpFIe6rLf`lAZj!!4!fm'%+q8%hL1133Cp,eVX%T8F2L###cAI$
+mL&00G&-%Cd*2iB%iCf`MfF-jf!FJ1%J4[MVRbX'20Z1CcLbH@N1)6)kDFS+SqQb
+1EX+TQJDrTfh#kJ*5aM-q0k+Q%VF[a'CXI#96N@%'546j5+F6eCZ`Y)TX2A,NUk)
+B-Ej,R0VL%(mE&PXrq-#p#2e$Mh`2m[mZZU6[&E)M(T+mmZ5*C[*Naii8P6'D6(c
+bha3TS[J5ABK&@0UBMc(1MV#HAk%1$dlX0f$d-%mhXhTHI(EKj`HhGF*SlVcm3"f
+0R8KeA4MGl##9e5FlJEb)E"IQpI`h[mJ1R[b#0H)%!d,9%Uh1GmIjmI'(P'YJ%Xl
+MTk6lU'PlpV!H4GrmYK0%M4LGSRTmK3Gb$BLAff+Tl2CbF&6Y![$@m5BA+)6!`8@
+ee[Q9(MN+4[41XU3cmMk'DQ'S6h&HI"C4IqZm$K%CM(`cNh-UZ['2M!%2")E[(Qe
+ki1c3Sd5C@fSUeH@m*6B09&BcS)f1L@L#PQ*+KA6-TD%G95+1T&jmbi%QIa"&$XC
+A8%pjZ(#6lN3Mjf1EiJUFd@m[mhpEDRiY`BBack+-$RSC#LEPF![d"pU$S5L'jPl
+JNJjCi#!A!`%J-IrFfDFJj'I2C[Bd0UCE2jZlIl&[h22GqrIq+,l2YIaTXma5M'B
+r@GG*k@i'TkPPB`@qB46N'fV8i#e-mqY#FQQhm,*pdPaSPhIj$G'iC,9Ub5XUlPr
+MUJ4eJF&a@NLbIaHiI1&RqABj*aPfCDA)c9$b&Q1&B+d6")mEj`"hp!LF[E!INQr
+i$5f+0$%85TjqUk*%EUa+@q*c!aF,QlbR+TRT&K*AHmBm`H+'b@!Ybe[DD%JNC+Y
+K,rT32-h-5[2H&`Vq&@3lX4p3qFD#JN-be"TjPN2HL'*jq3e('@KA62r,S8m@)G*
+`Y9bQVCUKQ*,F46fP#De(dpG(,*GddTH@hAh9Cmq89@fhA6q[&HaSDHi-`A&rBc"
+SL*VAklaba4[#Y3N[eaKF#TAbf#jhZMBU6rSp`@$*6JDqIde3IqrP2-(&8*'2lGS
+HTLKVm%m-dEa@`90(@8HSq#r2kiERdSZ#C9dhN3qf5G9@i9,MEQj4F)61!R+`NF*
+EQ#T+d!MBVHi6(K1%BpVk5r4F!%DirSj!pl[YiQ83Vp(a)p)(#6++Y%mhNNJ2e#*
+CJ3JADBr0GlNJA$EL+aRZ3114C2lUKK@1Nj`-Cd`A*&$Smk@bIplmk&rjj*%N!V4
+E+8QIVZ9DXkIkqYr-K5K(p'2[p%4qhlC$P5dE9Uqbd&iR9pd`'&Kc0*!!U["1F`I
+#QD4#UF6[J,+V(BCCFebM0LLP5'&(NU-8pp2f1U[GXf#3!0bTkLKeI+$XpBE#8R'
+ID@5dE+#fMGY9GNqZYN`D+Xf6iI+JTG!R)B'`%6K'3j9)bMeQTe#4CN8`4!JVG%2
+hqIS((dfBili2!*!$'JB!J!#3!`-f,M!28h4eCQC*G#"648%J0Li`!*!$$JB!J!#
+3!`-f,M!$0Li`!*!$&3"8!'3!L`''!!%"!*!("%X!N!3B!$`!3!#`!CJ!!3%!N!F
+""`#3"J%L384$8J-!!iS08`UE*!"rKN@`h6Nj%l$&$Pe,6NmGf`%9!pZaqYJ-9[A
+12LLS@(eX`@kXkXE!2f0r925rrfq2mhC@'FEU!!ZC03eF9Shd`Bj'pkj6'Z`%Xr-
+S&0c&iM*#YY5j)-Pc#j!!hfq#GS,Td84dcbPjXa2G[-RZ+i@%-ma,@ZUD8SSG#ci
+IQp0r"2"krMRUbY2UD[qIAfl(Ujrp3rrlNCBP!VJcDU1#E9E"5#Dm4DYXM&@eAPX
+qBTZhKHeK&AhF&mE5@NbNP,3#F4p-ISc$ekiEjSHQ'HT6frC0h3qk%'KDJ#F%b!#
+F!%bpqLd!rZS*!a&r!2#LFZ%#%"b#J!'#BQ!Y1)Z43BcI$%,N%MVLkQ15c,dSF4p
+-hh6j4F3VE-XB!*!$Gd&%3e)$!!#!$9-,@b!$!kCJ`kTUXc#`!5*LB$G,XGYCPD!
+JBX-HkYR!Q&8a#f-UZ[HR8k`+#iPMb,ELGpB!8LMpiEh!JNUia8#RBdJbMUrCpbB
+L$VrTa[llf*mk9dmSTT%&(C'kJKQiSm8DVUKU*k42-JV[4Fi&!*!$6!!#!*!&#!!
+d!"S"'iJE8'aPBA0P)'PZFf9bG#"NDA0V)&i`)(GTG'Jk!*!'#`!,!#X!+k!#"%X
+!N!8G!$3!,3%BL!*H-3#3!cS!!3#3"6B!K`"+!-%%!Np,!*!&!J"&!#m"2iJCAM!
+JBA"`C@&bFb"dEb"LC5"NB@eKCf9N,NX!N!1U384$8J-!!,B0@`Y6-!0hFbeQ"Z`
+CdmT9aMFdilke99E'2fp2lp9kYqiprq)E'J!!m!d!!1Jf$3!!#l)Y'i'Pq!GfCr[
+jjDdYFp0@cGpCf*-4E6ZY!bFUCeRCbDlbH0Gh4)AJ8X4rJKJ8[N3-RI0#5DL'!59
+#J#kS$Yl9"F#6K4bJ',6dJeNIl`L5Cd'q)0q+c@'mi[eVN`@PK4)VLVPbh1Hj`Y*
+8H1AaB3%!N!--!#J!+!"r!A!%Ve99!!!"!*!$J!!Ird!!)!)J!#)%N!!!*JR)!#)
+6j!!L)!)!)N!"!##(i)!K$r"!)K``)#3Cra!S'SS)-M++*#BbmM*10!Bj*QAd-K*
+P)Cr`)"($!%!)ri#!"!B"!!)E!J!"!!3!!)!)!!"2N!!!*b!!!"*!!!!!#)!!
+!!8!!N!1!!*!(J!!Irm!!2rrJ!$rrm!!rrrJ!2rrm!$rrrJ!rrrm!2rrrJ$rrrm!
+rrrrJ2rrrm$rrrrJrrrrm2rrrrRrrN!-rrrrq(rrrr!rrrrJ(rrr`!rrri!(rrm!
+!rrq!!(rr!!!rrJ!!(r`!!!ri!!!(m!!!!q!!!!(!!*!$J!#3"`%!"rrq!!J!J`!
+*J3+!#N)#3!L%!L!*#!)3#p!$q!JJ!!J)3!!)#)!!#!N!!!J+!!!)$!!!#!J!!!J
+)!IJ)#!2m#!J($!J)"Rr)#!DJL!J-S)J)$!')#!d"L!JCI3J)'8F)#"Rr#!JF-!J
+)$rJ)#!"J#!J"X!J)!!!)#!!!#!rrrrJ(rri!$rrr!!rrri!2rrr!$rrri!rrrr!
2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ
-2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!!!!3!
-(rri!#!#$!!Z"!S!+3J*!#N3#)!T)!K!+8!2i##!!#!K!!!J)J!!)#3!!#!S!!!J
--!!!)#!!!#!J"q!J)!r`)#!F-#!J'ImJ)"U#)#!bJL!J-!BJ)$3')#"Pp#!JC4`J
-)'Im)#"``#!J2q!J)!'!)#!'`#!J!!!J)!!!)$rrrq!IrrJ!2rrm!$rrrJ!rrrm!
-2rrrJ$rrrm!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ
2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ
-2rrri$rrrq!rrrrJ2rrri!!!"!*!$J!!!!8!!!!)J!!!%N!!!!!R)!!!6j!!!)!)
-!!%!"!!#(i)!"$r"!!K``)!3Cra!)'SS)%M++*#BbmM*10!Bj*QAd-K*P)Cr`
-)"($!%!)ri#!"!B"!!)E!J!"!!3!!)!)!!"2N!!!*b!!!"*!!!!!#)!!!!8!!N!1
-!!*!(J!!!!F!!!!2J!!!(m!!!$rJ!!"rm!!!rrJ!!Irm!!2rrJ!(rrm!$rrrJ"rr
-rm!rrrrJIrrrm2rrrrRrrN!-rrrrq(rrrr!rrrrJ(rrr`!rrri!(rrm!!rrq!!(r
-r!!!rrJ!!(r`!!!ri!!!(m!!!!q!!!!(!!*!$J!#3#!G"8&"-!*!'"e0PCc)!!3#
-3"!G6C@Fc!!*r!*!$"e0PCdi!!rm!N!-(39"36!#3"KaKGA0d!*!$!8P$6L-!N!@
-%4P*&4J#3"B3!N!-d399c-J#3!`&*3diM!!-!N!1!!!%!J3!#!))!!`#$4P*&4J!
-$!*!$J!!"!)%!!J##!!-!J`#3!b!IU5!a16N`,6Ni)%&XB@4ND@iJ8hPcG'9YFb`
-J5@jM,J#3"eG"4%05!`!"!3e6!Yc@"T2hdNE0440Y!,6j0bkmfddECX*X[UX,hi6
-GX0[NhAE9eA9K!!NiTBMrG!Ak'M5Q0Klla*eVf8k#LE$6%2V!XqJ!D*!!aElq",i
-'!!!%!*!4J3#3(S%!r`#3()%!9#[r!*!DJ3"8re3Vr`#3')%!92q3!e3Vr`#3&S%
-!92q3"93Vr`#3&)%!pID3!e6fN!3Vr`#3%S%!pID3"2MfN!8Vr`#3%)%!pIEfJC!
-'9[IfpL[r!*!1J3$ep[Eprj!'r&EfN!-Vr`#3$)%!pIEf9[prpj!%JIrhpT!%+rm
-!N!U"!2AfN!2mrIG@Ij!&Uj!$IrEf+rm!N!L"!&6fN!6rIrCr+Rm!N!089(p@+rC
-8+rm!N!D"!&6rpT!$9[riphmUI`#3!e48UrFVp[p8+rm!N!5"!&6rrrD3!rcppeC
-8+P53"AqVprEfrrp8+rm!!)%!92q3!e6ip[prpRmUN!989(prprK8rj!$92Mr!!$
-r+e6rrrEf9[rhphmUJC!%V&5V9[D3!rrr92Mr!*!%rbY8rrEfr2hf9UXUJID3!i&
-rrrIfN!2r92Mr!*!'rbY8p[EprIG@Uk[rN!CrprD3!e6ir`#3#2mVp[C@rRrhN!6
-rJIH3"2D3!rIir`#3#[mVp[C@rIq3"S(fN!Ahq2m!N!cr+rD3"[q"pj!$pT!$prM
-r!*!1rb[fN!2rrrMrrrMfN!2hq2m!N"$r+rD3!rIhq2H3!rEhq2m!N",r+rD3"&6
-fN!2hq2m!N"6r+e6rN!98q2m!N"Er+e6rN!08q2m!N"Mr+e6r92Mr!*!DrbY8q2m
-!N"crq2m!N"lr!*!a3Ej"4%05!`#)P""9$@99%3!K9Hj'RckIP9+A1THPQ3[p@HH
-XJkd919ilR0"ecjZZ,P[Y"Nk#VV#Y"GcclQX-A$KHA-'"#b!1j!a($*R6`fd),X3
-[m6M2QjaRL1F40-C6ipFJAjmh-ES33mJFfrVqqr`qEAmG!b'AerIr14e@0K)4!J'
-3""%"N!-43Ji!A32IQ[Ej"hUL-`Km2d5"rJbZdI4iYUQE[`3Tm6XAhiZ&e28rqjH
-mNSQ(K@lSkfQ#6r`iVi51%R'3!"ppNiMDBVVe&PPM2LpJ(+*"mm&3LHU40Ie0Ta2
-I!E(6NmKV1Sd&"12cP@QJ+GX')Y9EJeDr$H6H,`GrpKGRmP13!#bEXSf"1qIEaTU
-h[$@iaYbd'mYIm@8%bjemf8Q[*dT#jjHGTGF6*F&@[Y`*SR$2XV1Gr`B3[)iqlT-
-J)#BF!mrN18-Q*db"*XqIq-$d9ZHrJBj8$b*c9I013I3G00mrlfl2%H2BSK"2V[a
-Qr(XLJ*m3IS+Y18,qdhm2IfTqeKB%XFVLV!J0LIqCqZ[NN!"M++XipJ#IGMNVq'*
-Ia'@Zre0pE#iIbXiNQ114SC&2Ba+$fJQ#RIM'!GA82c-"bfc"+$+J6QE-GGQH%Vl
-1l5")aN45M)YY`T4rCDT3TH)rIjhk+cA-f04IfF3j$*[aXfAd#Ne&V[$T8Iedj)V
-%bPk-l4X6hfMqFD3[fLH#H8,PN@r2lqBNJi0@pqIGL4`4AIQImFqaqFqaqFp&X11
-(k5,@e[)$GB"[2AT(3"d`@mceeeYLZT9(L*@rFMQMYKmqBGlUiUmUp-GEIrM%PDe
-(j4`8,PBaG9H$6N`HFKc+EC!!qr1l1q*%0'hYYpjL69*@L-TL(@Jkc3ET@%K,bNj
-T*8+Ta0chAIBL3ZcDBCmeU4edkBrm4iR3f818(5LU1JkJXC(AY0Z",GUp@%D3!-Q
-BE2[,'f+d'b4Jr)GXZ4,jimk$3im+-C9HAbM8cpIjYh3HK-S#%2[#D,IjrSdE6ld
-Y2$!)Mcc3&(-QCGFq%-%lDdBrd"3Rlp8(*jUN!'8I"PX@-MqJFJ0Vl#C(elVC6Ur
-XUXk3!0qXrNM1PM@b[rS8b2jq'c(081e*Q1rD,,#CSSebGZ)lIp`X[#!lKa,q@25
-H[Ce!m)r0)U6jkFYc9-mi%*3SNq61qEJX3iP5fer+bKaGJ3&RU&R&Yd(&F5QbFT,
-BJ$pkMJ6C$d4"`"Hq[*5,FpMPSG@fiFhr)"DKJN',eRi%H8ePa*Uh#2'5&M&XV3-
-&8hmBJZH9#,CQpr`'&F("MV5eAJUqL*41(T!!Ye"%5B'E)JT"'T%IQeS6D6,Z'e1
-TV-L!N!#4!G&CFk+l0Dr*+#IY6e*dQqqhLI43jrD%L#AE!S,)fp(1Jkh#E(VrXrD
-!HHLpqZZ(c#D6UIkcZ8HPPf&(*V4(!LD6f@3IRi@QRYRPp&Nqf`3KYL!Yj*!!a,5
-*[c5EfJ-ThlMqk&f@KQFc[6A24N)[raKECdbGMkT8*4iL`eQ$P+dBX#'Uae4&&M'
-aa5qU"kT6cAR0KjYbQiUXL"b9LM)SQPZDEFeh)j2M[jSdeE1UCmPMaT5F9'6)&0k
-j1&%h5pM(UB+HY$Kpq!R&r'5FcA0L845jkTK2'QUc$1CEJf[bQMjX["HIDBdR1aG
-rZaJN[+MT,6$@)C0`ciPZBf!#i(Cec9-!YKY2I*UVqRVMT$aQ2b2,qNXG,V[I'+S
-('8qILIHTUc%#TYb-P&8b[5b2R8R2X)Fa"5Sar9hRiZ+06qeG+aV(q'IT8hY9UXE
-$TVc'[UIfLQLMUA2aVXe!r$Pc@NKJ-3F(c-JDbPY5KjqUcKNrZ-B@0beZRR[iZG#
-8,GlRHXV9I,dTVrNQ)SRJCbj8r%AR$2-e!hXRqU$NqDC&UNI`8if+HE2U4E"8dmq
-q-9Y&mkm03lqkqGGJDac)Dbj9,F*N)reSfGL3!0MB%#3*[d%%$Eemq!*q[Y#bIS'
-Ipl5XmpR3hrcV8r9pBPMB"TUIT!`9LiA!&@GSIq"8Yh*ML+VVejLE(cG1VA%eEm@
-f2h3%l5d6$cGrBE69aU$JBFFLeH010CN"-ZkRc'NLp-CIJXK+ACF#a4QbNRCC+4X
-*3"G3++%XAh0HifMcaeDH05Q5c8p6&U*))ZTf96q9X0!,9202'l*F$-6r,MK*c)m
-X4C!!RSH#a!'5QR2%pUUjITZ`V4&HFhh0XEDpILTGIA12a6E4UalpUpF5BZ02k9r
-T6qq`E$eL`f5Vf(L&rT9HZGkb&5$R(DrC!V2S3-KFVh0KiF2"bp[%aU[dVr6UcCD
-YafcZbJFI1AVcj8fSUZIfr6fUeEmI&#'EEfi["Vj`JMePK!+)DHXq#fAiQkYEN6f
-()YP4r9&lT!Y)cTpFLL[Rh5C#B`00(jVIfc(30-hmfI*MBelcHmZ2E3YSd6Lbp9K
-+mZBMK`HDlMCr(fac`IEDBEIjqmYIk`PXr)$qPAl`q*'YVmdk"P6kj-J03!bIXd#
-YE'i[Rr"aC2T(fq6)2TeSDDiHb1ECpiA9$XS1Skbli4S!GJ10NdkG,N,CeL)*iY9
-!I8PmQdMZfbD3!$d0%M)b5#R#'QqAXf1kpKE''#4'H3JjIdQ)$f0Yr[rPl(BcYYd
-Khfj3%,)NNi654&YNY,*kb-$-+&LX,848PKd`eb3+B1e"Dj!!MU!UQG&UTL@Kd(a
-X9T`ZX3AEiq8bAe8`[hBGc#F9c)G@CeBp3`EHG%CKjXr`c14F9A(car5aMUN+9B9
-0c5KiJb,Bp%eT8UL&ZUN"L`$!d'rUK9('+*'-@mRF35i'10l5,Tkf109'rh5,A8D
-e@8'C0mlKRpmR3RBHr2CjLG#YfUrTMZ8EJp04A"[GB'k$Se*)bM*Y&bQh)%[&4kr
-YQkcVpRNCQS@%D[2(&2@b*US$0Ia@*jVS3QfVNX3@ZSb"%pdaRRdEp5M93eQAD#K
-AQ2p"$NET'[G*QqfTN!!%8(D++2lTk'G0T2(m'P5JM9Pb8Q14A@XdMFBe!0XEdf2
-Ym4ia!X80Bc&P68*p&A,HiQ%dCR4L&-fjaF8k4,ID-E$N8AY#$MSpRdY9N6T@J8,
-%L*rcB*)eh36+0cV$)K"439-5-+XYR+&,8j%E%La6D"Pb#TKki0$Q80mc"`(A
-@+-6'0&FQKqMkV2YJU(l$iA'C-Uj"dNrLF!81Z0%mAIcSq9Q#60-q5ch3I(1+'P'
-NYJidPe,60H#I*D$%m92G8+UEXQaq8@@,+iBMXq+f)$+P&0RMFClj$NHPj*l!hX"
-6JmdhVHPV,ReU#!Ac`dY+8$$2j8Aa@Pi8#c&2HqhT$P`,T#MEIVV$FU,EZ9FDLP*
-8BL9mX2K4)l+$[$3"0ipLMSaKiV)YcT9Ilk!YUCe()i0ld%*3l3eMQeRTf1kPF@5
-Qj1pcdp%p)M)ifSe$CPZCZ4i!5V&#JAaVT-!d`4#Yi)LD'++$P4!GD%b`5cVCTGU
-T9cIDiPe#3TH3!,9j`jd-aX95TNDUYNPPY922,@iZYEI-b'Yqh"iP!)"8f[a&p5q
-XAN,qd65+,+H(,X+959YFqF+q@AQ"P8c!r`T-#0R4MA!dJN'*6E,$q%TY6''+kb4
-'Q*ZDf16EUcpkC9,)+2!3`#U+AmN@VEm!)Q*!%[$+AZ2aJeQL#i)5*+Kp09'mQ*e
-#F2%daGZcjAA1VR)%9h2"ZH*(@X'%+"-,jJiiThbT&%qQhDV2V1VKJCXUp3!82YB
-re2QmPCQVDMp9p64p)69VNhBkKZNJQql56MX`lC@QcaK%E-+dQddE4+c%Y)p0'd4
-3"QD9)A!3H,[rCUNa$l*P)CBI[$8)%Q-KJ(ebij!!Df1ca,iK-F8"N!"d!1kl#ak
-JkPFCE'A(8'N"XTl9,4&,EFpH!I!VLTm@%2L'*dS,(S"Sf6J&!NNV`#""!-mXiI6
-CJM&!(A*2`@BU9YA#$QF"6(AK5#'1m1-JMYP-ZDTaIR#YiQ!,J%"CC3&"Ta9A%@L
-i!!GUHA9l'4YYIbHlS-54@e!#0p'Ya-,%,S#iC5$'e82NCH1lY6&Fm3NQUP$dp+L
-UT1-&+HDd!"TFqkEM5"djQNQ&#hc2!NdMlf3A&G+bqCZ1h+*#bPJ#-6-0lQ4MTXk
-qYUCE`&$d$VP[(3"j29"8P#F#VXrCDf4,(B#M@MB%lq@ZK-1S,2DL'BP2UfBJSUU
-+0T*j#,rGSh0S,YZf%EMe4&e+mSl,GeL3!&@q-qD4(CSk)XbMmDCr@AH(46H"V4A
-Em#2lRkL$`*hF[E!%"*'[k2V"51mJTNX)K'K#d5iRRHRYNBjAiG+QfJqRQbjF&4Z
-KCQ6$EF*VMh)(00AK6C[m-ArqPFM3p,kFV3i`1pY*(#'jVi`*QYTA"[8Be"FLTFa
-BT,)i@q#UjmU+iZ+kK1Ej3aNSb2)AU8SLK#C3"+'aZ!'99ij3hFX9d3%aHjZr"!0
-PB"pSb#dUbK&&j14CClKJHmQqRU,#jRRF841LUjqhp458K)%r343iU2lfX@UVFdE
-dLePaK4Rl*8FPU`5)4%h[aMQC),P&cF$XNLH*U'4D9!LRJE5!j*B)-NmJ6iJV"(M
-[mcCpJd"mS&9#6SRmCBbl)jEX#cC9Y'CENf!X-ZF@f[#cUENTZSM!-9@*[4eQmCU
-U+-q2a5998BikQZXHa%3&&ML5kq11L&i!4Sl)N!$KLZQZR1T)Ri6+FbkSl)!*&6N
-f1V#NcMU`T-UFYPC0fk!U(f3m&cCpNk(U'HefmZ$PEM!YAR+9Q'j!-dbBhN"$626
-K`#JBeI6#e#3b!&`1,,PU(9JmM'Qr`m8V,[q"J$&MM@[*eA*H4qh#hF'Q2&b-,[!
-5`)j6('##Fk46*T!!&DpG$[%Q'NbIZTBm5S$)#6eL(SFE4-M,TlVT1)c8CFllGc3
-4NkJBM4NA&rple4T-,,Nbi#Vd'TJ)A)2B'894j9EY`VY!)5LhN!!UeH@G-pDqASN
-Yl5Qm@,),Ri@0D9'%db8,R49SU'TL`R[#U&VM!JU,(kfC+&kV(J+BJ!+ZDkfDLMK
-clRB["cmY3(%D$F(Ba5[D-H(Pdmra+RAaSfSflHE6Y@cDRbED[B4Lp$`!eY0FK3Q
-JGKlS8P3BL4'$df#f(!J3!`*bd`("Ab#Uk89d3(LAP'Lk8`H"fX#5NMFY"-`3H@+
-SY2$[MGlU(J4LEq%QU,+1M"""-qN3QQjl#kDZ5P1&a66Pp(i1!45`*dFMmVka8)#
-D$-5#CJ+Z`J8pKCY5iXXYdP804c6G18PM[!E6L%T#GC1dY@+0TPXK52#Q4f6SiFB
-$2&Y!e2E!FCj8dS*$T*`pq$Q+J`dF2"UfFc,bNNG4a0qd"UqA($$R)M##Q4#C+#h
-F4-!DSZbSRP43k-G29#)9G1f0jTRkQSXJDXSjc%NP82[AG**3!)dLC$'U'Q"1@@C
-#XcI01%N1fkhC01`mQ$G)`hBUe04b4+HqCP&KG,+U,GIP,B5,)+V%bAf%#-b()Up
-G*hE(pLUMc3&6ccQ(+UeflU+L&qE5F8YEVK#&d@Z3!-e4X!c6cee,bp-)'#ke!+$
-[!KP[LJP)bqmQ!k8,i-V@8h#&JSp,f*1FL-PI++r+rFVa,+U3!%A2SCK+A5TlDl"
-Skk(VV%)#k-T+p9&MHJYNU8ZN%Lm+ZQH'$5S*j$Tkl6&5-B,e(K3R4`RmjX%kD8q
-%[CLaXj1QPB%SB10&d&&LdNFTJYU*m+!@5*+DH!&3E!8J@V`&PmLpTB@M*kkJQ5A
-%HijHTmmdm2BV-@iB!&83hB6NfkpSZM(`*+#q1k!q9(5"e43iSN56U@JZ98+a&@e
--&lkaVqd2hjM6cma3BqdTD,$f&-dXjiSjC,"@,fd+SQe`!+H'9BXqLR5#4a*DLhc
-,a+6,afD+0aX+*j!!mBTXF5TN81biZ!#*`2GDji`Y(i,!*`cZJ0aCPS18aN"l4m"
-Arkc6(qd3UZ!KZm2Sae$Yk3MP4EfS[*ILilC[`ZZb8*CcQp'QCDkbVc4kLAQi)r#
-pD"$-&ILilI5k,($DMZb@Ya--L51G-rj3HU*E8J@2M)6Ne!c`N6GGj6M-+54h@dA
-e*ClC(1fFkdJ,AEdYB4X609m1*XaB!,$mj4bRQV+j!2b[VDlC"r)*$ZH!q!bc6TK
-M[Z#Vkj!!hJ9$p9EAT-Z8$`*diBj24!J*HKEGXeG9"2GPDNU[GCSF!&jbjAX)[!r
-aUfch8-)L$0BPcV9L%"+Kf,MT!Mm5!M1U,8al-Hh$)LK#H1Q0GSP3`*UE9(F&V"(
-AUbj4aS99q,Z%Geh#kAZ9K2UMDIY8SDXRTH&DG9GS*E)B[VF$"Ab$r1D2NDNkFFq
-%5$Uk3KG[ml4d"ECM$pq)J[KJ6`,aQemp,mV%,IHNKG5L`T%@h*AAKkXVF(c-j!5
-CZ9$Z[L%YQ5mm4RpYc0jk`hRih3hAPYP(hMJ[6J[E'hYl)rfhLh&M!+pppj`(IE%
-##MiJpbIJP(hiNrZU1ZmLNk"#9FU'SfAeBTi49`%AbbL)YM#94&fX(GPUXfaMpld
--9m[Sl2P1Rf1qXb@fDkK%b(qFLma&BV0`Y`%eZ3aS2ZLF#rC)V(4rCXSC90ka[11
-Tjl()122l-rZaU#150KE,lFD$F!i3#rkI$*N@QfmlQB&&B14iHYCY@*MbmSJKN!#
-4FMb2&R9C@0pJ6%F6L'+M0hT"(%35X*ESKG"q!,lHL#[Q8hG&IhQ#-Y0M)0P
-d"8jMZCXUB)Sb$"b)4'r!kZaLNEC*lRi'KHAAhVApX-FFGF8pcZ'SDjr(UFDRbeQ
-"U5ki6)KB"Dj0'Q%1aL#C-N3*+D*cak9'8#YAjC,J@i05KI9#RGf()b,Qiqk$P&%
-q66)'-C``YhLFSZL1fF+qkq+2C6pHcZE'l#[cZ[eVi6,-c@-ic$cmC"i!MFV!AL@
-CBKk4D,UL2i[L4QF8Rf#HGp)P)9J88b*'M61j+q"rS3j*R6j!)"eZqN#1JfhTljD
-0M'!B4DBK9+2fQ&hU(cLX5%KAJBr2kAea,+DZ(SY&TH'b-4`C5`,&1%a&(pc4J*`
-QGlq"*U"SZB'Da3$ma!Kq2J8B1@iFUBj&ADTTpP#e)%2Ed53m-,3@jTU5e![!86q
-5`m!T!T0i13SMI2Qc@%McQIB#[j!!Ek!'Y`H#SQqm,&T0jm8fA0,M#0LpeD&BU$T
-)SZPeSJR14IFQT#X36&6eA%55SqJA`p@r!'X&XCciJ$-dF)B@cU#@YP$YY`rML[(
-UU,eLD$1FDdS46"D*D28Yle#L-8Pm"6mq,9`m2lkfdKA5*U2Bj+hdLJFk++KF&Sq
-#T@FePJVKiBcEZ&*kU[ZNJ*ZJJ%[4k89'V4rNrP)%C56HJ&R%Hp!-3f)cS9E([1V
-0)S$LYF5NCZbDjXGJ!0j%(BTP2mr33l(#!,MRb4@NZCU8DVT9MMX6P)PSmm"phHm
-FRZdk#8H-b3QR6qfjUckf5kf1Z+Tlp%8)%,lE'S4ENeVe1"VDGpG1c4)J*d6K[,q
-9*`C"4T+0SS`hb"6QG$F19DJHI`I-UUdBq&@&A-![9M1F+QX3E-1UH@"V8Eh!$hk
-&aZb#(p(Khh#RM@SFVM+1%0Q!VXAeMr"V2GTVe4XQV$CjAD*35BYhb+PZ(T&"39K
-iJDZ"Lq-L8',CGG`*84+*-X$Z'D#,Q[L'Ak4$r08Y5(cJa58M)**jf$8Y#S5R1-*
-UIN98p4AIV%qr@DMi"BlLX"C&+4PEe6YdD"irp!+rdS$FfYA9[!VfL3eL0kh'I[F
-la,+9)YJBUSeTJhqhhS$i*VGbC6h!)i%ENl'-E9*Y)dGe5MK%L45N6@mZGp-2)D%
-UC3-N3BLV!!Qc4Cr`,ZVbLEaC9-6H15JPpfSDN4*HPA`K*IILT%Xhb'IViT3Y-@+
-,NpNL!G#F[5VP+dUUL!E@#l2LpLJ4(fLi26%V$QFNIh4)p4-3PDqFNT,&PC*V**T
-H0i-jR61AkM-iT+`L93L[6K-lA3$@cCJ!)[+kkP0@*)@M#j[I(`2aY[RY@I(S)Y5
-Q)9@aIBSIJ6L@+'&f9ca@SCr%PRCe!4elD"B)L$Im*4Qcq@JV!$$6`S,J3d6ii!N
-iT%3RkM"PGB3Tke0*@BmZCmU+5JTTqK3JIEeH2DCh*H88cPFUTm3(e)G8Il+hD"R
-ISUCmi5HN02Z"F'9YEm"KHhR++VJ@VpS-bYS1!ACN1M6rE0AUfEi`A$f2AK1Z(JR
-`0TJV,aBj+DRNG6J#m!b-BmBGU@I58i58r*!!#Qdb4mR4,$,a`Udm5Gf),6!j!FF
-ap5rpI#)T6GLh'!-+8V%K%GcN8R@NGjBl1L3#@A4JE,p`p1CX5K1YNhpkIr3+-Jf
-*M&[$QqdmDdPZ&$iXTV"!SQBN%P0IB`'jVMG['S(UiiVQ3p4$f648S"m3)e0GlNe
-H4ep1*,T*p-M#2UKfei3LSX@5&QK[ZhCQj&+XeGEAkRpeL8T9*dCZ30k6@ac2M1*
-ci+62H`15iiR)T8JI+TCEGhM0Rmffj-c&pEj*8qiLZYKMdermHEFjlh@3!%!QqdF
-cNF93MkV%CeVmHNPX%e3km(S*A,X3m92hbR&lLc3P%H0q-4HJM9UD`X%518l(H,0
-paqM[ZH1DPYMZ`#YNCc(Q(hVNZ2EJ6$P1%3I(0BQ`9dY*$PPfP4V0UDRpd[&@kBL
-9CcQ@E)@B&PhFAY'qU'4ckk+5Kl!jN!#Rj#L)9#"$PY35)`K266`Lf[3'b9r4L`k
-@f40Y4q(8ZNK9[$m3FfMCm[jp)@Ic-MDEJUfe-P["ii`YD@"6"`d*'C(5%4XNm0i
-SSNIhi6pl0(U%,bJ4kXVSdG(Hr&'Dc-JjFja2*Ke(l6l(%53L$HLc!8a1kjJp*bY
-$#PCIHp'4r@Bp*C2hpj!!Fm[ZcqS$I3**3lRKAq`I1Q@Hf0dlf0rC0pMGeYFEi5k
-rA-MaV!YRQ*!!f+U%[-5%6,6e6daqCk*ciUaH$!8LJ&&HYR#cKBm[cNZ"c#M3U85
-5[DTJVcVCK)DbaSNdM+Jm,b)`!TZ8(5qL%j[&FM4pfSeZq8CUCYSZ8XA#QMkSH1V
-kKb+6Sa1485&'2%-TQFI6-qA8R&cl"HI"P12Tm(#@MjpC5QJ@@FZ`A9iJq,BKLDY
-hcl4Bb(5@XZFJ-0U$#SM!UGHi`'i0hpT9UU6JPP'5Z'C($9aU5e$C3e@U,b3!iad
-dDe@0))rPJM@E-MX1@bKa1JQ8a&hH$AAeN!0(*M@p3lcB89faPN&X4CMB@Llf%lV
-Z"'88,1$J9"-AI9N[qR$FILm$C@TTm3B+@K	(P9ME[V%b$`6aKR`qPmpfF@0"M
-f"')fFX8Y'X&Qfk@Y8c#&b%[iZ@+-0Mer1,klhY+MZJ4h`S!cY#I`cPR4dX-ViXF
-,U4$pk@$h+4K-IeX[4aeCmf8F+03M,dZ&NrT%hG"[4F6i$5Q+10SPHQ8MDc2lcHr
-hPDR,l$el!h5%6%0LfZH6Q)VZ)l9e)+["''Jij,c*FBL1r1JX9ACL)d-)P4hbSbF
-kpIE,Lh"Z1"@d-ISaC"kS%`2C%[!LE38")%,'2p6G1GKr9VZPqmch"kJ3pj1U#Pq
-(UPCDaiMqEB8E@+DGK&UMjLb"KKfT+kB$@4K*ekQDkja41JG4-QabSMSUP0M`iVl
-1'EYf(Bj$PG'f[kJYK!*)5(1[dZdDj1FSd&FY3kBF[ji5Lqi421K4`ZX@%%dd&2J
-3+G-FVr%A+aep6hq'TY18Sfrh6%I)@G%HII-IhJmH$99QHj-1$L0TUMU*aQYp!00
-qq!"9%*YT8-rih1#pR0(dPXhh@5(FI0,*@E'JSLG1bB8GV`(iqF)dD(+$XEl&,BP
-bfRLNYKL1B-2,F1b"NEJd5DjY3h$[P@qdAB5JQ@Sh06paB4G38$Yhm'Kr"K&qM#+
-m4pKP554ca5"KmdELA%`Th2SJ4K,"0j!!3&"j#"Q"8,kULG3%TYG42-$`%YH3!1%
-G#+MGGPm2("B,lX8@e0`i@L6"&A8pFDlDebJVieB3Y!E18SF4kQ*Q*!!ljm0)c[C
-fpNBQfLVE#NAA,KL,4erTla'1E8)MUGiqpXkNDYI!E35dF""S&i#9ph[LpK'j691
-A3&F*qU,V"d5BFTZf#Cq%b!mN405SI#hk!QdK&8!S,IS(2kq%JZ$0""5'0U1hr-*
-`13lhp3j1R'SET@1G%pr"dH'TrYcdc*6Fc(4C!k216-R-6Fdm``@U#3bf6-,P%Mr
-*Q*Ub3*&S)2S1%Gk5-DmTe`$JApEd4VicfMdi53X&3Q5XF$5F4S8HL$6#82KG'M,
-h$YhHhcRChbF&0lL!"F@i90$l6@6U&CrJq*[e+D(CY2JX2I##lmfC-d1m!"1aEF6
-#,aKR!4hZXVGNmDMd5bT%!KXTbM1Kb"B8&r@'3(pTX$Xbe'Y!30U`8c)-J'39,k+
-3!+KJ5&IS1dri10,EeMXa'AE35NPAr46PZqYjK4KeC)P1*cQ"G6E2-f'!50ASX[8
-EEqZ'J-&Z6@mRhhLaqIj[N!$C*%H!J'3kZqXGlMHTS*C-b+p'9UipY1H[21LK5Z(
-ZCA!c3l&5JHD$'i&'BiX6k2l-Nf0aJ&*[5d()q+F'+#,PaYQ[FA'jDVFf3[faQ)R
-F9Nk(Ll2bLN,kG-liPHL++em$#'JSlrU#1pMeGZAe3$IkGi1Lm`HpU-+h#EHYc1Y
-5IHMdIFm&9eNTBSiMBY!jKAU,AX&8BCYkcrCh5X'UK%F(LZb#"UVbpG9'dC8ICDZ
-f8l@S0kGM10MEfFH2&9&5*4iB66e&aGYH4DFG&J+XM5SCf9dk&aIUNDUlSYp#H&9
-2r-ek5YMP!0$"LdJ*26X[%"H*+9lF8Q)EC1`8&40`ER)4JF4FEa9bR%KeY6fF'4H
-qqCRMf0-cF5bk1k`)4Y5p#1@JQ8*A)E1JXhQq39PiI3b)3I%4$9h5*1Zb$DrPU&f
-,%LU9Y`L-r2A'MVM4fh!S4hU9J9H(CIIR&QafP+VG4!e(SYla%NFrmFP,@Al1HM)
-@f[DU2*9[X8T1B$lp&[CjQqF$)2C5Kba-56fNS-)RSIaLA1$Y3IBqSQ`F4C+qD*a
-#aFZ,aP'U`)3q+,1+%de!1AjRSUG1paZ6%mkc-Y[Z-,pJLLG3)L5QN!#9DZq*4eq
-M6GURV&0d%!639JNiP#el"#lfk#Y0A!cb6)hKB[-%A$&B88b!#,pq$bN1bZIJf%i
-H"FZNLaQSmc88a5MkB9C4A(CKT@8m$VD4F15NMQq3!!9fE`qpAXQC1hJbjCd5NXU
-YJ8AQ,"p9hL)6iqQ*@k0aRjU1RQ2Sp("8pR63"D%HYdc4pKU20VL8kPA"&,$4S!!
-pf+,8!)'b62fNZ&'eZ[i6FR#-@!i,+k(M*j!!eQ#f0,aVS9ka9%em205Yq4c8`[l
-1XpfR4V8UT3!e"IFJYHQX[)l!",[1m4)9+hECFHKT@RLX"($"YHUhJ`PdQ2AdNGR
-m"6IrXrD)V[I'2c+'pQea8L"3p"P3i9%p$1H4d'i5[c*KTQjZCVpm,`QRkL#k3fh
-ql*-MA+Mhm*MU,-5L1bj*&#G'kXJa19bN0$Rh-NcJ'3j))1X&"3JjT$mM05J#02'
-KB5*%%c--%d'DD$4-H'PL(KH1ETk3!'cXQH@ADij`FTAP(4j*(N8NA6V9UCNBZVf
-hFc6bZ9kChb"PUSNF8iibUm+9HAm*8fC9Q$,lp-UmrkB15CRq5XVdVe+CIP,QM("
-P$NU#H#0LG9@bb@hLjXY@(kN4jM9S-#m$mcXF-2GX-3$QP`FR*NF48TN@p*8pUB&
-AR5Bb+jIk9G0%bp4X9fkDIP!c-3DJIdm!%e-0Cr-L)#bie2I%i-i)pa`"iS83&9M
-m&j))qVb!0`jE1-XQibTBE2''E+TqN!"XlfaXQ56kDDRD*N#VAKm-V[C2ST(GLfU
-qZh2h"!2*898(rDbELLJ9,ccbfKd,HH5Y4-&2Lf%HH5LL(cK-N6Il@,DK+[G3B@2
-P$4XL#k"`VC8+$KDmk`fQFe8UhVicS6%SVNK[2Vbc$&4[KG3`5+cMKBA(ZJj94b'
-T,laUBSLf-%56U+B+&H"&PQR`J1#)Z9PPHpU4EGr0`6!A-VD'2h%p6Ff#,TVbSb%
-[IX%V54f4,ZP+HX%#9RX,YSbA%K!h1)lM1MFh(`5@QbbaqDb*8H%B$+pSl91X`15
-Gh8R0m*kiT"DY-8%YI`Ze-*hdpdiDi&K%cdidi8Q)'SN-4r9%4@6)l`H`,8Z[8'J
-A@lA03$H+G*T#mISmVTV50QkMN[TaNH%'IpPhMKZ0&h+GG"8c""5a1JX459+0ZHP
-5!Epe$-UMcBa4X5`"8XBhQMTd[h%XY+-#YJK,)+B$!bq-ZA-4XK@E1RV3"4G%64R
-p64eN%YX%#CI!Ih@pJT`aa-JCHS18'VNN#NdK5C3%*KP%m@V&0m!ER33#-d,'N!#
-@N!#KVl#MK$MN,%HP[A+e5VX(9G'SeFp!X"+JA+(I#*Ul(USH8@&03Cea"I,DLJ9
-A-Yb9))*M)5@!)J"!CHZ*aj*5d#Ne8M9*SJDd6@8'jNPBkaXB&HK!%T&,5kYDhm$
-(*Rbm8Gj"cIbB"'`SA!Irm%"imaq!4$P01Rj"#bl3m3YDV'U3!1RTTd*a89+XC"F
-0aeC+6FV+E($mf%3-KUENGrZ(9Y#5C0G'FHdi[cCU9@X0*FLZ8XGD*)+B*2jA965
-T9c2)F1@d$eFTH0d+"#p5#JD`X9VENBP0DX8QZC,mR!cLCQ)VQ0KNR)[pQTSQpH!
-qM)*"qdbB4kY`$dI4!%"*JYA#a`52-i9l+V2KNL*L-!#S2b@&-rL8A65&LeVj492
-m)Z8P8G(+,[(%+J'$dJ9IIi4HKJ'LPH'`pEYSC08AlC`HIY%(fSdB`$h@c+jaH[J
-eIPa$48'5LBl'+[40U'GQdi38N!!1p3raeK)6S0B')l99L5)bmCQJ+4D-&1L9A+8
-AKL,cirkKX"*c[93`[QS92&S4VS+&r*,95[reZfaUeCF9bq'AIFc9EDKr@E)6'lV
-!S%3a&G6!h#r5a!(K1*YM(hmekK2rFp+2K0e$NDTB"-1j'He`k!J4Q,DfI3S*11a
-45[Jp@M8kG%!9Xd@Z4+T',id1aBJYb0N%CkZ3!"+)lklD6BaqBYapDII3p,0j"(D
-fb&8f0c+c&!P'9YV'&%JG%2Z&c4hTE4M-%[i&(M4re9i[GpVPLC!!rZHNm+ITNb'
-"FPF4'!pd",S#Ji(4`-Q!-E!RF$N`,p!8Q"ji2h"(B'1J0&!B5SBmSIE3TT!!+D3
-*h4[+#Kd)eB@q#VdBQKfU$pd4fKJU$48'Nm(aB%H`+cJB(!hDJqR"Sm'&`GTJ3h"
-QF'j`Dh#R0q49Ha2H6Gj"lkMAlNhh([A@H"GiArI1m-laAZ[Gl0hPpVY(h$Vh,,I
-C[GZGi8ja@paAhBqi&lRVhAHiRh6[m[Pp`ckGEjD[clIEGpjh`(ICYm$Ai*[TQq[
-EkYYCjLZE+NZ8fFS1Pl@9R5ilAlDrV+TXH9PefHbbqV*TC6HAh9Hfbarb9rK(r1h
-q(Il$ISGrYrrN9+(i"ra8M6iE%f9f0Mc%KrPXq"SI1YM`Th`iaSBAqE#($ErL3jN
-0(q($&MDmN`qpE&K03pmZ0UcP`meXq#)IhX5'Ar,Kh@ciVhci"4ZqaBF0E0M-Kl9
-Xf-5(#pQ`N3q2XH%52NaM`m9mH)i0AqI$%fbiL!mlfI"Y2R5aiFriF!FErT)2@pP
-`0Km1Xq%,I1KR`qNdG*H`iIrQ`iIBF!BI2Xk'rmD(FpR`2rK`*KYq`SF[B,N92aC
-5kQkD)J838`0R@-L'A-AZBfc)PHT1Bd1Z4[FjKDKD,LUI-8J)k`hJ0h`iaPjb"EP
-lf*!!4i&ECU+UY+)U'!0AK&Z`)BmLlc1-rDIk,AJhXUZ1FBBlf(!q(ll2f1[`Xi#
-ccfELH(4iAe5)Hj%c,&G-r5ZIXV!Mh*Lm+@c))m+ESEMJ+'H2++BZmLQABZS$2N8
-+q!NTM`Z4&3a,1)0H!G`-[AS&m-J1NJ+QkC8AI**YGaNIAXZ'cr(K((E`(rP`"K[
-bJ"9mR3fjq3BA+&#B4bJ%,f2j(Rk@FiBp#UA8FBBXaC&MI1Sd%mN$5l#0$EN4"Jm
-VM'8CCpr''(M!$UjNL(1&"09Xq#`IKYM`EfNBfSRP2qX4#ch!KLrai6@+DekLDd,
-[+DB@mLPP!(L%6p8UTVl&TfS88r2je"l&e(rbU5b'eXrjeIFbKZrLj`TRD'--A2Q
-K``a4(M%K'f-r3NE2f8N"Ib$ceaYe++UimYpS+P#LQ*V"TcDcBa5C4rM8YBSTESk
-"paA(lZ46qJ$!83qmU'$J84pBVTML35CJ88`em+PFYVfMA%L-$Dr`BB30Mr"K(aY
-HiX0CE&M(KcSfr*J24pM`+Kp'fI!$'SSL0Vc-Ke[BN!"(1dH0KJ[jm(UQJLp*qB5
-Xd"H!h'6%#f`iM`qAXH%hqA!q'riR(k+,'[%q+bMfB[&2V)JaXJ&99aP-Q963jl-
-A92#dX3'*FV%"AEQ*(5"$d,%Ahm*JR!d)%68E8$AURASrmQcNNJ5Fj)P[fcNimb`
-Pl#@ATE#%dj58+N5*N!#mGNU%b!'BQ4b!ZH@Nm,CTNe'2`h0L0(JqZ-"VN[i&Cr2
-&L,F("cY%J"qYjNIMk"6['Zh4k@+"-!Z0Q)BH1kH*h5*GR"HA4D0i%F16BLD5)4c
-!FTV)&FI%#6&(I),"FY(!*kH*qF0MiNj5,"De@"c&iX[B!AaHM+AMXbb@Ldp6l$`
-qcE'6q#b*RF$RpGKZI(i@dq$c3Xb"crq1pH(c(l($q(`5km+R2VB$RmpLfr#C'@[
-(jrXa'CmjX4&m2Sa0i9-BUm#R11E(jl%B[+c95%,T0LXf,B&lqdk+N!"1#qiY#m`
-&@2FkYP`(YqfD`-eLIZ$$`,@"RB'YJFf"dY"+84hb"8T##&LL+E3b8!2!,aTU%3f
-KP4KD4,ei$UUi4X`9'`2ca@C4,,B!K23(21Kc5!lS`'3,Z!"-QJ2j!8hJZ8"ei(`
-J"U!bM3[i!XM#!6``$iXM&$La1)S&+C'##5Qa#JY5ib%X8V!iKX8j,&l$JY4BKm9
-T,(j+J41,+eL3!"S[B@(#!Pd-"TCLm6%@T-DV@(4Jm3%@#5aU+("LF4',&Lb@Bj(
-%iL8X3PJX4'5@B2'h@$b$a9GBh)I&GbP`BM%ILjZ`3*HEiJiXjQ(a)4EIT-#*a50
-Bc-$L@eM-aQ)"&SeBr!D,@LcH`S)8X!J,8X$Ec)LqB%EdMpb)rSNEdGhFL2k&'p'
-eh)LZi8Ed"$HL"lJ4hFq0D$-hSYpb)lU2'p'[Z4%pa)hSB@j%TGb)rX#0k&IFL*l
-K4[3eEN3lp8B8p#,Kb-rJeZj6MiQ[5blVS5d+`eVZV+!1"[MJ&5HDpcJqMB[k#4G
-eSej8D!C%,@HLhQHLPLP%(A-Q)-V-"lIb35Yqf[(6JamNY(,+-4Y%lZ,Eq$EIaU0
-m'b9m'p[j0JVij8AmFTAfmX1i[*PGrZrXmJj-@YMN[l(*BIj"JNeNDD1i#AQ(@j!
-!I'BV%MK9SkYUS2VB*Bjb#)QmJS5Uj58Nd1UBT)H2G(a1ReQ6KXrS+ITi*JdI-df
-*'Mk`d8GFTQ0LkmX@cYccXS@rp%XIVS`2UGXh@JCA1M2iBL-jUI'$,dS(4"@1TqN
-(H0AfXZ9l&QF+&r"rRI[j`Z2X`DZPB$T-%lFm!@Bbm(USUTSCkVmb3feNKVUB'@S
-$-p6Cc&"rb3ae1M28Rh0$IBiEkJaZU2r!$I@IZD'qa`heapa3jh*$[BXEkKhF82r
-)$I9kEUKriSEkhcb+Eq*4I$12i[r,ShJMMq+Y2)Vr&irL*eN8Rd!drF'ZU4a*d@H
-&H2fSFaYI(('ZT-@ArqK-dU+f'TRH(JMC`XAqPBYpR)[p#a2ViadK#8AA*8K-car
-")T%+3#B3+hNh&P&lP,Nh8I)%'h9h)KdT1%E1Rkh-%B3bHJE1`39prM[Ri)lq#"*
-demU1fV*CP1&lEI5FU3mGYIQ-dkJB3GFpIHLiai6N-4hLX-l#&chY&NVUMXl0(d&
-LH$KH&ab$!pJbkQJk*&502&(kE"Tk"AFb2eBGJ[#dD+jj69()RR,GKh&06j'hVFF
-[#ZECFJYU%rl4)qPVRfMQ5G1e)TeH*0&[4`,'BqCkUPM-DjcHrG0L,DrN&L`50Yf
-LJZRYL`TQNaUT1YHlU&*@T%HQa`P9)bF!b4QI48,0HEN*U2&DC!+3!(-SUEF)"*!
-!(c@Kql&BK4cmed3V%T!!bF%lXC!!(IU%D3`dN!"FaTV`+SN%b'V6ZjbiJfj[H')
-U2#DM9G&C3p6[3E3K%pc[[$I"ZQf)H9[HT`l[d&P--,&fTX@q"3kZKekYbKI'H2d
-KqdkmfS%Z*,ebk,'k+SXF-VY-,LckGIdhrV-ZqX[h-kENQH(rIRChjN-J80X-"L1
-2j5Lkkd*d*+Q,-(SJMEkM,@h(6jZPlLU3!$LeG3+G[lhUDUh$`-m(4e[Vd(e60!F
-GVP$RL0qZbqq@(HM@"4ePmBRcqGfa)QR$hmV1cNM2cRjjachSi1Z'HdiHcmM16%[
-00**riq"qUI0@l9@H$48rAbRqlm)N#dQBP1#%NTp`pY49XUGe([c2"mmI,iGTL,J
-idil1J`Z86*8fa6R&kJTXkIcG&"Lq4EVVH&C@6LUl4N+UTBpB`e(AXJj*DYChH!)
-N9Nimr*2@eMTNa5$KkhB0SA+L1mG23`N9C8G+G)J6)SRC,"hPRC(id6&%Gf9@5Ib
-d"9VaYJd3Vj11AUIidGpCr1KeLrqAKr6L#m4kL-HV`Q,T'1qS"4dTj+p)p(iQHNC
-"G,e%cbJi,"d,&dS&"K,lI53DRCl%4f+C(+KT&VA26iKDZ4p1K5ZI0iX&Ub(3!9'
-LYBiqB'V&JpQQT'f@A,0LC1"iV#G",bkC5iHPC*jk-66%G9155bm81m+c9TY%,9X
-XSm@Yj*VA5%Y#MaeD`!p4eh%@L4fCY,LQm$b5ha44`FXQDr&`U`9iI09)*cSdJlY
-UNB,Cb+Xjmr0JNkjLD0qREkJj1U#NT+04e0Up*Jcia"5kJe`3D43,IU44U5BEH40
-T2TK'l0a35MEQ8a,a'L-p6'@RqC`@V8*pKe[i88%)8*T&+"8b*U0ML*ccNFcN4ZH
-Jj%iVPZAMmA&)[1N`DhL'lq)5**AIAXHFlKq#@9SdB%'QF!6+jae@5Sb2&U25@%N
-2DQ&GJ,&U(dlL'A*Q5NT1LR`K9qj05aqmN!#9fCpV2*JqQBkAH8ZA%S[Z)b(H3#Q
-`G+QfA(VMM9l$ZVpE-G*Qe$$e)8Q1fUE[XUqGh"q3!"#JA&AZS+lIfcY%lA5`C2'
-1i%QjLGZT8N(@2Mjh3G'dZ#JTHKPAG!ZkQ&[(PEfCG6@a(0dG),%[G6!JMT)JKH*
-,p"d2@YFTe&kb!V8r4*Qe61epA1fl&'VIaGfI$@V29kKpPelYX[3302m'+$cer2'
-8MQhbQ3X(-V262pSJjDX++9Q3!*4"*P0hb$9`j4l(`qjQ5JNEYTIQ5mK59b&'RR!
-+L+efaDNcQ5P+b5a,5-d69fNcNpCKmkjf$L3k4eT[id8$3"d1V%5Y3CiS#KRXFP#
-[!!P3BQ,SH&Hl-+UQ8aFV(6mD8UQBN!#9*)3#"R8jT4Fc61El,*P[Q%#!)@'C@`D
-8d,N$)F&8iGHVSZ3j548P6c*9Y1K9)623GRh8`5lfKfeL"cT`iLL[GQNIZp6i0lR
-8%!88N!#BXUBqlqE1q3U9YmGKqQU1S"4*-EV+S$3)5L1R3%PPmTX*6H)#XJ%[+V[
-,Sm*E2m%l[Z9*KJcGjQQVJRCd,1JPTbKdM4XeRq-GF)p6*8#AVU"+UR5"SBS5J`k
-4hffA"X2jh5K3ND3H`%cSiTc`lKKjN8+2A[A+P"JqJ%FlqT9Gr['XiLEK*cIPmUV
-2Re6VUdmaFYh9*`lei0$*eMT5KZaJ(Bfh5L+qI[Nk0U`A-X*958@9Ile"M4QL48+
-h%T!!)@A2Ca&D8MA+A!2p$,QNS4"Q+TmK6NGJTPEUc,D'$*&9aBU-BG&",bSIecI
-rC,rk4MXHdUKm)@Z83b2Fia`HHiPbdUU'`%e--"VrqJB"KP1a+!G5&dXJU[kBi3&
-l*##r,Rc6US8V8&5&DAQiNK69d'D&DQ"Bj9r-,QJ2QeMmlIQ'aeF+E9*(rM#Tq@5
-Z6RpN#44aHf`3lV0TP%`'R6`qd'SQJaMSTSS'"N[UYr(UD59RiP1&#bR!8XFbhcB
-bK0+S)6JZ`KU#84b"%J2(U$')kLR+#ccDFY+`AIk!6fhAZ+d[@9m&`eId`,2q8Ti
-SjcB#*TN+1U8!Ji++"9i@F0X"b%AP&KkFef#6(GaX$["Z9R9KL%P"f,)LNbAhLYD
-D&88(SMKB[iJRqr2[2V,F)JF86&%bjjBD*AM+NdPMdbPb`j&-Efe2$&e%1T1*Y5h
-A6&VX*BN*Z6r-*-p,P4S[T0GT8B-+9FG))@G,q3X+,N`KUX2P+d3ec"9#fapAGSj
-)#'N(%26E1KkSp+CGSVq@NSDU@JbA%ZL"4&%E+6$S,bqD@IlP4I2SFR2H6li[482
-49M*[UA2jpZ`rIc%FMVCSU)bfQ+j%@m4@B%+E'0V[-q0T+3pYI66[U&'UFDj&UFB
-rUe&a*YrE5+,i%0!XfER0-2Mk[BE"eeC@,[,RUX1+I)"d8T(rKhRAU9ab[TY')U6
-L@9%!QDqVU'D&XD',fM595Z'ZYVK%T`@Qd,5"mp494A(H&4BBG&j[dS)0KK@TdX9
-PkXV&G1%AUdfp[YV822f8e)Qc%[3U-CGAeFj0eeHek#CY[DZp4mHPSkY(1"jBS$B
-8b4)"XTfk+@fCAT84D[HL`kSCfapT&hL-ZRIkSIcZM!J9`qhRb196$KU-GAZASVK
-E*aRXpU[DJ,41B[ZfjT8Ki586MQRdKA4XF2UK9*0Z0C%P$bK%XZ*cqjK@*!ZBZiV
-d)T8*h282Q99@0P*h@3d!JM*p!),3M'49$#r1YKpY9e3b8L@arD61,%G45E6`LJ-
-A8N96XSXB#CKbd'2'"kPc4`Vm*6BC(3+LmF+,$5Vb`AbjI6Q[U'4qe6VTXUrI9dj
-9GEZb5T!!*@3"FSdU3#jPmBdQA,r5c)%%J3BY"**)"U6D'#B1REj80VqLDa@ZB,`
-l-A*2KaYB)%diMZ@-@j--R29dAU31c*bK+mpHqfbNkVPMH8r+F#AcTPAZYS"AG'Y
-`B%DJ4#Gd!+TEfcUQfYdcUM6G*p&ek,A,TeHP&ZZ#mjGc9R4a,,',p[EN9kMiRhb
-@QTm')&S13RfHm+i,T-HJpJ"Fl5KVki&,Eh5E@pH"VUDKp[R(5$N05(L988&Jr9G
-)b04@CJ2ap+Y$FXXTG*rif1*YlZR(6UkmpPP%NjGG&HfmQ2$L-6hS8)k-2(8VM#U
-+4jZV$3mc03$+h)M819%*p!$b#8hhrX"lMB,qH)(SeMS8j@3HDMQX)h0pKff8H!2
-'9a9qIEX!dF-[0AcXJe*LeLdqeP3qcj[+KBUQ-LGe+*V+'BUQFU'fU4b8b"-6$pm
-iLQiSE1Jh#@TkV2PCS+S"JXrK"eh5THP*j4HSj5cEdBD@-h-ccXJ(Fc26M*QTkCN
-C@ErI8*)&+l+J%1Vb%-TdmD'kl4b'ILZ[SLDTLJS$ZhM9j8Id460mY%6(TceDm-0
-!XKhQK(XG&ArjBF9I1#"U%,Y2DY)45D)kV)KB*&8GIr-VT+-mbk#&AkF21[l1LbF
-U&lPrYQX9'hYZa9G3pfSdV+p40Yr+Qjaiq(UASB)0UqBI,YQS''a@$+k4M[jT,2b
-SSH)ZILKFe(DK'2J9!ip#E$%*L'ZVld"22RpXIQ!@,F+VG#6Ii#Vm"C&iGi#)e@V
-R#IG4B1r!NEi6hAKUqMhiS@%&Ef3N%'M1)@JPH0"#iJY4cB*5Kjk8)+Rj3XkCl*2
-(cf6+pZ-AXN"`)N*6DPEQmC69!`5Id"pBZT5G#!m3(!bk[M5miIZVE9+&rX$#p3'
-$(TK$)XTVT2l+AVQCL53i1l346SQ8m4!i*1$h(l@S!q@pQ+Pi`36FS`Aqq4BS5Z)
-`8p8L20Da%!mD$b0q-c,bMR#8$D!ADe#dVJEB1%!m$2'QE3SR@@cE0bB,l@3Rl`T
-e"MTiFe(Q(FLE5)U%!M5%)V!DA@hQVNKPP%A*(hc(0fF,fa`5T@QlT@(G2&"$i9S
-b-'+)Nr*Q&+($&8-3d3G@8`[)V!'HT4!LJ%',kM2F[$6DL6YNIhih*fT,%c0j`jf
-MVChm3QVf6RdLU&ZCqB5)rQ9K)AA++UV#*MGMdULF+QU4!NI4$UimRMaCqr+F4#S
-S1Ra#HfA"9Vj*2FZ8G,aJ*dHN`J#DN!!T'KV5P3SaG&)C4Kb#ZYj8&#AUmJTZ,F&
-QHp2US1Z+#MN1V#!21*aN4Jp*eT)SHAFKQR,*%%T5a4qb9N5U-*!!5"3N[(%$#Fm
-S9LpbYiF9ZC%QhNQ0IcA6RN,41-)b&-Xe8MSfLH0fkY6'6k5j969HU%*mSNj2%,f
-VAX'X*0V@Vc))DJ(MbN3R42fl,0((BPADUK$C%16#,f&NSB`9NldF0ACrC2(2MmV
-dSej0TCi0)M31'jMc9m5XIiJ%-Lf3!094B@hK'5#5Dd!dM%"3LG5U*8`V!I52K"G
-UZ"#Q!UkDm!Bj2k`Z2k+)R2I3i*0e+b#Xk6GA8EjC86@k[CLUd8+rBU"@$)55F*!
-!U#RAG$GFdBX,G#Y@Y,jj,@CTQpH'$4G*64J`,#l`Dl60l`*Aj5TY4@LUdPH98EU
-H9kZ[qfUH#(4+bL,N$DlG'ZU8[jLjqY"4)NbUf84d"B'Q-N'i[)KJMb2!jQl@%LA
-eei$BUqNfA++UV8b3!+KmHAPJS3%Ke3(&&KAAU"D&AA2hDNFA&mLV,",d@h[jPh-
-9e@JK5m4F5*8l1p5L80R5X!$eFS)+erj9&QND6GhUL"5p@2kf`T9AC+p8e6#e&he
-BcRDl9U$!UA+feX&HGLQf0PbT'(5Y,UbJG!@4F@mBfUlV3NqTI'A9[&Tf%BM[#BA
-6QIcb'fh#UlZBZ24Z[r#fCqX-i&581T6(G@%&@9KNM2e2*H+BV&ke-C3Ab9*#Dri
-J,dNPZY8$fBUL2c`59ad!bJpii8&)pIi+#+JH1YjDm`TB+5YJ4@68$51ldKpmScb
-JQNeGr,e#RG98ZX5kVPfIM66jaJ@1"$lb5mT($T@*(UQ"J%iS@hN(eKf"QijZ2E6
-0r89$PXMd*Yba8+YE$Y8F!H(r56NJGBPQL*C@1Rj"S+YY'r`*(k0+68H%"*diUL!
-)Fa9+V,TE&iPA296GU6F5qqiE,#0K*#diRC4AU'l@9m%Sd2G222br2L4AQ0pZ3iA
-Fq[-j)(TZ&KSXKQN5JfS-Q'Y@`@B8p%RR$K`b%A%6VmGPhJ4RcDYaBY[H"*!!ZC,
-leZS1A[U+h[,r+RfklS'VeTN,UGP%&MPjd*lpS0k[E"0j&@5RTabrN!"q"Y2C"XH
-bX-eXIAqp0e1Xhmc@rd1E55eh-kRDc4K!)b#fHq,KadT"N!$edN*6PeqAL#6UfL2
-dq+',rr5Z@5`P02"!E%`!E3rBVY+IPi3reFE"(B*SLh01G'mSXMPRZ#I(G5Sq$0R
-6Z(irA8q,F'6cPHJQT#N&`P''F24h4IM#li)`P,YaTU6FM62A4lNEcrmjPEY"KJ$
-PEY4)bYfS@9rPFS6rE-TG$i6ek#ESFTCK`UpPB'+PDrQPpi4Gq[IXdT`c'hMKBeI
-rTKHZ4b'M[p$djbNZ1%*rTd4Sd`d53T,1ekHi#%IVce%JV`pDUeD@fNVG%(BHI#3
-M*r["#aQCZAT*ADRT[cGQJR&S-&ASRB%mA@`$IFL-#V@2$Um41cc"&2HF)`k[ACk
-eKTceLD3Z#qV#QC'KZ$NA2CGIMMRVZq@e('DEZ'H$LVCCCc*cde0q(qD'V5IhM8X
-AEFHI8P&CP4``NC3hjXa-Kirala#T3rpIAV[#,I0VShLD'@A4)I,3853qDq(5M3M
--23j([`I,LF%(+3VT)@qcV1LbD5J!d!C*$Y6m$d2!3l"+X`ihq)AYKrK6YZ+5U25
-FV*`(-e2+Nl9+89[+%AA3D&bK+&idH2QMELXii%TrU)"a@#+j4Y1%*cM(S[B5-(`
-#)RAFFFeLJp`,CmS4+CR2$6CTLSM-Qr+1RlRY`8T&N!!mmI!6ipbChDFJ2C86Y,k
-V$&RDLbJ+b"dI3AHTV(lCFYIE)"M!LIh!U(,kFqf,rbUArEmDbQIIHk)bX[FAVJq
-bPRH9f1ki*rYXCQjQ#U`U05FM-h9r1M"(f9P1J8aAY2jCVNJ0[i,!D[bK(A$L!J!
-m61Dr3RFD)K63&DqXb)T6%EfDS96mRkT*CFA@+SbHq&06bd0NDVd3HAi&TD%"$id
-8T)")P2im"'41@T!!!%9&38%GR(Mi[LaU"Z$b`+U$9#SVAPFXkYIPL#S[51P&SB[
-bJaBGq2+1Tf9RCHBkdmpR'dU6X+M5&f(&",`-d%-iLRY,9E`$6LK-6Bmhj3ijH$`
-!$jK0XTSD@!`!kF%Peh9"C1L#T+p6@3be06Kf21["ilmrNjfEJkl#pkm51qP31`k
-KhpbF$232YNTqBa$X!f!rQ([Qr!9lqLS`Zk""(%Ci0#)J6XP[`d$`CdpJiH&LGP!
-KNlY+#AaR%@i-6&DjSZk"U*b$k4XS5e41r($r94j)eHXEA"H%*9[D9%iJA5p6HG#
-JhTHlHpi'X))r"Z)L(KH)2bI#+rq`S5l,1r(I-Hr%(c#%H9b(B6aBVQ')p61-"cI
---"lF%-0iX"c$U"`&QmpTSk$`Ea!&LS)B!!!`!d&%3e)$!&D`$e8,,#N!+Qec[jG
-h@9G%A&BL)U)9%G(8M((-'%IIppepbI2,b%c06%(1,4J"`S*QTXqlZ`)LRXh8'M1
-RF4c(DFbDaM'RS(%FTm`m[aV(2$HH1b8cN!-MT19qRJ9F2(I6I2r[ZVl[ZmlcAGF
-&'ab""%%3"%'3!%L+C%3VeYA9r@Ep8rTj4l$i&@M"-f#1`jb'k3V$B8*K,X0dJZP
-lX-ec+UE*63K"8H6*hDGbXi0(@j,U0%2kK5(Mmp@lkQ3M%$f1re)YTPmRYG-mdLb
-M0RSCIdmp3"mRcG'+T$ck)1P6EE6d@f0-Y*R29'FB*G'2m6qSMp"h5BZdE#QGPL3
-Yd"kAPKU24QIaa@ST68pk3hYDqV2a9(3CIdfGBRLM$r+TDJ&05jUYQD6"aZRS&qV
-i2HUrkHkNJ9UPG)D'*0f[h5NpB2`cqL`IT"kPQU5l003$id6d-@j93icbk$raSHT
-YG%G5X(CFDU#8T)He2G*$a[24qrK`GB4a+[SjIUpkNKj-'URYPqBD1G&lq6IUEKU
-@0%UVPh*TIY*#lC!!0-mi('hKN@SR)c`kUSirSbE6[j)kDcZNCZU6p(GYXr4()bJ
-kJGqZCP#rT,pUldKr-r+M-rP2DRpMBr6Vr(GU%rdPUDr@+1fLRNNrehk8AMAHMVl
-!HkZI'cHMEr![e@rT0dRGYB[5*iBl1TEr9pe#rdKkAdZ6)UK(dSGDM25$X5QkPIG
-58qPbdUelY-qN!FCAd5[j1E@EX5*k&Ap#rCkH61UL,CGH0VC&Im6rSqkNCj-kD0Z
-PVG3qk4AY6DQMm9EdDYj9$6@14'rJep@eG#8T6&XMVD1V5CHd,k4VaYI4khQEkL*
-RdRP0Pa+0qk,MH,aU0j4S"lGC9-QQ*A(0)YR3p$#8rJE*0)i1d10dJQj3R9%Reif
-V1e$hH0f*1M*lDJ[c!NA'Q1*PmZKa"e4lmBc4ZVEDV'X56,3jML2Z'UGVc`GdVE4
-BefTKXQ!HJ4N0T!NG#cV(`93#-f1-bcjk4Uh,E[!mPch!4l[XXV!(1*!!ii6eF#`
-KF)AX9$!I%(DFX'2BhKQeZZD"C+03Ya6UfMKCef52VTQ,*52k$Vl-mXI%P8%a34&
-T33Q@2dVfVpbaPZEi$@j,3r+H&bbhfHmmLH!mEP%cSL`*jjSb,9rp'1-1HLGQ[f9
-$C[+TrCC'LeYV,EFmGhL,l958B'TVbScj-HB8XVcRQ,#`$HlRPZ9Pdl,l-S)XQI%
-@06E'hC5Tr+p!RGV*qBdE0bd'pqMF8#f'a@-a*,Z(d&0%G'JHXKM-@MbUc51ZqJS
-Hc@2Sh+0D22%'#Da(e3`2j!Y1b-%3M+Laj-%!aXQiG#"aRGM$$8I&FJVhX"eL-B8
-E,VB8dd#a3CUKBKAZFGJp6#"R#U*RKl5UC6MMUMlQH$'Y9NXrchSH&k3QHMKbF8j
-Fi9aeSNmQeh8,0j&!@VJU"P`BX0KK9@jb*6)'-R%e[S,4`EQV3J!h+6D"9VR&TCQ
-iNPLahH63J!TP,'+hHTkYB&,Y1&GXJN89+cK#fC)3Ee'iKH&F6LB%DkYFU%69kL@
-b!CKGGVq'Z,BIaV6hbe"iSF9X+A6CcB9N-8YFZ"V@86@"8I&[0e-KmP*,S3dp)(Q
-K3qc5a8EX9bf&NQBZ9*d3B5Dfh9iSHLS1a4kc)PJj*)&$%C)Nj-aLT0S+Ui4,BTQ
-iUR8Va)!&qhLeHPAm6!UL*YCK&L*9SCTr498Sb!X9aQ8afrbDJ95Lm#fD-%SE)a!
-q8@N`!JmS!MNe4P)`F-d9,mijJc!8&NJVk'H`8RCJJhVH,d#FqrZL609i*KFLVQK
-8)B('5cf#&C6VIRDffbQ1aq[Pp'rQ@X@UGU(GGBY4TDh39,9C+JUc3KZrI*5fJG3
-,SpS983P!CS-N44-Bb5``kV9#k)-"JB-8Xf)c#aB3#cQG+R+l@a)lmCY#0X"Z-Pa
-F8Ca-[-)9KqBA*pC4l!cTAkG0UC!!cpC401b1&lZ!mc-+P"fb9E'bSTaRbl"m9SA
-Fke9EQIS-(FVf#`HLf[(+i)!b&SXNqUJpV%Z5DVI!9Ja!MH[Si)d"&P9--VRLr82
-8$X%QfF4!#B8-BXCPNCJXa5kKCNJ5Yc#V#,'1mibR#Lq@J!iQS3d@FrSAB4JQ3f1
-Xm*!!5S93PdhX9e!cE@!9H-ldU0,*8E'D)l3#Ji3QHLa8k#&cS6l!6+)$i#rd@$#
-`L)(`S+,%#Mf+6E#+UJFfp3SlCP[K@1hBSYUa4@L*J30e)C6*%I)Ff1k`#CN!CE-
-JfL@a%M1-(f9ehLp11(6')U3*'4AU++L9(K5[Kid9b,R2b8BZ*d-jl%)2Qa#+#U[
-'3jL*6"*c8Kji3Sp*BTl3"$J")H$U*C0($4-(j!(H!hIRB4X%a6dUSb%1&#IM8+q
-c(F+B&$3,lR1bNCm*'BIJ8[`4KH84CH"`XKe#e(Qa2-(PBJX6lprZJ'T-*dHSAa'
-UBNJ%QYK4I)@+b+$Bb[$aINj&V)2-46jmUN#l(qmNprG9IM)1IimQQViV1DM9M@m
-)KqQ`cd$IjBjVbJMDN!$C'Z[qbKd4&2@1HX9R4!ADV+X1Qq"4dHrXZ$3"Zq"SVr"
-5a,i1BeB[G+*pF-DXk8"I3(ma6,#ZIIp*J9E6!)1AU*VMUVBU"CdM-+Q#`FY(UYU
-10KJh$$+V&IeMh!Q@mY#J+T@KaRY((GGD*!P+[,IHBEbh(*dG-*PBjk`kB19m*5V
-jpFd4qE'C#HZEd2$-$)T3%kZli'c[Z+3Q0lTM-cGASB@Xfb'V(cVGaF"iEbE'mHM
-2KTQVDmXAUApjDl8VbKd&8VL$)Rb*-5P+d-*Kc2%@D(0ba-#BFaVbDM$'Lq5FpC!
-!Ge(9hJT@%prUN4U4[cNLb"*cDq*Lf0BjMGKQKqQ'VHQUYM9DI@,VNI(DI"(VpLR
-)&N2XqX"aDb*m1*N"dC(S$")$if2#Z%H"pV%C*N[A[ST@Y6HKjjYR#ja$)eQ"a'I
-NEfj+hKPNLG$b'5P"riq2JRmGc&CGfpC(G@l2C,b*'8'CQpf0JYQHc`Lmh[Ki+rJ
-M`1Z%k3Vq#&AERURD$V-YcKe4#6ZM,"Rfr16$qN53!+Tp8U$iH*(MZLp!I$`F5`a
-%"l5H$6HqSk[U6%kEU2+#GlDP`$QlNTfhjFHkGqBhlib)bY`Fa%3CXiq"*3k59X0
-Nk&VbBM9aHfC9J3h3di)bh8GM-f1D0QIL25JM2h2c-3LHl64QGcC#,)k*TH'U'K%
-6P0Q8A29eca)6#ZSi+JDhmL1B9&G66'Z81lQ4!HEX5'0f#$5C9D"0+i3T-N+J8-J
-ZQ(#B4L1NG@*,D3VHSei*LJK+m!@TPZ!eECYMSQ!hVG&K6'Y&abi'aV5V'+1b6ZX
-'dpm)`EH2N!$,"HG$ZSjYh8YLhCF%bQNMaJ+8dfSFaK42J6DP4!b-+6PB'ppITZb
-(NBb3!,jBZbG-G-%c)EdHl'Qc61LA@UCNLV[DL8d*0DC`jTkQ)$e6%Y""HUBJ260
-mA41%qlLQ+IfCDpS)30fi&DDji&C)T*!!q&+Tie0G9DY1,61Q&V&9TfCKe4(S`"p
--2@k%",GFY8BUd)D@q&HGHYbrkNbBAM$GB@l(1HVP8&2"Xd-RiQpD*RYUHf0U(iF
-a&38ep5HBhXC3V$2dH-'!SG+,F"K6KaY6Jl(rY3*Y1X40Vc@'3UfKJ,UKi3AAKND
-fA'hkIQ2kF@0SSc'dpHU',mCAaNNVkr6`PT9eHU[$Q!iiRQiA!f-kbQ8kI2PdP-[
-drXE3d1UUQpL8(l0c4e4-%'TaFe464Qb%)#lErbikLf"'kGVV(94RIJREF6iM2cN
-+A`l+RFe4b8&Z`@deh[$Uer+[6T!!f$IUM6I1'N0R'd-""N-M&6j#i5X8(Uc`AbM
-m2`Tr9Z%r+Abr`[qUm2F8RX1`II$kTr!5KIpFiFmSh+l`@)8rc,Lr9hLc`MFU2&l
-KQa5q@1&1*V%E#mq`m5k&rd2KPBa29[K#d3EQ"8`SfLXZKGY8mEVTB'GC#Kr-a)(
-lGB8IB(Y1-Y46#RmEE3Z&$m(l)C0lJDda6q(h+Vb0(53UI+h#rkl`q3VIS[!3KIG
-N,I`4E"c0dV0(%DpcZjR'AS9(XT@Q+IbL`[-8IPhKhc*"lCL+53Tr3H&r8rKaTNU
-M`Kp4H*V#Ie6i#B9rTr"I-Y3CTKa@6DjDVjB0VM"&XIN*KEqLm$mVr*,#PbTmS-,
-raA4UBk5rMHRd)91S31&&,,8+5bF+Sjh#cbRm,BA2C%Y+6)-%KAr##L"Ei4d8EPA
-i6S8(&(j8i5UMb(5&peGi9jCJP1AMM1jp@GUQ+,b6`JH`ihZCVU$qJi`klbVm)CD
-'KpNDKeLDda@q9q'V&,j%i@MbI+c`'`Vr4Z'pf@,$fImCTNS$)`d5Xje"c$T'eUX
-+Ame+#i[GBRTJl9HV3'3$Sq#2,*&h-pB[&,j5i5mceLf-q[XBiF!k@q%G&Iie9'I
-&%`jC$(TL@6R0B8`@*RS9+im(&&k[m1F9(UE`,eN#)-+Qm,-+(k68289FLVCd#Sm
-dA8kGIETAkf"ck*'C$AdE8dUkVTja[1HZB)r6e5lRpS5jT9f@6crlLAY3EG[k@I[
-lCBc-HRREiU2G,pB8fT9hFc[[Q1mpYh*+CBq)JAPKDclBehrMm1cf@aH9pli3%SL
-2QecIThP8@EF9Vjej2fe)dG9eFdlpP$NL[F2f*FFq[ePR063ekI!c8I-+ERdflB8
-I0Ydcj[U'hqlj5p2$Mh9mk`qhrIc(1iV2klrHqmHJEjjqm[Xhr[RIf!H@AI[k[C0
-rIHI"4rrcdG,IrqEEZf5EiaH(rT@mm1#!VkEqqm1BZdGI@I[TmlplrD&(ARRcZcq
-pq[E3FBRhrA,hhcF2HqU*9AqqmapElMp`kBZ2RrYErVf22lYc`BN[EjLZ+8hZPfJ
-8,dUBH)kj#-jS%AcCSM!a-"Ce`aLqE&%(Q"l'd-'UYRN(A,IN@1RiGk@[$k)*(0+
-Lb,&NM)Y'31D3!),%lr+B%#ckAEUaD!4H"C!!,haA9Y&"GVPS$MV),VmlBRb(E'a
-SX+T&e--8`@3,*iGF"YYVc!ARDd`9qG4h&ih[l%D0CG*-#6RKjCV859SYAI-M3+Q
-[ma1#-QKV8%6q&a%*34&X,-4pi*LdR41I2jjKNF2iEMik0@*J,$CMM(aUX3NQakM
-"eC8D0,TV4,iFU@V00pA,cFI',[$D*!SXEMB@TcQ-aH[4[`N6CY4FRN6SqHCM%fQ
-q6%4D1f2aG+0QCV@%Dj!!i(pjB'de`62)@&TSe!aqBX+A#TphMUAeaP)dj*H@S3r
-D,R8CGp&DhjH5T3R'dNcMVY5*YHA1953r,LV'r5Zd(*IfQdK"q"[M5bG$'8$+d[P
-LB#`&G#hYJ[k3!!*Y5Cja9d8$mbl@`%5R%DfpeTI3l+Z-r#frJQC,YSe9Xb8SZ58
-SY5ARa-"BdJ&M&rTpB(SEGqfUd)aAD"CDF#QNpHZSC*q@am4H%jB-E0Rd@&$S-"E
-N&9aE81VEC"%(aJ),cP!,&TbY'"X,MN!*%'S"@N%,-SblaVp5K&Be6-4HTl(JR((
-A6)Grr@l!ifd$"5`Um0(NaUL)r4CfG%N-GVSMSTVF-Hc!FUa+CepjLbXNRDZ3!*3
-Iml1NB"GHD4EJl5I5)JE)b0"(IPPV,1L2,P)8H86A,Qi6(5mZ9QMfFi*$GhjEkkY
-drSY6fVq'fEq'fBKdSiYLLZbYDfrh%Kd[$eDGpSY-3XH@p0ML&eJKrTb[q)UcDUS
-m1Ci!,fUER`ccm1Bp,kkD$20@#M*%SU8iEbX-2K5m6D,M*d1#i!!C@ZLDrk[S@Nd
--XC,CQ0FHh5N`D*CH@#ikIQ+XBd+kqPI`,l!MY[PR8hTq`*KIVQ[IMLc3V2$T9N#
-L&5l0'UTUq5K1+qUV&9A#L[TU4E@`iYA0ZJX[lEembl8C[[l&,9IZ-1DM$Xj(-Fl
-[VQXriMh#'Pfa,TbJ&Fl35MlV$SE"5j-edVqZG3D6rXU%kAaaT13,*@-K8RX6E`9
-@N!$8LQc"#P@XH2@ciJh*#Z#fiJZA&CA8LTc+#RGUlBTP*GrLUdVYLbbqK8Mc3U4
-jiIX`lq*b+li"@B2&kPjZpL)I['Y`eG*HhZ$P&LmAZR6eGM"9[jY8[*PBF,8c15-
-S+S)16q#),)IYBhZGX4a@*ZEiR`AeQM)h@j,cm8dP)MECR4p4EXQd(,1m%l9VCdc
-6KD#U6bH6VY,LDdIedZ1rb6"d44fEp(9TEXm+ph-VfIeMDe!9XBljhqV#',E+9Fe
-0-HB'-qLI1mYKc*eHS(d$p$HPZUCC98hVjZ9iRj@mr!K'kldm&E(3beHVfSd5,`r
-(9BpCAYjiRfdI1@LhFDM`0#k(R63hR0jVcZP8bA2-1H'98UkC'cGZf#HbqUJ%apJ
-5-HUL`hF,!h"4f+2F60Y4Pah'+!$1+2qAaNilla-j-@L@M*`r1FeG89(mS5R6AH@
-3!0SU'+T9''%-Sr%L*aGS`c!BKZpRYYShrAZkMNdQ&I"K$[pHBaJq%!a$NfAB4TK
-iAB[(Uhpm!NbfUTfI#r-qM"fQ4(8k8jMJfbG4ZKVH*lS)9J#!$d-p(6C)eqcp+r4
-Vra,E99m9"cQ-&(bq5)&M6GQKDk'9AYl9bcZT@Q)0c"bBpM!+$0c[U-q01UjUcJj
-H$MrPA1lPPe8YmkUUfBE!c&(2fc,rCm"l2Le)e!K,HCIUqL'%q2NXIVlla,YF+AY
-[GcQd22kCdAZrZ!4ES2AHri94Pq,PJq'DMBF[1M3[6PqY1(feaHNX"bk9IQCdVcM
-YlRXk21Y'DTe4+(Z+!q2-Br*'ebiV1Q!Um"iXIEVXUC,(XKr*HM6pFF[Kh%-jHqY
-h0qcCprcqNkHH1re#jEr2r[2-RFG[+rr6dGmI1b&&l8K1#'VHh0LdmI@-Gc,c@cG
-&a,KMdlEXq[(#QpXqfVicI1`-EermpZD0X&PYekjfDrpXBZMeX#[SAlTmkpb!,Np
-fHk*VarD[[2bI$XpfHUEc[flrBjqrpre,rpreqq[RArEkSFH(RrchrArdr(R[9l[
-rj[-[Sj2Hr8@lAdrqjFcIIK"kj4A,aiQcTdfC1[f0erjXQ9'hk,[&5jFXL*`hIq(
-FkjF6EedkeqA*!8pd(0cej3lrH@$)rF&hK!bYZFYD4rp6'UL+`kA(hAGN`jUeklp
-HpdAUCbZr@[lpLP@VhlTlUjm)BqABbSM!0E[0H6jqf+IIm&RS2c`UCIL$$iedMVM
-Rh[2[$4adGha,'[cdYjBdq1P[2M6iG0ClPMRMDI!(AaTm-fTBbX2$(aVji)Kl"pm
-cm1j",@J`bDq`qQHmL*qiGME4Re6RljfHb+mPEbHI(hq42em"i6irbHGA*p(BIe@
-lM3NN5lrbVf9UI"%J`B6+QLIKPmCb0&kM56IaX3LBN!"-RDZS06'k9IaFGD,-CC4
-N-38`hFY-BbL24P-Y,D-L62ib83(ZpML)ZmQHTM*kLNVS-FUQ4bL,(U9d6!fcd'(
-+T8183hZTRRC6!qfKII3mlDH6Z,[L146h#jLAqfrF4r42h*Yf*afRfkLFrS5ja,q
-RBjKBKS++SKf86!N84-fdQ4UTL6E5kj4"le!QjH0'Zdd836(NTPK+SbfdLhkN#r3
-QED12D$[Y4+Rr[`KiQbl5Yh36mpV#U+k0VY&9kNEYk9P+T&#k$Z`9mU-[d@@k4HG
-S!(@K*m(d"(@PMQ"pK9kQre!(E1P%ce"RqKIG6RqN2[4hkNYrSIld1qT(IkA2k8[
-U46p3$rU3!$kKrp,lp!rU56qRh[3UGDII-)CSc,kLGqNAe)jq6C2TPc56INXI3)m
-V@19Mr'E60*T#8fNk[8'[dCpT"Rk,k$YD6%YT#5fJ5*T(mfNKcBAQPj'#@p$k(00
-h!26Y5)1Kmm[3p6rd!!fKqbQBlU!3'NSeG"GCU8lj[`m#+QCA1-K&1XA4IA5%0Y!
-D@N[Vk@YD4ep3+Re'+qNV@NlId`TD4D[T,GVD!J6qA`5-"`(FG+@4R@cNT2-86m2
-S8rS'f&RN4cp-SbL&KY1$p"#0"0-)ZSIZ"HYl0*!!"Y(Gf2*5)2!6rHdP38!`4&2
-Ga%$J8qM`(Xh"Ed)3q!0q%`H"Ek$Y-1Ml-$3@qMi)IHm�`$EHq'[K-&!6,@m6Y
-8flMJG3MQ'K(bPV2!44LG`m)()Y4QX0"1"&-F#aG%1*JY`Q1$4FKfLT!!EN+`T'Y
-X8-N#fj!!(Xr#C"BL@CJV`Z0(@'$(MrGRB4B,)d5`P,+JX,#D"DX)KpH`d)@&%"&
-b%eL)CQ'*#(Xc4DM[)m,Z2"E1L0"J&Z&%*a'NXb+NcKEK+lEjUd%L,%pRB58,&eR
-SaF)L%Ei[BS&YrVk4K9!@2Q'"L9Le@)3hfl2!%[EQjb*XBkTX+fGK1`X4)Rc%52N
-4)mTf4[VYM(cE@H+hGfDKK`MKM#MKp5b`!JYRL3r[c3)MF6K60-V&`Q84GR4PJDQ
-9c!k5`ePiQB@I@'!N5'C-#5B@@#)6f)BJPZ`J4TUJ15``GB-Bk$6[&k&a[JK0TeP
-JfjTB!63aj6BbdQr-BS%aE@4-'fqb`)Tcih34-SkcN!$+!P-dJi&A"Q2+B)4qTeQ
-%r+-X-#$,pk-BD1EhC'%+#`aS@XYBB)4VCD$3bTC[hFS#+kV@[Lb`cDf-P+d-@$F
-a%QpbXm"8fF3)YiQ"a5C@Y*Z'La$"LLf#JA8%+lB)"XSa,0Na$&aL'$PL'2RF!4B
-B@Gd-V0fXXVPC*A5c",[lXF")idjKJ9AD@%E3@!X,$&"L@@*L'8M&XNS9biSfPUN
-BqaS,E(-D+q#d"KBBZG0fX,#,KA-XX%U5aXL4aUTPfK!4YM#PYl#NEQ&*hF)+D8X
-h&KMKYV"Nla,,m&d@i@NXZjKAf#@NDVYkb94E+&0rQ(D&XP&D+"FZKh%Ab[*0Q!r
-351pE+"F(B#S,j6&(#q8m$*DY+C5,qK6+*4d+j82E#ZAG10MG!fC%SGa`$!B#'VS
-8bR[+BF#`"m+I6i!"m[REBAV#c)5C!C05+1mR,"U3!1A#5&N1R*,PNM4ChKdYbmr
-hPqApdfAj4*JXUd@bV'6)XYjCPZq,Jh(,mK'6,'m!``CXA1Z&k5(,kl0J9X)XPZ@
-[JIbkQbar!8'THE,mfAiB#([VXLb(Mj!!jDKd'!L+kLl,1bl+FR+U,!H9`4b"!5+
-S6CDE&9RH$%&01'K&Cj09PL1JC%3cc%qb(0-H"XTZk3S$j5jdJ*NXbeRR22,TH)r
-m*jG(rRfj4ck"cSPq(YQeh52VPchb+S,"!G8@bj4G,-YZQ(E&XUFrc)KL19!+d`r
-QY@,C["AQ!Nb2BRR-l'+jGP5aA03"CNLaA&"B,"qF85`rA9mXPi3AbpPGLZ9(MX0
-!B&CHXCbZ`-b%'9iX2ei#FlPB2R`'jL)-0ZB@`C6$""I,Kl$3S4d`@1a3CjMHaA*
-1*FaUQ$DB2M!3PJ-&pqE#5$$BX"H(HaFAbrA,BAE"32(k16$cLqAG8'Jh&QT)+CE
-h4"6,*j'`NpK`mRdB,(U+B"B9bmp"NHFJr(3C$!5IKS)[R),T@5aAGLq@cd,aIiB
-@bfI#LZ8lSH$a"TK2LZAEc$")f'hlBD"%Z3N''mS(&mY(Qi[P%p(&XZ5#Z3N68L`
-V5+4b&3E%GZb$@3H$MDi!$)MSJR"A2-bjBMQZY9Lq,keB2J,PMX`YPMId,CEAG#Z
-@eqE!J-"VSF"k&0JA8$B9KCJ+iCqP&X[,)Ial,2jpHaJ3B3819m&3@8#Q5N!k`I3
--b)'iJ$`Z,5#E!IhQ9TLDJ$aQ)mcmJ*bh$bB$TJG-5%!H$FE4R`INfJ$-6CM*!AP
-C,Fa+Q0N"Z3M#$`"a!%*-%'BD%C!!#qB'C1pV!IRJQS$m9'T!cZSIN!!IE3[)k9-
-#XJ9#$Zf!53R)$GN"qIP5Q#%"qH64J(`+R4F'"q4+-0eT#XJU&(8FJjNCN!"Gkf%
-J3#q(k3`c-L$(V3kJ-X*J`j()J,`"'cEd#mKVHJINp8K3+K#Ir33c25"[KH*EV3(
-jc48"1H&-3'l1JpN1dbH!*`#J!5ZX&,U`G"d9eG1ir5iq$R0EF2%'Xd"j,6kLU0V
-+VCLd@AK86-IRim4X6DdedK8DQA@@mR*SA"NB#lcf&'k+ifZmL5Pdf*a$biT8@bQ
-C6bND0r!9"Pqkqr)m6)$1+iLr2j6#McH3!-8VAFmV!bGC625S)Q4%-QE9PYQH$VV
-iD9q-1*r*J8l`*Xj%)fiE&CGMGV0ICLKN6S#c#Cb&akqRTqV*9+R'Vk1F0A5i6)h
-I5Xql+Eh--E&dqT25AGMT(&qejkl("k9+Re'KepZK1d8YGp&6Q1fC6DZD+6H2(Ld
-6-h22P0!H%q%k2b6MXZR3[K$(0,Eh)d0FaK$TU'AdZfPhmB-1cFMefY[ji,$ZBPm
-@&`pTL5V`hF#dEHY(GEbr9NBPARSk@h9UjC4HJPBTT4p4E9Q8hU`kbbLGprBRE69
-E0Phd$+&Pfah"H(S4Ek-b[21i9#IrJ)T1UFiX+X,N&Fh2C,XM@1cY*26TiJhV4(8
-P1C4RSR((UJSH*rZmB5PdEdNF1dRh19R[E8XK5dNfQB[`aP@06aFESP+cUDb)$TV
-8@hP8j+8X%ceI5RY0H-&U8I#pr&[mRDd#,+UJiDES&(Jl42l2bq6ENC18LF$jP!P
-MD9%Q&4cM0rL8#3qT,T-59LBPV%bb@CQ8SN`kq*C*BA@CA"&PX[eQGC&-CN@5,BV
-%dE*)1JYeiVeKRImh,*)f&)QjN@UcD9`ZlPiG[p[-*P$9JPSAP6Cm0H+G9p$[q5J
-U,e)((+Ikj94C4)Ij9FTZS)-jG$L9ZD2"STkk4$@YUDLQ%$K%YGh!T(MFrYE9Djm
-p(PAJ1a5+p45Hk30[@mqIU91Yd#R+R2Dc&+rpQ9be)Pi[+CZ!bYPHRM*4I*JS%pa
-lA%6M[$k&9IQ5*q%P#C1F0)lpj$*1cKkKV'`U-"(ZfcY8kUUZ'!bdl9lE,",qFl6
-`Ri*XhEcfZD$ST2L`Z65XC$APPG#i)Tp9QVhA8kM1QB9,4B&M`S0!q-L#@c@$DAH
-p3Yib1T!!+cBG3'RkJ[*Fi9qAB,CGUMGd,X$ChJe2V2-Amq!AZAfTA@b(AT%0fbP
-[6AAL)iA#REfKN@6*UUF!GeE)9Dp(i$'Y@EQq1#eLK')[mFRQ)NDiVPVU+mPVHUQ
-e&rG3H,R3h&+NAD"!598plBLUE-((RcZckA3flFQQA(a)bUC5h$'TX"8`9q@bBZp
-,i`GY2S0@Rm&bRm&aRd&@Y5$G@544F8Q9e`l&iSG,0e*aGP81l%GGR""PDUa'e45
-F&bJYem)PV5KEYEPS6,Dr&('K954CG'X+VM-fEbB&XKeD"9+l)eJj[ipUc95X9LN
-9MPY!+JBiaJedZ'&'%0I[,6F0ekqAi*0XV@p0U"AYKbKmXbV1Uml+Eb%V2jbH5mY
-+bCY&HFGT@4CcZr1&dL(LYCK3aNHU-9V'*kKMTJP%PrUV([!QAh`*1VKKU%5+0fI
-j(Zcheccie63DYm1RKG-'3BUphLFP+lI'fE1U%8LiC8+%Uk0apKL9jG+M*F+plLQ
-PJlP89%)(c95QqJX$j#8'V[j03e0p!'dm$Y!fE6)Q(EEJr0@PRjj8qQQrp$-YTCp
-fK9P+d)aV3CX'I`Bb+IlR+66-'Gj!P@Bk@8,IiS&XCQV)SLB[0AMTd%ANJR5)pk8
-lDqR3$NV&U)3DDZPN,9A@1TLVQ-98&Ge2a(F8eZdT[U+`lY`#@`daaYN&YU'$'6+
-k`"CLqC@fG(r4LcLaTGVYr8U-[XHAF&aRFSQfp4JqLiTU'I%(#FAprZdDr0[%b)Q
-DF+KSUdqG&[@Z6N[I4iHmkQAiNE0dS*C+&AUXK%Tj9dC#kbLrB(6RLkp5j+qG9A9
-h[ZTXR1r6CRj113+``@epd%"Y1dfjkI4d,TP+k'PcPCTq2lHi'T!!aN-1i'8fjY*
-D[EJPqe,p"ASXTpT*iR'+eBc%h+3IS1iUF9AYkqD,PJU2mS(5qG&m#CQVmba`ISc
-Cp8Bl848M5ij5hQUI()dGBiDeS01`%S@+Mi01&GJ)88I2)fXfMIG'm%#iSlkUaZ,
-PTF4&HGi**-+4Va(,c5Z4+'rjT+HK,(20UK5jTmpT()qVpLi6FcV`FRQqq$cQ3dj
-9Cc5LG4-hJ8paa8H9mT6Uh'5)hqZ@m9l9Z'#4+Y`rPqEMDd*Q5)ADe[h5afi6jCY
-SiaP+A8%rPP&U%IhG4+RVDDfAi[*)VD@M*VV65j8PG,)Hp8p8bU1eiL#ZPYE@8ZS
-qHZ-B"9A5aPV+Vb@h(fVE!EVkLREcB[(9@26k!a8XHQN!qA$4Z`"8U1LG%eq64Dq
-$q*4-)1'XlAKr1L8FVKKPBP614VT@'#pk!N6I&9q6@EGrPFK-mIQC`@qI!QG0,jq
-kp[pAD1hr4k%f##eiNFca0EdUjK0TqFQ+jYf1QlT1UpTAh960LeYD[-d`p[[X,@B
-HJ4@c)F)F%dkM91#[6dq3!-@G%BU%@l)NTfLYPIM"GUlr&F%jGfcc1hb@XKc',I$
-+pC+L#9UYAMpiPdk!,r&H5a'lafZP(8c9YFr3[[SUS'S(-9rQ)'B@(6aANDLf&Ya
-UU1r'FcVU!ZV$I'aS2fPbRI0)0#QZF5r,UeXQI*mrRjU8(VIJ6mjQ8lD*LXj333Q
-0,N(,c5%iCM%fmHdKXfSNURHkejNb0N+e9"qdUTMY0H'"DV+9jV+UkX@XR#kU9SV
-j3Z0#GHh8,PA,bX!8Ida$R2keYVVXDfe9Ae9lp#KQLkISfQC-hFR0!4#ZIS[4m1"
-XPG(Ni#ISI1+(&@pl!5mk+LAZ%mD9("'@Tl1`NS@,,24LBC%)haHaF*D&4J6Yqe!
-GB-UkQ'jT@U&U+rUViZj9EG9L(6H#BV"2GEkeQZ1Z@GYE2AL8`rP@-)mU9*aEMh!
-$Gp*ZM4E4pZCCR0RI[)MR#EcCAYMqh)9,3*!!E(mc"2eYH@+4EH8kV[q)jEIeB@'
-i#"pPLm12MQ'a8PAl+%29$PK9qdF3SAhdVQlrD$B%IM3AcdRBVQJ(!"2EXhAlpNT
-)aAdEf,NGmje`Sk*fB,*Uhhi1c0XlBq[f(N#&UlDG1@"blNcPN@L)lZb1E6YRL@d
-l"q[fm(T`KLrARH%*20bMD1'pJCb-TbD%,q,K!38AP-3$'U)X3%9G&LJY+N5hlkL
-&P"d@)@@(5mH9*YCGM2A+9AYb'64)hSFYb5iZlQY2$YIYb@N#'bEXbm,q*'`da#3
-[&J4)-!N4#@Ge,F%&-EQU&P5NDd(T+ZiSdS,Qk2BJT0iH9!0YQl0dHr0qE'dqaTp
-cf*T[BJUBV6Q&Rh$B0ZrJKad-F*E03#2JUK$D1&RA'N'bCGe9He-@"$5GeV8QV&+
-l!ffDQi+RU3p3[B'+!mmJm'`dkrD0A86[G[5Q)bNEDlLP9V'phN&XH"hb4MHJY@h
-5R4RK()rFd$+FZMe$E-QiA8HcA,#p8kVEhcN+h$[`Bk04rc-hkPSQ!$C[Z'V2R)'
-66%"e(ZDPjD-KNSI#bMqUfr2MF*+r$EeQdEZJfr*C1[*l!MG&i%DKC`8e@N&RVE9
-HYlHka(#VX*N#C`HZVqMee(%Y5j!!Ga-$qNhP20aKhj5!XdeZhElTCG(VKGlRSJG
-&mZ,%*5faA%54MJYDBPG%QJ#HL-kL**d4Rl-#MCL2ia(L)#D,(F3FC`Fafh4R6#-
-QRbMf'!'!-3#Q')#Z-fDZU$afG`"BGlTZG`0dRHieIQ`'`0TY%8GGG+HlRm"UlZR
-J5K()B0dHD`ClV)@ailiKPce@*$Bf3U$Mr@J"6V'I#maVIN``0UHCG(YDJqJG4fm
-(H0*fLD&6GkE0%QTUD80dqaDKe4CSYH8)J'T,Z%MrPM!G9lCBYlIZh$+CijCqEFX
-)-I%@VJ[3q52Q$)l$%c8Z,!G0E@m6#le%Z,K0K'pV"I'q&Gi(RmC8,6"II,9%jed
-aVe3AAfF@1V3EZ0A$Jb-1Re-B,+DDkMDY'jFG0NaFaPEl1YeQlbp%fB4!Zdf8V`f
-e`6B%25GUlIN5(JlGcYYe@la`FTMDU0Y#+d8hY-[AcXI1m$U3!$2lFphfL"RH5FY
-DSpZb1[-kKrCS$ee,amh6T4Y9Cqi-2JpmKlE"Z8,ER"*GbeQ13Ar9ZGI$&cBSfZk
-MZQdhUbblHk!l3Y5c"RLVJf@U[F%0E4VJelei!@fBM-llURe21HLpCjZ`0iAY"+B
-plGCac"BeCDJff3db1H9f2!V2#I"dd'fHrX"S(Y`[G1"f95X'43i)HTAUYN!r!@Q
-"erK#m*T6GDIj!XI$9CcQ([a3VD+03Dj3"-p6LlRXbp"m+EUUfSTB05h#4-iLj#8
-&H($+-U6Vi!add,4i'RFEeGj8YC*`2)i+b0(`&GPG"*QcTr"$$YXMamAJ%6II$B,
-Pi9&@d'6d4NaH%+k@TeXiZ1cT-`%YkFah2ei#M2Bi2N2J`5V*+!j,AedlI!DlPQ1
-QJS!"jq%Ch#K8l,P&)%-Z*SrRSVD22SCC#m&#dd0EGIXK!Cq(,JJVUXkKhVSY4j5
-M,@He+2UF0KcPp-'L16-C@P3rqpjFS2G+31rG)G"lfrKQKlChX@kVAbi3pEZ%r2T
-qZV0q$UZKpB#f[$6-LZJLA-&ZiB4f)c21JbYXb16c(,D'&!#QE8m%#YLfCcK3fMj
-8kRe1ATHPD2X(klD6E8,bbIFj@Q%RJhAE+3DITd6@UMd(PreF215G9Qh2#6hYTq'
-ME+I4KR*STbrUfZP"UL92YEe`5QakJ@Rh3Np9'i0XYa)eD`amd&R-`Kd$Ara2e,!
-aI96Y6"Jkje6YcJ[SS0510qLfimbr(TqKfiq24"*Z-qZffjJHYiQm4#XhkEEb8)%
-Slmi3JhAY6ihBM`TlY&QJMZ*6URQNDMXfA!$bL@cGGZ+8+-36AA@E*$)m6@T%9`#
-m6HSXMU5"ZUDL5@VZVGU8VB*&ZDVE(#c[FJ9BU"GS&pSRCN#`#ilEG8k8[@X+FiJ
-ZNAATH!5''91-pFr4fD8kieTjH+RL[#q0Kq24(8H+4051S%6-+e6RKVim('@fBC!
-!EPXM()bf"ZfFY5)VYkeGai*E,,N@V5%c@NRVd@Baiakk,blUYLpB1bL9Y5P5SG)
-i9*!!cc#aI4aUjr*fD1dFCDfICKED#iIerAbKl)TXIJJUV-THab["hNF4hjc(+DV
-051'4$Ll(fH5HF#1f3*cB1NjN$6CcS3!@FbXEe!L#MYQ)QSZb'c0IGqD&L)D50MS
-06i9$&KJ)%h92GbjEbD2JFCE0aUHl-Mi-EDJ$YA`K8!GUG+GT"%-9c'8SlfZkGK!
-[``&-a5q&K`QJCT9KUR-!RjUI3U++RDU@MH@+YkV14clJ#e%"Xd!,$qEf2iVRGAM
-JFG1RS0-C6`F#!(QJh5'dPJkK@HI*!GaR#lrBJ'DRh+SkpjeP%Tj('db'H4iZT"!
-ZiL6F5#%JpC4!B0,i#`#TbT[Ll8Leh@N5%ZlXJ0IeH09jfck@)GlQpXI*V0U9)hm
-hFJ&plk*qfRkI)Ic[-EJ!!q9eSNB4hqh81!!BEJRq#FmR`-h"BDV0F8a84FG-%9c
-V4AEKQU,Ep*'L'lGDYaeKl[K)*)##Y@[Aj`V%HV3a[XB0Y)fUE9ffJ*TeZ)9k*F$
-L&'le9EA81!HZH"BfZr[@p-2[mS`CdXS+Xhc'M"XGDfTU"PP$V0D"6ZG8Uh@)X1L
-r)IV"mf$[(ALM&8`e9QX`3`krF6l8DMd(4(b`04M)N!$je[&r)6@I6R$mMIqNKTe
-'KJJKLd*B$,''Y'1pTG@)EaEAe$a3`e3B!K3dZhqZdaRLG!kXi"JiTH8B'qkZ%D,
-[UDQjafkh$kPC+)*!,I$h'11pLqhXEh$0r8jVc4$r%S1'3X*`Ch!&dphIER4#`0d
-e)l"pF%d&q[k4cZ#DJ8kVN`Ppf#PS&9)c,HbFe6NA%Thf%B`XGl`@HRQi'&FK8[a
-lr'SZB2[mbh`RYJd88U$m``*p$a3%i[l[a1JKG"qShVP3p,kT'-kYk!ak@$"&9Le
-A3Dc"GbbaAPKqde&9&#Mep"lRHi8pfI'16P,M!1Q#X1HNeekqjiG,mCFZa8Ykr+A
-ZGl#rpm2#`JB-[4b@q%ITR5Zhhp2aqX""Rl-JZ6[1NAD1l(M2b'($T+dX**r[fL8
-XV223i-X$VPdIf1&@fp9ZYhTh[A,pNl!`UAR+$e1Q5-N`S3p23IJGJR3Kc1Um+Ze
-%H$)86iVGpRE%AIp(rlfp9i"c66!$pprqZB,FRpl`eJMXM98hZLIpGXKVm4m-LVr
-4+IipK+XhRl"qE,eae@QpmF1hTdCDjpjB"H#imD(6H[-pqbclC2Xm+iSib@TGB,A
-1XIlDrZRPP(01P&pHHHa$9b6P!FR9mm-KG`qj@rV`0a@G[bFqmdV`S2k*9r&629H
-Z5j0l$T*5T4U8ceT45(mG)MdV"8PEZjbAVSNbq&CBQehDBRr@6[krfb5Z&UNjK0Q
-mmD'KciD'GR[Lh-[SGPhje`'*eb@(X1Y#TG43IrJ`Y&GScm6VV`,p9ZJRLCmN5Np
-m+Dhi33e)dk3Nb"XRCGV#L066E9IDK(`!!"`4384$8J-!,[%293eP44%!-@AZ3lp
-YEjBjAm,,$2Q'N!#6[)3jadbbiC%d4b8Z@4,R-T+a4!RFI-R8C"2*NMA'019kF$%
-aK'JKKKBXPd-$TDIaq3`X8+XHJ3'@`a8[0r*mV29i15)8T)MPYPb[f04prRl[Zf3
-*PR,[kAhq!4ZQ*q9"%!4!%!#L!4IRm4'G$LmqA-KF8)PNK!'qrQI6#bh1aZi@2YR
-Y$6j1PIakU[aLI1'41jh[rIf,p4#*3eUE'RPf1QaCD(,k902TFL3G1!DH1-f%9(b
-Z(jeRSipam@1B@&8)ca,l@K4#KqjM"FhS[%2lm&%YIL6%$lq[$HiadFdM1B##IR)
-i1IK19aFh(#8A*#XScD"+5+5F10cV-!jCIK@ZH*QhAMX5qZq#8!%jU8C[qH#CpDP
-@ERNR%&Ul0d5Z3pehHhXG'GH2l`fdq9BkPBelDLhcZErlar5hm8,hMmr[jp[lR(p
-fD)06rH5H+b($6`24R%"6fC39Ie99C-IPPpbp(M6hSfECJHp"9V$K`0h9cJVVU0'
-UF$Q,AT1KX&pTNN("C"PHVI&U['*&IV`q1a$+jEhEii)Tk$QM")IDp)RY9STGB@d
-6`m1-M$)#4rd11'bKN[8l`ME9AlpML+ZQihYmX8"-hG#NK0YpCP0qh0[iN4cK#8p
-#&[KR(U%T%Y@`LPKC1Im-4D(XhDC)lel2DR@$NUBQ'V++&4MAaR4SlZB4)5@9#Dh
-mXj'`48dJD@A9"T'mLkNQ`eBbP`3MNjTJ)"91(56-r0SESjcIEAS$)J@QmVT9'Cm
-hqXcK(RMVJmN+DMJ'TlaFUj[PJ$)R)'keH$9aHIQAIE&*DIMrH1'8RRA&NediCr@
-9qklNPUdZJ*YFU!r[k"qE&9,(fq,YKZ31ZYGbYI0C(cV#mRJU+I3jrk6e@U4P2If
-HD8cI#ZIh!Qce1E80DD`H*,%kker`QG80kK@6hC2`pSE0fX6Tc9a!d8X*51Y@(K[
-4A(C-bfSl%RdDDphP[G9+P)TIpXP)h,@VHe-4II$"CF5F-`5+2$4*2)+[)ZT&XLm
-XAKUZ"$krq0*)F9TpU6ijP0m'*kJ+CX,%@c*6`Dbfqkc)DPU2PCqa8USbUD61PU%
-a3("NT%HG2I*0$KaA5)dKYGVVL)p&2DD#!dX$S68&[AYArAUi3Ndp,iFF40!jKdG
-3+k)@0A9e5G@N-&)4&F)9eZhI&K4GLJB`f&Fmq0b+ja8fU1cFLUZ98S[AD(AQreA
-@kPe[3[pkm6&X6mA'RhVEI&C[Tqr`I4G88rh$Xr+4SUP)4V54PT&N"4))'9a'-G3
-bJP6!&kQf&f%f'U%%p3'&0U,NiQJ#9Y$&FcQZVG#e!pq%+`!mB53e(&1$J6C[+I4
-P+3*6rA12I!Jb%S3N[VC#14"ji0G$&DVI6)PU$R%PdF!5+K$*%q5QNe*JDQAcAP*
-%eApICR1D!6P6ECjUVe8effp(hM[be,$2T#k)YiCl`hX[Yh1N8pAeeB)%9+[M-LP
-8CfP%QQD*!5RC3-J$SYlfYNRT#%2&80ZX,%q-Z6"ie%mI!JqJ)j35$SCd``5AZlL
-B8U"da)Up4Q%Fb35@3"#)88"Lr$X$BerEmR`bb%JQ&"V!4*d*J5Q2GpFKQHH%N4J
-`mClqH*1k[pImR"B*T[*RR51C*T[((`C`mS*YGYiN'[`F,T4QB[SDkIe'5NeD#L2
-hpY@C-'3Rfdah[a,4lbE%33N-5F5E6!"+h*!!4N'+"F2rfPIRlLmHSL[Id3pa"BN
-pRX"209e+06SEBI4Y-!T)*-EKISCaf8E9Ai%Fh[d5*Z"GfNRDA!chFL3lHE$la`$
-'9QaNkijq@N`(M'6MPMSFV3@VXZ)M9+e*YB(e9'T`bfp@',F@)UddZ+9ZKA(,aC8
-ZA+I(e[K"'Jlfi@$bZ21$0$TSF'kTD8#([G#fj49em)1ddkM3"SX44*Q3!""Nq"a
-5JcYp-pkEH5KX"VTVYLhK&L5N!V`['JYEB6L189US0UD2m#`0D1lI3+$D@"p'%UY
-qNK61CjeBb)A&[5F@F[qMB*NDE,PNFHdIE,R4mXR6MT4JF6hY-"qCliFkq,@*-ik
-a`CBpP[pB2pM5E(QRlSfa#XYre,da(&cl"2dGHq,1JP9[M'HPr-eGU[8VK'2JY3&
--+jXl@)@IN6'lakaD!3E0a[V"'CEH,Umh8ES)U5hRRa3)2S0EHq0HVjA5ZYK816R
-SfY8fa"2RKpJf9e-#%B*KqGC1G5EUp@R%K4&DU0U4'8Z!IDQP'rp9RI&Cb'b89MZ
-6dGND9e1$cPCX@fDmXGZjXIN8+MGH2hV,a[IUrcpl9BZ!A%[*Za05S!0$YD4`[U,
-2HGYmNieeCl8PPF[rZ-6%QC'1B8%Qd,F(L+b*Qr1#Tq`EebcXfRMX9!FQ1DCEZp#
-bXCQQdFjj+JT9#LL$'mrN+Ui###e`fiVXDUZ`me[Yd@hkU6rGfj3NB%"m'ilSlYD
-f)pa8%5Hh'&ANeI+"IJaZU)U@91b'STJ'Ypb'3*Uj9U!aQ$4E#ZFS'1#3!)dmZ,A
-3hCpZ5H%S'F2K*pJNFK32kciTR&jX'a05P8LGF`dFE9mLiIN[A4KZI2mCBY2Rh1H
-Q)BB#,U&dRk8L6BcdH"G)k8EciNPf39QkB*3(pd[,)#kF-2'TIT!!&X"e&*0IZP,
-h@6J"0ddC,J-@`@CQQQTT!kRke(cHAAS6Sp0d5'S1J+`iC5Yph00[)&35%Lf&1Kd
-*LN)RPVmAYL36,5F4'&"!fi#Vc%+5AdC&rNIS+,EF&Xf"%GQ[dj'cJaLd4*(Z*%F
-m'Lmc$Xq0AL6@9F&LXlL`a5PUGT82Mh-b9"+`HBM5`ApmKS'K1Pj0V!N8Tqc1eQJ
-63dTlPH[!Y3q3!'J!%R*c[Xd-qI*GEdrekb9K,P+A5ilb4R5j"X2KR9(hHp)c*Q'
-q,iVQ'i&%VUpe&`hK(8dm-!66dS(1-pX%da*IfKC*,Q"N`X5!q)[kf`9d0*Q%q"K
-!J12NrXQLNcHcl6Z)ReeDh[)#$+T+,%$S,VKM$i,&Ye9B5'DVMTNY%D82CT(*krj
-D9cGkl'!@K,h&$q)UZUHlXh923A'bRUT%-ia)(N2S`DILp@*kCM%-XqMh0$8'G(q
-%-"b,qr'bH+3%UQ(+-rU'%NB@D+rI6"#qJ*UmA+T4!9"DY,)S0(2rbS3EG$@IHNf
-qMS%Vbhie'9Bd&NGMQ5Ar)GY%a059A8D#C`S!AS'3!)Y*2bdU1[2kKCpI1K#JT8f
-(,@Q,EH-35)fYTLk2NPSS,He&9cREPHfRT8Xh,IY`-ZBVmclZbimqq[0,(Q'J*YV
-Mdi44SAB1C)jd22kT1QH9BfdQr5h+E(lYESIDHIc55'a9`GVAk'r4DpGNhPh`T50
-$`EC3UQXXh$P3iqk29LFV,$HMkekZ'`SXJ,1ZirJPVI!,ee+Z5qN,@bN5,R(GATX
-aeVfiHh'[,D2%T*lI(q2*3HGk-0R8Yha1MKk)+"$J6UKRk"HhE$lSSFf(5N#i4TA
-9k83(VbMMA$*&I"F*,[13!(J9YpN2)3G#d`NHX[0+K%CpFRkr3K1G!00XFG*a&*C
-f'jhKEUFcB1TL+0DReE`cemG(Eh&HR8c&3&j`9"SfTe@UR"#S%N5FX-bhJF3j)6U
-B5%h)1)bG&b6'X89J0adG-(A%`m9-r-YTi!Kql2ID1)PM0[l8-"U9UYkLKdT2i-m
-L`V5*C[YjN@KrcP6r3S$6U3+P%RT'rAEUZ'NS0EkK![Zm+14a'18QCcM$PX*9Q@2
-f,8&+EUQl@K`!b8+E-q$'))Q"d48BG!DS#IfjcNX*I`%Tdh9bD-`[Eq"bGLfU+LE
-@b6c9VQ)KN!#RRKMm1aK%Ak@UA&QU%SaFGSCTqESF'@,pICPKSh2i1PGd#'B&dmC
-*-"%3+"0!eXeeAbD)'clY3Y-56&BjL%8[%@A9kH)h6QMNVL#I(&BMeR`Xp(f6&Z0
-b2YVi1U-Q'B(K(AM%k93(qSdmp&iH*h$!'I9R#@9#QlhCZReJ-$DC1#(i1h34+',
-pp`TBa0JcE3"C4-G!N!!S!8%#B"R')TY(PJJGk)rb8+YK`#&T`1FP!cjhK[dGI24
-l4Gi36C6&YT)#,33-'hqH6kINd)-EG!G,0Y3rNF+'EY$Id0r4KPkpdJheBb2(eqG
-L8qImjcB9SNKA[("-k0d!FXU2"0GAhTAp[ETkDS-hCVrPrDG5Ap9`LiZ)Zf)M-ZD
-9A#rPYi,K-&q4RkkSP3hj&KFPGh@kaBjS3MVd4KBl8K8@e`JlU(--"@F9C!MEXSa
-MUQ!PdG`h!S3FX4aH%H00"S485L(N-03bM4f%#RP[KqH6+#pr&8$cAIHZ$kprc%e
-eE-SXqbmFlF+469m%2384i[hkpB2[emZMP8,'G'T8M4&!ZlA9!Rj#Ajh6kDUjGC5
-1MD[dh868h08bBjbN$UNDkFeAMr"#RXGITJ#SDZR3Ci0K0jp*QpBSPE0G&16eT52
-HfPKTbCq)b&dkR8FS4,"CbUj9'c),JrGX0YR6@p'93b4*qQ'3!-)$r@![ih-@'Dk
-"'JTM3C2bJR&c+5H5(`imG)SjRmmY',hPI9FCiZYQ[ch[0HhRVJ)&KRHfDbKdlbY
-R(2T9!Iqp[ej6ULTFF@r0pD8AK6lq)LA99,*!$3AD$#ifh5k!+f8)G%+U5qC+GZ$
-P)!*`P,Z-HCbkQZB,ARir`NjNIXIAr"YcD&1(E&Hi%5jDIU1kJ*VARqYm(%liAGi
-&8*A0fYZEiDCmd-B#E5,bHYiQKq+e616EjE2GFBiUaV'T9Z2lpIIRRq24K(3i[Pk
-QMh)N--V4YAQJ8'PaAmSHL+%E'4llkK8K$S%kUU6%`B3+AcQZ&XCjG#KP(f,,([c
-*+b(G340H8%3)9&@ACiI'qDSVaG0i(Q8(Z0iia"ejRhkcX*!!!deVmaLU3"9X2K[
-%lc5SP`,eh#qUCrN29-pbK!ij5e36Jiec53dP`!ec,&pr!XB(A8cU51LUA3UKP%"
-"L'db[5U3!)LFPcS9m[Ip%hi1"0(b9X3h6I*kDaH"qiidQCVcer6U&qHb!T5&&EH
-*KNT14Daf5K$GN9E,$FY,QbNXchbjmK+@pqbPS`IBdBZ-V0i1E&+C2K1TdV1SC'V
-6bqGTF'jL63%0Am5'rlq21ea@+U`Faj%l(,@F%K90kmhFNQDeda)S'6qBPmGp*Um
-FMAhIcN-$&m5M0100bF4j8RdQL2lc'$9-5LNNQX0jl-VhCAEFmRlcGDlc%39'fq+
-!f+'4",6b"p`e9VYXjjG*YB[Ze(I#L!'Ce9k'(Q%cL#249ViIC*4pPq)`"(EQ@NS
-c,Q,*)J-TNb)T,,`b+A[6i9"0)LN&TjbDcZ84XkNJlYHXlLh`l&,0F-RYcTUC1C!
-!V[dYpMdTM'!jNM(AUL%@NZU)Tl3ferCiUrEmA!G3l9T[k*iVQH`c,0a6NqD)#SD
-MNG!pVfehK)-dLETGRHeYkp[p5%IKq%6Rc)DLR(k2jf44cXa-ZrZ!HdF'5db@'d`
-S"&QjZ`'*%VK,bGRHF4[RC6P3!p9RK312"mZ@I9L%4dc8cY2[,[Yd+3m+TUeF4YS
-bTTU2IqL0q3*FIZ##qPNcA-Fqfa%HL1cBUdCf1)V@qIbEpUkk-"a4+qr,R29GM"H
-eUYJ1-(*j,E0DH'a5m*QMbP$%QK89!R$2RpYlB-mM(f*5[fN,&c`#820*eAVk"L4
-'j"I``-ELap@&&$a,X)&ERN6p6+MLCmeB6YG3(@6JI,dp&kJ)pjF!jrFbcT[f)%B
-IhB+EZ9JJm)Z9j)*cpmFEeq"MHGV5DS6CYGl6#A#fCYQLeb0peXK5E!l'h(hD*4)
-#00!UelP`FF($$jiaS*dM*F'lrERXbBl#!dAD('5#V8J,jdj+N!$rk[l(AL`jQCh
-Y55FdaBE&`[1jr#d56Kj*d0G3)$'&9$Zm%N[llYcFSZbFd3-dNTMC[eSRP@ER&18
-Hc8R2034q+j+CAd+"[(&jr,$N'(9`*!+AF-9()%P)3,Pfh!3RSLH'4ePd!26eY1#
-bQbZdZI(h8$@,'AD#p@'BSbHEEDP6A$*)Lf'58RK030UhF$FIJ-@C$eecSj,q#M(
-MBTk&a!+B4E1eeHc$)eCFVG@`MjhL4jqiS&fX'0-fXSpaFF#`Z-!RINa2dDX*j+&
-Tq,I-A,QjJ"hif985Z)LF8JL%-2@XBHX)5f$X+bV8Jq&93BLY%&**(R195aIpXf,
-KIE[aFY"V0L[-CJ86+jKBSC-91P(iJc62BqPj46hTlHj#YZXR$9XMTBX)3C%BQXm
-Re0ja"FQKTm2Q2pc++C`eJMBa`"eC'rG1),!qcqrEX1&@hK4J!UeVEpcrHXeC+eG
-I[p"VAf@'d3TP2+"YFfA&`hP+B59EA-X@4l"BH,h'9iHPADXki3L2C-a6@5*`2im
-(*[DV2+qbK+hbCXhV04"eQ&,8QUEk4IC#aThUKTGk3+MCR6Qb!@LrAmhJ3JQbIeq
-kV6YGfjYcp-$0lEP(M88-VZYljZHQrmLHRTd$H+m-jaQDqY+"MNNNq)#Jb!G`Q5Q
-eCfFSRa+DfXTYMZb%'[NE-aE4DMAbTN-UM-lMDYL#E@UbZ(BiiKVmY-+X4b`1LiY
-Yq1i8R!9U6#US'ZNMI$1IZ1lGNQ%+IKV*f9!bb&TeL'1Na(EZ2*UaHb9hbf"ELdG
-"a&"-+*lX*F@626k$NY8qjBAM$-+MU($Nr[1XSH,$cdH['5mELdJ+bR8'4BYX,PD
-d5$d8V3q[9lJV@"Dm-43,[4Uk&0SAI#K5crl')QDm-RdbZGj8q`LZLBF,3TDIa$J
-HUr(h08JUK1BiMla+bf$6lA!kqLAbrZ9,Nj4'DedTJd4I`e5rU(3mdLT0!bB#Ba)
-b-#%@5DlDUdiCQMH%T#'F840rQFG$!8`l#+DkFKqFdrLX4Q2HLm"SK$b3!2K%c)4
-VrZ)bjDGVIMqATX,M-"ep$Ehj8rhCad66`%1r'C)C#Hhk*(KY*C8P9r2aNXU%S6*
-3A&PG-TLV`NLNH(TFarZ@*'KmFRImUQ!!q'`!(J9A*[3fS0S!MZ#D(`E!(cLdRQe
-GD+9E0r3@a&6VXC3f8la%X)qfKQh()KTHDV$Y0-,@["DeAGbbDYhYf,*UI'Td0f(
-,k!'%QkJj@JTSLC8#66,NR0rTNcmHiT!!di#[d%294*8,Mr`J4J-'P*frl"L5[AP
-Lm989L(Kk%3p"A)QTA5B)(r%4eHje,lX9,Y(BfIP)L8%8%Dp!c')%-YE96$0@3c#
-B3k8l(%Q48j9L&m[,3phX`[rF9G9-lXMq%B3#CLNrMT&djh'$L+B`%Bfk$55-B4$
-$RA"#U%b-JGJPQCD($iV1C%S5+K"-mkA1FC[$Z+RB[HY)5X6-2MNlZeGEG1!jch-
-(MKTk3`JRid@&-bIe$b3LpY#MXH6UK2"30YJ[UHV$pGLSlFbK[BJU4PDE("#N40F
-a9ChG6b6"D3kjYUa(Ej'YiaM#jePhBref&+,QB9Xidf[#ePIM@R[Si)8T&!r5d$G
-[5XU-aA!a8`S5Cm8[T3d`2)ClC@CQGhC4)Dk3!&-dbDAZR-4TmcbqMm[QHBJaprD
-G0KKfFhTfh,6EU&h*IZ59#&2-X2[%%(XNi5)5dNdIB4h+)KMp,Gabq@EHa3@mc$b
-'Kd(,S(j!(h8)63dSRc3Nh!65bdUfiM'*#-[4l-Q-SKdP9(mXh2KK'l@D'L`Nr$A
-p'bCd('D"6'%(`(8'U')6Zk#[G@FJp)QS#e'[#ijQT"GdC`b25Y)I+KDj-pfC-!0
-Eq33pHNS$@YmE4`T06bLXIG&Qp-8E"4Y2'+G4N!$M6EffH"JrS@MeiENd[GM9+3B
-Q(m@)5A3j%TllI$hr3-F!`!Qmkh)[Yd"jc*FlZ6XUi00GPDM"*A`##[($L-N!!AP
-a$b-Q'i@TH!+%61,(bY4P08h*c%D!GqNVMFFD(C-Z2*!!kE-N&F-##9dp)mR$$)3
--BF-p0+6+j649,XGe5mJ0Qj5,"diIJ8!qmBp&21(EbLeRPa$#i!@%JE$D*5Xm`%K
-T96X*l'I4`-#"K4iSd+h'Bmd8I)-+'1E9G#K0M`[G$56c@l4!-SQm*RHrSGPT%(N
-C-NPiPRY9p1,mQA,HBrNlRP6KPVrVk"(",`$15EirQFjlZ!f[!Gk&ea5hi"APjZ6
-R009PiBfCQ4cL*+P+-N')aibR"U3bdbNeT"mAfbp(F`l-*r6YBS)f"N!aJAimASC
-AM0*p6+@I(qM(jR1%)C8K2IrLX+f['@TGP!h91%!mZ'(#C)3HY[H%mJ3i)CG"J2`
-8VYIB3,qRe85J1!)h$6kmRk!jm&ZUk'Z)EP*0KZEpDc-cf6m#2-5'm$`@Q#%ehiP
-CXfL-jK8E)h(BC!C"8633dJ#3!(f-MQZ)k9'4+f0V@1!G@cR$'Q*i914)3qkQ9*3
-*kU[CamaNZEkCe25&-hd'-hPhD62CQj)-V@C6XCN-cdLKJ,mAYfTQkG(*QD-C'HN
-(CQEqlf61C,Yi$AEP@E6dq'61I!1UP&j#L#iYfEh5*DTaMl@[J5e"BmViA2E4R++
-V,0NT,DREV@I[$'XiFeSi@l3[!6'iJ*I!B`XY,9SbiRfl&mr-j"E&RcX*lM2aM25
-P4c0QdTFZ!4-ZT4h4N!#SKCY&$54j@1hSEN"iQd`TACD`faffbfAFl9P[[5!IjRC
-2L(hX&$rb2%fU[8P"d+!Ek9&%%K82""XmVN@0"1DBHbQ1IhL"d$&b5V6mFN%m*UC
-UGbZD&4pjeXQYr#A2lANmfU4'FK15F+4TY44BhVR'S@fqaZ%,iZQbPcbVe!iehc!
-&'l4,HTNdRK+@2V2e3V6&@L15R-"3)K`9M468D#pHbUk53191D3'@lL`qCX[G,1e
-Vp64Z1acI(&9-NH)V5Laam&I$N!!r'0#&kGX-"E3Ic5d5%4lSUGe*SE))kd)J"S8
-bKZB1p#0`GX`3rQ9!1cCJd$N'ThQ,IT!!T9LjYFULEkY8I&UPiT+KJX3,28C[P`5
-a1*eM,2K%`Bq-8-'548(UHMA4NN-@NPM-BKFGkkHhmE"Ia&@3!$[RVK,#Y4'ipH@
-F1AG[I0["PK38ZaM*m&Q@8,ViZK0h8-"FU"Z0dB(qdJ'rhp"4X&5`UjF(UiDlXJB
-N"!f%eT6"Y46'[fj4I4e!CEqh`iZ+@IN(3Yi)rU8&`Lk55!$cpeUT#e2L!X31&B%
-pNIfFKBLdHq5(d[iapl+GKp'KUUL-S9)`j@HI5rQV"'k@L*HB9J1MfQLL%-P`f0c
-a9a5XfH8Q+pca'S4$QUFbl6GS$kYrHI0601,-8aHfEH(K!i*[)3mRLD`&,%85D1@
-Q0%D@aP6K58$X9NHk+"6`,2j9KYVjC+Q!482)!"'!X!'PN!!hDN`"(S`["FS'ie-
-SK1+Y30P'J$@8T+N@iM'1j6F-h'(M%AFr&N3mK0iK6`V"YiN!MJG[jQ&HKQDRQUa
-!U%+C*3FGT#aYdJe2SMX0&`D*3%8S&6UCN!##)FPPL)A(J'B)#MJBkPl#'pQRKVf
-k94-*FY,f`LKmBplDiAZLEM6cR80elj52&MkalhHfdCUkTh%@Fhp`b221k,lMhGZ
-2fcj%cF4M(efdeB`QE#eCSlFqAc[kj*rZrA$9RrpfejQ,&bmHH[r1dEZA2AVXZdh
-22*krr2FfZfhMSESpYUX2,EFe(+UcG66822hG,cHh2(@miBfIAYN+!!"(DN&%3e)
-$!(VJ%&80C&B"%$%elNAr[fh1-9FC-ZaLV2ibPQ84RhHKLEA%i*JLbl"UTU@'FQ#
-PX&QLXN-mAJmIElU"2'q!jP$#5HQjZId5QT1U9#A2HbKI5h)-d)45$YHN0!&+%mS
-K+D@%FJNPKSTlrrjq[cf[K[6fHcr2rrIc!"ZYTbJRJL!)J%!dcjH+4h8k[-6P,8i
-'d"qrJ-a9XX3A%@"*9MiG6"K')#U9T-H5N[qrSrK8*6e3YQRQpCN2TE65rT*pdNP
-T[mcX84KCHP-9P$&ec,!jZ&eApN%NBIKkqY&j)8R6&E0+@UKSp"Qq3"`r)5Jc6$-
-[J!8QJm0L9JDdi!)3b[@Fq8X89QD2G%LHM*2)H)kDKJ+4R$UKaU,-SPH[2RP#K%a
-RSE6TPBT&A,)(r*&L)!R9#0!*0RqR51iBQmV$T%`M)V`kjNrX0bCq2ceJ0IN$$Ja
-SPkk)d2aL%ESH5Z`20Yp4T$dCl&MJ+pb#aM%6KJhBRdNhA"Aal-TRjdPG,LaK@Dm
-Xkl&F4-Yk&bk'5-JeK+Ck93AcXPk%-'&$l3RGiQI5(4d[&c&*Rpf4kJ*6eH2kXH[
-(5R0T8-GCBR4NGUGmf+$8&8MbF@$CR,)emB(cdG5jpU[a4G!KYIZ3!&#YFiAkNmN
-N-kGY,$5TAQKU+ehD`NUAb3a4jNeQ`',`UC%ZI(lb"&M*PBH`U9i%TLeA$*AC8K*
-J-H4-@N044,JU+l10p5-G6(!Pd6TG3cE51+rS6TUGk0*VU)m$55ceBG"H'V6CFP#
-CP5RDQXCc3b)jq"p5ea2QbJaD(*U`U$AP"S#5`)EcJj9J!Bj0RJaXDKMLL3Q4DVq
-,YeKEH3LLbeN6,K$30p9@mVCk5Y,j3PM-$KbB!(UprrI"`@+l16JS'aRp68bSNR4
--chIK)XcJG3B"m"U*cDR'`HBd#h'UU%GBES@C[`KHHP`3a4`cLqh-IQdrS0@m&)T
-RI`eXE"2q1d5,5##I-LTFTVSIQ'+2MJLM"Y(pX6T%8iJ1a#4%@a(pBU`0d5&%Xf0
-f4*1)TXG#)d#3!*BAFi1+!dJ#$)kY)*3T8$GL649@QK,l`B$V!fUc5N2cAldH5TN
-1EI-XN!!ABeZC*CrkAi3QNZk"@PPY5)JIUVpQ'R3f$ATMa!VbQj3KSrpMQr$(($P
-A4A0-2kpB*'2qP-PSYcMJ!DNK%(FIdMU"SFeCIERa%3J4`SrAN!")IJmCIl#@pQI
-ZcG`,SDG0-bkf5qZIQkSVdk`2Aa&Y30hqXA'Kqp$-8Dd[XIml4BHfBD*m+EfV46P
-mN5AU#fkGI$55b@iU9[@"YUBk9Gpd4AdrZr,jF%TNTJIm6rDTHM3f8f2cLaUEd6K
-%M8-[DKb5kQ33F3Jl!8UX*9@RRJTBQcc1b4&jFSpkbRe&A4SQ%$0+k)&5dK"T4P%
-0&H6Uh$D"!R)S&MHK)C!!41'GCLJbaU9aR5lrHDF#!N$)a6ZcZV%j3i()iNKr4*L
-4H$0XNrbXmJ8,cQj-5LpV2h)j-NkE6N2Bp%4Ac[(&YNC#Zh)PIdBZ!PDcp(,*4kk
-EmQGXHG!cc5H&-*fDZ+[m'9XHFDT!dLa*#m"a'1SpRa,$lDcpLZJ5SFad-0HrBa5
-HLi`#15!qPJG1H#Hr""3H$L$mak$U2rK,%HVEaJL@Pl5q'Bh*+k*G*!**83b1LP$
-MED[Y(L%&((Jp"99[IVl(M[8$RCKJYNei+K$(kq%BG`0-UI%JL`LV8bUffT,dL2D
-BPCDZ#*8@ila)KdJmL![NjU3!BT8-pk(!b!QICH,2[dp%@@#4"rC0R$V-,,6`H@A
-LX(ZL'4-e9d5#96+VG)`D9Tk9Qb3d19CI-N0&fFB,`NF,4Lc%JfC[X4T2VXE&iX%
-NIi!NUM`j+0N@j-N1QXbN8[(TjmmRla-A96eHBfScAMI8)E`'e$Dm-Y8@1&E%eAB
-Jfhr%`P(e&&iPDMCH4PAlf(f3!'[1iG@MMZ-98irLG9deif95ac#T9ah&+k8fiP@
-RAX4J(5UVcRXSfDjH#S2TA+bkk2-qJpPPYRe@JqhXr#Ld44YrCr"H93hddF44Sa#
-PG$%qb%8(pDSAj3XSaie"4%JCc)DLamad`BKUaP+GXZ6#8ShDXjZhdJ[LDk"(e1d
-fUiFa9&E)D#S1'30QI"`2AHI0K3SFUd0#YfUh1940"l3(@SMd53a4'#SdaRIRL9#
-S%*m&SIZ#`IcF*mfKBCPS3!MC!B10G$(e&#H-2*ak6KQZ98NF([!qp5rbJ1TIm2N
-Vp4NH-,miG2e*XhVmb4l2*3`cl"R"+qUTCe@J$9%-+Q,j8*k!X[T2VLVGp-CD,UV
-P`&D'E+KSF6PH38$8hAY`K@lcc2!B)jbiaQ-8b9E6QCK9,YErA0c)4ASmZ"!0ISM
-#CESF"&[pKLV4$,(k(HUmCNc%4(X9a1TY!20GmV#eKh8VQ,NC&lVPVl!DH`Q,iEM
-+aJM%EmN2iAhjr*1hp*,RCLl%Tq9j+Jrf53L(V0$0JE2$LXMqPlH+U,6ri(B4V8[
-qilj8adB8RIKTaK$,CjmmM!kCqc,hMDdH,M2ei3Sek$C(fQqrqGri&iL2!)fdKde
-A4%FJ16DH$lHBGMf"MKqLUa8r$[cBmF20caY&I#Z+jVD!#`Lb$F&8`m(81SmrJ6b
-UG)ZD")+i"U,m&4'rP*r[E4*"$6*SH[`d3h&!L0Lk#m%jqXTpb-V2Fpe(5%'b$9E
-0Rrm6Jme'Xi3-l$`HP+ljCebc9qi'0XULi6Jj#2c*1N[i!5)G3*EhLD3DabX1P)Q
-A#!(Jp"5BQp8@[)BSU,G48'p"8"r@[81!e#RmcN**&P[!mTdD'+m&F1PH#qVQca,
-4Q0k**)eKG(b0N!""LT!!34f"G+0k,[2)m52"jSfqf6lM964%U6P&c5MJGR0J+m'
-V9ReQ0hA!UdRpbpqZUL@ke`0K1E'$cIPl*A2I0Y@)j'V8[6kMN5DmLFmkYH45Flj
-hI4%e[CR[6CPaf$i6J$b@-X9M83dF[Ja&mh-,`jbK*[!--AKf3,d*N!##bP%$Y`G
-ffPQH$`E0G"1#4NPkS*QATD3d!!E1p"Q0r*NbV*qkFCmbH"5$G`Epmh`(*JhXRqF
-F'!(B3iKb6e#0fZG!G0jpA*8S'bcYIMqTiM0+Re(q0$UNJD`MMf9LLKb*PKal*PI
-UZ!N!32"1Q+kUd3"BeCSk9FS[9K0BM,b#4Gem@ScL3p*9)C1*#AIk8JFhHY(3U*Z
-2T8CGeCfqpHr1hSG*RET"kY#*)&BFlEK@TAXRGI"0hbd'TN8SC*ImIS@ZZ0U!,#1
-"(UEiD+$"QdaDE(rp&k5'"c%3N8%#'9T0ZF16L1"jc8N%"T!!)J!)6d"3AqiBHVN
-)!D`YJaf[CY0V'lp#0i`LY(HL%133X53ki9UKB@H4adPUc`A4,KjSQA5SfANS5'Q
-r@D9Em50d"[*BT&ZZ*)"G'ZMEUY0*rKQ0'8G5!bDV%`eir0M1e&J,&BY3f3BFFZ&
-bk5+jcb`haS-*MM#DQ8I"$+KVN6%qXKkAQcS+F30"1m6&2GJ6LcKS1kl0`bFAj-j
-J'TTCV`E6C-%"BN0Bf5b+p)$L&!+a+&3[G[HS0FL%lifDqRkU0V,$$[qRJ'#PaD2
-14EUd8,@fD`Ze&i%V%6,L&D(LU5C8`-%UG*@$9HJq,Y4#eAJp(#S-ei@ZSSX9BY2
-&[QfK5b`@cfK%4M[d3XNJYM2j#HKEQIK"2a2&R36U1j`%4Mde,1*'%(bEjfb3!!B
-@a5mim%dD@,)0,%dD1+B-,%dD@-,!fKF0'kGKEp#JcEC"QbF01U3-f[cL33RTKi%
-)&J9BX'kM4,9Rjc5rSl$'5Kq%Ha54Iic%J5M3!mMQZC5rP`Yh+YCETEV3X,0S0MC
-E6P'2-cU*X)-U3$T@!%fV'V-#PI@5i`f+(rjiZBL"!NMhmaD"BQ`k&pQ'UfSF)Z2
-dIL#eTJC%2iHJhmDCDJDk&DGi+&bb,@E0DG4p(QMHM5PU,aIY$SM1((#%lPDF&*`
-k-)LR3eaZjq#`Z`ICAKb!M(1MEMU'XX0Y$4RR@,+T26[RrV55G,N)9iVYB9f1%[4
-k0"i,eYpQCMT`0RDL'!&Q!aAa)0C`i"`,"*,Ti2E3*D$E&Bc#3i@"CJ8T$(dG'39
-M'k1+S)")G49*a!iMbrP$2Yj*@!6ajFaNX5AUH4$qH+$%HB"UG"kJrZ@&$P",h!H
-S*Fi$e10!X0V*"d`J3BmP!CbX#Cf,K5``ZXJaJef1S*!!YMBfL[#)$ZbDZUD1IRp
-62$YRfCD83@T!3L%6+@GBqqlNl'Td!fGA,d**$PDPm+"!%md[&kA-Z$K[32m04TF
-KS*)jF%BQB5Bd$kcb5`GPaF[PB"!AITZZH&EUb$q$cleS2#H$I1K)82ep85b2!3N
-rFqb0%%PZ"X+)D""a)2)8)NP%(YEGK)!Ac$r'))KK0[-(XeEaXa8,ldQpm`I&UGY
-q$23H#2kQJAmi`c1XZ`CRL!mYXcD)3%AEF"SE$MGe01RPKHA*-8(C(+XLjYUEp-a
-qATSc*SkR[bK3#h@c#aPVS+Ihr[L&Ekl$)-mJD#E!3'PRXN)Xl4`6#*,2%2Jc3k8
-9"Hmf@a'm!m@RK-L'VkIhqp%p+lYbHCUQ5bj1XD8M!2`Mc"a0'CK40GD9P4ic)dJ
-FZA@$Zi!eTH*5LI`cc2"EAMc@&BXU3aeT@SfP(@0GcSNBLSF["VZf,aDM)YS91%q
-&U-[bU-K21LUbeU1X,hJ8YSlYqC!!)*Ri'F#2!6mpB+0ST2h-f+h0d'@#5GQ!$R2
-"S$5!DGJQ$9"6PQi!6ADPUBF)fmJ4h3"q$2M*C$)hkEZBZ8!J[1*H!Z!)LY6p-qZ
-B!BR"kSMX9P,rlm1("2%0#LcT#!VN"TTk3CPk!D54%#4DJ9am("L!D29bm#"%&QE
-'K59UN9PPV&6!pDc-D'fU%pHGV!Yi3QB"*CST)h1C!%Z+fEQ*PeEdC+CE-Vk)iF"
-S#U`aCRB!4GM%IJ3aU$28b%J3VqL)KJIBHY3NQ)9*D$dTLjahq5)!8FP[#D3"!bq
-SF21-M4&+RiM'GAaYlLlLr3+XaABN+G`lp6X-4AIjH-2'T0aX-AJ5`X'3!#cHbB*
-GLIG1heeH4BKLT(!82pRi-4S[6EV1J@$L,Kp[i*G[d`Dd9&30%-+pbL,cA6lMd8Q
-G'NY1'ZXQ,EB%*8be6PVf"j[[mNNH5lBXXiJZMUYMdXZ*Ki4$SfBF*,CD@)l'&Pe
-`#FG%KK,)EcIkY4pTpeVA"**K4m$rQMq`c1%`q)C#"ZmeXdD0Z0P8(Hj13+X1Z@2
-'XB!pM-j@G*iA#QbPcQZFRHZF,+BCl'3lS[YkHZFmrIP`&cc&i3J1e$L$+LA!cBL
-3!2Y'4"r!mTaJFSEaKJJNqcXH[NG[00EeX`#!!Ja*0Q2`L5lrQR[dja%),CB4025
-$,@0GFL1$VY-&9eINc(J6iT@chY1i1pKY`lTTM)L1XQ)!bdE4-Fr@9)5QdU0Je(G
-mBPRdN!"JALbid#VMc,3IQ@P@ANNHbMjAkBU3!)&Ze"AG2-R&'Lki2$[RlP,1f%3
--FYBQCTHCm8HlF+!"KIPdh3UjN!!lbYQL-I[#M*HcRN+"F6-eF&QeIqA5`#rq8qM
-4e'V,@MBc%qj*bNa#b25c%N#Y`dmMILi#a)B8CC!!`pJ5E%29J#5pl%Bl1MQFRb4
-Q$5PCDcm(r)lcA#5`LN1IQ6S"4qq&iehXc-m**QH!daiG%h,bfIYd1Q66K,T6lL#
-GH1X,XG"P11YecfB(picEj3'ZFN%$9@KBiI%T%)d3-jeS-0*eUec+H+`!`Da9bRJ
-b%a8H#V#CF&!r$pNK,"8)[HJ-1ZEjUQmJ%pQU-1EM"fTXM2N%rMIMIaXbbmeJ4iC
-%Uj%M(BM%j3AAMi'DJ1Lf$i&&fASmh4KfA3@MjDVJ5"YqV2KTK@+K%dlXhhhKCN5
-L8%)akNKNjfbVEKVri[lErbC[N6H)BU31'd`jYbGeiF#SP!%4,m%S4%4R02)4SSj
-jMkkV+PFD'AGGqRqq-B&-#3`L#DiiTEU('J#JiCm9c,%)$i,Z+I`NL0#r+ZqE-!5
-Mmai-)9N1JDi*lXTG2L[rYqS*AGUi!*J`1F@664d"2j,c(r[MhE-KkR`j08$XRqX
-!&iHKm&dlJmcAlM@C[`(@4&KFGZ6j'Ab-VCS1lD'f(`S"*UkQN!"CZGqkTEL`6a9
-3%5Dj8JJ3dJCm)-q'SCJPBm9J"5CcCMS!rp'a+q)!-R3()PI%H63H`*(AqEM31r`
-CI&pQed#!AJ''qA8Xj)*CFjfB03LD6QC0D1Y4,SUL%&jf,N$(32)SC369,ED!T%9
-@,)1#8KB&TH1#@DmP##,A1BKmHm#`hHK-%%j@*5KHj1#)M'('*8H4&f`m)bUef,(
-Cmaamq!I%hSaU&''jS5KYBN2!(US6Ia8U-fq-RG*!jK&h!*(C%`Jd!b@mh"PXIV"
-Bf1N`#CR3FB9pN9!L+96MXjIiN!$YDD5L,!(KZK'I&qNc439EJJZf[cZ(B6CeSp)
-p!KF*L%-$ik-%JPNRll!m,(N("X224@+4CJ5B$Gc+J!qP9hchqjU%YNm'IUl+m+D
-[F1X0I'J2MA9SqU6NK'XhD`kPNV`S$`LPP2ekr#Lc4"+SeL3MUaC'9L4mq&RG)LH
-cbUkbECDCTahj*HNb'PH%Y'Q+N!!'GJT8YP#"Dmk!9I8RYhK6GXSThSaX)L%J#mL
-c&cqZEl"#I4c$)8JDKXY1FA%"NE!1Pi!J4!+3!#`)fG&mcP)3H[U5,!K092NCIQY
-RaaZUH0&hrl[9l$!lDT8k-Sj"3F2-4hm#1K9(1"Tkba[b8L@3!)GEK1&G+E6$*eF
-+H4fZlh+(@2jSlX!p$Se&3DFj+PIkDiBkTq8ITZF*8fk-eGe#ABj0X-Mc(QrK4KH
-8,k`JI`p0-d#BS8"b(NMmFk(QTP#"C["rrEJA49D4C[b$bZrf`UfTL*80d[LYcb3
-*PCLQIe!Ch8X+lE0"4a'62NmD(bQFd(JdU&,6Q$4qk4H&PNd*Ce9!&*26Epk-qh3
-k!AaP2iEUPH*@21GNG5M9dH54(5@iS,c4*HQcS(Jc(3U%GTk8p0L5ZX"A[FQdKjQ
-LVA#PL*P5IQFAGU`)k*hUlSPG%*AF8q8T'&STN!"[S%!@#dha3$0PNUB"I$S(rjA
-F+4iL*[TKG`CFk&(mDm(!d-"pD2QmNpIpb*)Ul)dE8"df066*iXN+&*V*f8"B'')
-*)dM6SCJIb6*e`N'5FY#&IjKZG+!c!rJ3-Q1EUFSMXUPVR`iQ-$+!b&3MF49JIdm
-'GNd(9!p1YX"'Td-3XXEXmZAijVSrIZ'Sji($$r4G9V0clXN#m+(S0[80Yb,Vbq!
-J3LJiXh1qDSE)0a6G@j+1!N$r0khZ!FH3!-)LdBFEG3q%r1*RaTE*MJ0K-,*iNY@
-RD6F8!F`fj[ZiJNFMR0([rPG0(lXVSR!CSUTSC9h)2(leA!X(&VfT!mT5IibVG6C
-`"N+h1$YRdpb8S55G&jb*#U"p@l,(p-`DfI6P#$IE*c3E-9!E"LpYDN"P!$J@2-e
-94j&jTFUJ%0EBKDNTcUL%,V%,cXSF1,E,RH"%-"-C-DJHG&[Kd)),L5heF2l3HH%
-HC!!ClVNX)#lZS-il))BZ)9E328"'GQB&X3["2-T5a+6,DMd)HbX-"m`G8Up$BaE
-cKjMBfMhDRRPpKAc)$N*F1l#C-*Jq(B&B[8MX4q@p*HLS-3h&%KU`caQ"A[0*kX&
-Y3S9)%CV4D#d64IMaDIZbHL#-Bm!&2F2jP(cR0Af4*$28[q56%a"CJN`+'$h5rUL
-*'8jJcc&+CA'q$5T&1GP6YSk'54he8Ur5%8i-b%3QQ4hhT3*1'(bJD2l5F6KIj(a
-ee`4f&$QLJ4AMH&YmFpfBripIS))h$8%"&HBf2F#98#'3!+HCHSCEkjf!PmQ!Yh'
-U"H!GC@6CiR"d++"R4e5)Rh'@cYJj'IKiQDGa*cL-)LRUQ)'b9HUiQbSC)D1H&Q$
-J@1Ek-5VZ)31im3&d5Q2`Bb$6p$!"0KV@!R3,0$d5CAqLqfFdML#46$fhc*`i05,
-$a`P8TllTUdiKkeN8Nq`NjXA#5$"@LDY5r1Da$#M%A5dC2GSq5V#qHAh$43bkFJ@
-@p9[@!XSZU2f8J,$q09ElmB,&K'JE0[(bP-#BIEJG&B)#M36#pRj')'!S2(hp"JH
-XjPJE#+dMSXc9q9l*imP`'L4bJ"&`-YBkZD2*6"e4*FbB583cb9@FQ8"0$4C"Tef
-ThL`((R4qGRCG9k!9JrC5FMZ2pGU1IAZ8JCZ6q`!kPfERE0Ji#Ga-82UBf2N3!(H
-8!&92J(U6UR"beiLQ*d@JZZ(,NcVE+BP-NSH"&@#&bN@-+$E-CH,+J,YK[KY`0hc
-#J2ZP'ShI8Kb!baa91VXX8)3@UqmVKHJ3#4mSh"m`M4,c$-TC2p$+NY49pAf!5c1
-5[80NACHAGf'TMUH,R6`)-RiYF#**2QP3hjH6F,4,'5$RXTUR`LQ&R8`d+@B@&+6
-UK0&i3#BdL4LHb3,',iG'C8C,,`XQQ(#9"R$)9iYTZ!-%e#``B$i'Uk"aU9&@*%,
-%4JBelChmUU9IZFYRkSR&&a5$PEJ383P((9FZ%SB!I0c8!G%e6*[BK-$BM'*),q'
-JQ4FJhVl24,0EZ,YeMXU13C`G6#MC4a409i5VkBVSD@TJmCBckCaeK%"afTCaR-i
-&HBXYkrKbqX%#"'[IB"F08c%+!5$@D1r4Q314$eSL"VFTJ4HB2M$c#@c(LS,6JDV
-Mel#"bZG((c&`)PKQDYc1HVU&cL5hc2cHk#,"c`@bp)$j0Lim&YGIJ#*J*YcT2hh
-PUR$TLS(8jYGH&6fkD4!#&JCAcM#kXm@R+)2%fe-UaPYF1R8#B-+&,E%q8I6E'TY
-ULjCdcb*3YD*"6TC)+bFJ-Z[GPA)f(*QS1'r)b0[kjX4,@9a)2m2Bhm&EYNp`6b5
-'(LG[[XQ-`-0UX0j8lC6U51f8i"AYP1SV8*0-#FUL"4"$MVKS-Km(5&cT3f22P#"
--E441UBDbl8B`K+be(JejD2#aii10+EqXbF0$+&-GF[8$&YhAa-$m@!CA69CAP6N
-(@l@#83RrB%S2@#Z,&`"a!+KEkB+G*J6`30Z9`LRP8h,aUTqbp`U'Q9+1`q[GeEV
-"X1++D+`q(XMmb''G(kCUe2'hrR4lF9#0R(#c0CN)lJZZ#L)V!*)iTNZe8mVIZSC
-Ar9[&3QEhSQ&9*V%eL4b16rPD0VEQ0KU-K63f,E#Cf6$%D&59T6)j%TU2b$Ej`l-
--bE10#`Ji9U'+El"M4Q-rh-18,PrQ!1iqJ+[#-ZX0`FbU6#PJTh!jqd%,Xj9$"L`
-119+2bUL(F"#'Dc%k(%2cIkJ4R'QIbQ*)(fA*89$12hClPmAK8BIrH,UlbU[XIKG
-'"JaJi'09[f!A,$m8hDUNIY$*JRH!&9e$8C1Xb14Ahh*b[V6,(@Bd'ZVp("LCjCa
-N&6pFjr5-KTrSBD4eCApP&X6DVJQ1cieFD8b`1bP3@DZ0J3RP@&DJQC+&QTlS2-k
-1TPN6%aD-J`)q-,'ASd#P3pQ9%-5d6q8&$Pd!TjLMIrf[@4p"b%CdGXkQ0'60%(9
-Fc"S49Pc+iFkkb8",e@D5%ipK!Cf(IRi[!fG*qUdNS4b),j,*PRc%KQ53!)3kbMi
-1FJ6l8eQ4eIFHQFVUrALGq1hHkhiYR%DNMYrZPE)H[#Qc53,edQ(Y'BeIfa20@Re
-6K1dp`K`lIPR8#lMD&#@b1-ZBiLcMaG%@GYC#SP`FID)mI(IhD4mY2rkl[6i[9qk
-!5rh&F$MAPcTGXNplU+3(KM`FYppK4UH8"6B+-dcXp8![#RYQVi8J0pqCJC!!Y,@
-CZK9iJ4%""9krT+eah2[a1PpYVfiq+Lb0kYkXYQ[L-0XabX+U88mIpIb"bK*F'I!
-e",-M(*!!dPB!C5l+%`J!#j!!)5KP!5bPC9,3GRjSfmi2,EEc3pYfiYM1$hNlB!+
-95UG,UR5PU+UbU+3AefM@,EVp'MDf30,+'e-ICA8BLjfCk4%Y+B,58N*ke*k8Xp6
-NS&(fZ#pF%KQ5HL60H(,(AXZQ'R@0,ra-hC!!G)JEA@D$@@jHibXiecJN(HCPYp%
-',2m&PdNV`B'iMPqAGRZ2"6(KMVmUc!8P""Gl1Hb@4-$UA$hI8')30d,D3iCImfG
-*5BNB$fAe'YlMci+5!R%dG1U`iA2qV#q"le+S"+jb-"Z#KDNP8l&`cNaCV6+B"K+
-VjbG,`PJm,Lq@@LkHPaFAZaFcAABS"JU&EX6eX!6%(9kQA(8ZNMh-ef53!'pdT'!
-QSLk#6#4-U%LHAPr4fDKRcV(6[YVRG&[[r&(FHmI96qSIm%VYpBp[(ibdrrA)AYq
-'Nj)I%ip&rA01BZ+[3)c51lZ&2qlGr[R[6fhb5[&,eTf$dALjR4-iGI#1D9)$1Tb
--0Xc*T3j*h64d5-Dp#5RiTBeHU50[eGE"QSlb0AGA(I&YfLI&-6dAdmr5G,XZ(p2
-YFHqlEfaHFCGAmPc@EaZXmj5hh9fjalF4#YPHAl5Kb"[Y8$SiG*[3`4(hrMP[9F8
-'Vq3IHIcH`C6rVr[1qZik0Q',-*DPfil*eVMhm*RhkZji9fTiflTLX,%"9krif2I
-!5DQG0YUZE$5-DNIG)Kch$QTk9p0'9p&'ebJErGbfd628S99AK!kYFHr5hRp3DD0
-kfQLEa8E2f$BUkGCKZK6hrXShH`0[P%MZ)C+ICC,60[h+p)4Z!kBRiYjp2FpAF!)
-4dGYPSU1#IpPkaC!!!'dB%BAi%GdZG)c%[6VGApkL,DqL,DqK,A1RGL*rqaam8*F
-Dh6*dUBPl2cTqacZmE8U!Z*)!CcJ"LYJ33iHbEBeZ,MTSiYllEUk*VM8"cYJ5i&(
-G9%aqDrFq[rPfj-Qd&%ANcNB2VTdMfAP5b39,BPD3Be@e"ap'ipp0rkrZBYVq
-+YZp-LR@F&)f#%b0KRh1D1ShVGU$6H0clmQ[*TpD5(!hBYTh*LiT%TA([SXiR$e!
-b2-(*m%Xj'H+8B,NdDA(F@f4qhEcqAFPqk6FihPkqNSq2([cl0!@%9bV$,BYl8qI
-228IN(L*b0a1j2k*NKD1he&k8kr1b%d$Fpp-&RaG[mS(-GL+c95(c5L,F5LBFKY`
-Hppl9j2Kh)Zm660jIbZ59!GE$5B&TZq,H8)meiqr[5L[TLL[P+a**1`K8lFU!1q,
-H$4rFkb95$K%TQjA0V1-NBbF[D@A45EVNTVM[YhrrfY502T!!d%iNY")*2q*NSZh
-BLml5e!eahe1rqkpl@D%jJB`V#5KA+S6F%[G1q9llAC-*5BM$!K9JDRlFZrJl2cM
-$'b*#VP3)Z8m1(KD%A"Ih(6TR[AmYK'a3!TfmmDPaErFrrE6Mri+3!02LhV+rIVH
-8%j!!VYKJ5fSR)Cd*8a6h"Qk&eM-KmiC!(#DN6"b23Tbi3XDjFGrhk`Ef-"RVl5!
-1Nr%VFP"r!e2ImXV*V&[b,4FK[9C'HMrp2MB"emAriB['DFUkZ2I-2brb8K,[TL4
-Z8)MhDkRK$lkSRkB"!![rrep%1I"b-GFB0aaf(5E#Y8FEA[G&1fJD%Q,ThD0f)XC
-+*NEjEqkH"A+FN6cr![,5*!5-6plCeX2"Tlk9Vre6T8$i[5rD6P-faEhl(rMrZSP
-BZiPB$ECJX4)App!d%'V4(rBEQ9"mTCTf3kqVP`J9MkjmhAPa!2!lrc)h5!4B58M
-r0dkNEb-5NM$brllp(PflPDrp8`A4r-&*T+eallB2(PP#B,1E`+E"LGjrlp`m3'[
-,AcA(R#5+aJd(A3ITfTp,+rr&H@d%HIrH[h83mPK*S2mE*ARPDmXNf"$hVYq5rbe
-#(N`Ncdq26%VBZA([[9rkjYd8h(C6F'Y`&j@fa%@Jl*U49mSATf4E15RCC#)"1+G
-pjG4Y3X`V#G4ri`Cehc(P8L$#iSHL285Q&LE6r6C!pje8L)"%kD[6rC'5VSf56Qq
-*,U,fd`M)Ve1eq,K[eX),2hi!!Hl5'YV!UJRSBL@QfQRUpVL[l0@Chb*Nd8!Nfqe
-'&VkcES,FrXXc8iKN,8bbqff)`THVN!!$5I5[pRAA#%fd%CV3@k+*D!-1pG1KZk"
-kq1[Lrq2[48M`0C6JUpaS`RI'$FV(F[rp35*F!a&ZpeS)K`"fDr$Yp*p)1#48@Xf
-p1bB6cSNHL"`bi4E(IGp9qka-Z,`eK"j@ZG'$M4`!kHcNQJmSN!!e%'VBVD!'5i)
-JS$fImICT#K`Y($MZPj&$R+j[#rK[h&Mq')235"ZZ[a*AQd8Em&YX!#"8GmHGIf"
-5%-(L#X&1m[9"-)m6V(pjpZmrBP*38[U9T$ccTCYI(46qH`C&mSj"BBHJ@6V*35-
-j)S+V)2)2EII1!HY@fiI-3G&6AVp`Y&aD9H4pb[HSd2ECqb#XEUJAPe&r"1+ebJj
-Xc)5pY1UDldl[h4mGZRr+ZZqmDp3c`jFqLU69ZrCH@[@Shc!R&FSmIHld0#m2R0$
-8L,[hj2S5Th&S`jdRjrKUe+LQ9Hck+1%jIRUD6jRJrGfHBpHLRP1i8U-bS9brjD4
-lJX(PF['86%b*((31SE8B)KMqAI'aI`cfAeT9[K*G[G(92rhSp2`D-FHAm&jDPI"
-Ni8T43r6KDZ&Xq0e(*kpKHM00Khe@C`-M'fj+H(JEdBIAfCT`52I*DeR(N!#ekd%
-@%H*mfLk,6!Ha8q3-V'L4@5YUA'%Ei%2XYA3K8M,XMbYC)&3(NRcZ"DS3G01pJ#T
-"&TrHfHk2Ek[M'UAMcFPAN!$@Z,08ML*TM6[EaCr1$"Sq(RF[IeXGP#-G2MGMSiY
-C+P$(6PQA@TfR4MhPAEZkjjbYm@`kHm3,&`6rC6AUap+a1[r'BhZmEd2pZRd[JPX
-V"cITmEGbJre&Z3I[Rck3!0,B4E!rkYrad4cI`IZR$TbGhbULIYG"`d&HH%pC+!p
-M-#a-Si9)4r6aeh0jJ#pJ`A+!2ddDi(0P3HlqDlPl[+DMc[rlBpV$pX18LBY*(6[
-h4M[+Z`MT[5[&m4QR$qr!28Qh-jpG8VBFH4NZ(ElSKYIAh9jL`4DE0%&DEcP"9im
-+Um6-B$0e!+*k-%DQeqDT&`i&G+@eH4r0qUqr%N12`+ZX%kB65RmcV(Y@U(JY%5'
-m[LBmH*8*2ej,43GHD5+1PdkdMl!$YGiB5Hb(%i(GB@9PceXYVPB+r-PU[mNDf`D
-'+"Zm5Sf!BB'&,A"Rc&FZ%Ld"fkT9BG(S&V%C3kl55&8E&9BIe(hk*Mm8T@G0T"i
-*k,[B#2*&X2MK`+!C5JQSrC0FC4fUb)Y`R`M*3!-Q4TVG,"UK*US6cEbS#KM!8bE
-Sf$922!EPlqKF%F*")6TNQ!BI"AX8lV"fGL4,LcP-YE1@J)Nm2`-40!bLi3Nd*&h
-b!S`$`9X198B4JEYNl*cl`%"f8(`36E&ck4*ff@NDccT8NSA0,qPH+X(&3EI%lB+
-8kV+IP"h18l,$H8EIrE1qaUU4*rTQ,@&h8'-0MZM5TGe+f'Z&EYD5kfeDA!%"%kq
-$pmpDXUD+e@R'1*1YHfS6Xd(p"YQeH*'KX$LVqr[dLVLdVLb&L(jANlLS'(-X"j[
-d90SL`h"Df@!jXr%'2i-LLUX*LINiiRUR&P'U0X5-),&QV[K[B@Zq[G2Tj)%"PZ$
-(iXM"$rM9K'Y"TG#YU5dqC5M+m[@MXReaLD(S'iJ1[ST,LX&F0RQ*b"%SqXd2&Q*
-L2C6k"fL3!"RiH'S35LKFlc1kEK`JXa9%C5EZXX&b9(&1T%i`ST39-Ghl1)%-pHa
-+#V0Bl5"bHF,3K'h"G9SQ$60jYl*KJHl[bi[pV'kZIH-k,E*a1E!bhbKJ)RErL!X
-`*CP$51ClQH5%!,P+NS#lQ,ll*&MpADai'ra-RXE+K*H,%LG55Q"-@qaNj,I99[a
-F*MAm`!XVZETeK"aCh+lVTk&1rC!!'dd4pG@!#a1qVLK9aq3Z--%k`P&8GDR[@j'
-f'#cEiE6&['3S8"GQjrafUNbZS*V*UPNY0lQ(LE9#8@0RiS6BGIVbmA4P1T4RS45
-j-B#B-BGNJMZ)F'l6#$-"hlYQU&r*UJ%fE**RmN(*B69jf26!pc,GJkJlPF9a9Zd
-`b"#c'3$$9BfTHqA6[FlVbX0p68Y1D5Pj@qT#2KVZTBd!a15NU4'B3R*[p4e@LF5
-QIRZ%ZAFqZDijH'N0!S,kDMdEc+JMBUJb-E$3BL0qf),iGLG4M@aIr0XQUGMbNdJ
-kCRD6G'QG*8NI5l-Bj+DbZ1f&51S'*6BkmpX@HG1LALC+%jXk9Z8ZE'cjYqF)TEB
-&1QN`6%CeUBA"1%b9@j,'BGZ@DVNYa`3M%aC''k4*4KXm-+U"J"l32#1lZ3iC8iT
-D*SN"V`%ifmB`aER)KRerqaUaQ#f-rX))dVKpSqD`P2bJ%fBbcV&LX@Nmml2EjDa
-qkjkCkNS0)#Me*6*(e)c$K5"@F"@c@%'b*$Z!ErFCrBk@PiZBU98$pDA$`dU90S&
-U6j%ARMTEY%ec6M@1f6[%UTmdIB2Pp+5Mii6JTBc$e8*AIQ@J-LJ0!+J2i[VP(!f
-G4V6qT6c48*PhKBe9kbVITSCVD$M08FrI%6h,d3iVSRX`q3H9(r2N"PhP6@T)S'%
-K4q1h%Ch0dIC2%AdINjXVCr,NeEV+'G5`!!fIFM6j2+,&(0@2)PT&PhK6ZF4Ve'"
-!`cb10Rb%k&b1fUFM@N56TbQ6hl1XFL!jfH5UX9R,&3)GDpi#,!JY9caIFc(%,S@
-hlV98D%C)b%eZ"i)h`)QUYM+9AEQSe&6Eh5HVkef&9DH-@6#%N6,PhKT)qEQ!e#N
-&T%jha939Zp*AG49ANUSZ[94B1EhU[+Zb5JXe9@ePh&"Be3ZecM)HLJ2$bKk6J00
-[r$Y6CTmFIUfrYZS8&M@m''"c+0-R'%b"Xfa8-DDF8&4iNNYb4+h)S+pjbj[bXK(
-QD)e!eM6kN!"!YZb4Je!&V8QXrJpI!L,S@kHMB*c$THjd3,pcMcM0f-%BfVN(,[h
-qe)R)LFQQ*"4K[h'YbUTQ9P1Y68R&4'`2mb@KT(*F&Z@#"H1XI6b-Dp!IadrSNSM
-ZMhSP9HZl!)-2NTV&ND5NRZ+)A9*,11+3!04c(,&+kR'1K#8B$%@NYHqR3XVdfVf
--U!VRjI&JDj!!Q)q@L(c[&PrS0)XTdGGVa#2H'U%pPR1'(FT,2Y+HYCqP,RI+cL3
-#CRE#1pbAAX@%*9$KLbGUr+&)M6m1"pDpaNEYDARB1Q6(0K`,83@m'Xf!H1SBIXl
-@3*M22mY'0$RVp[VM8R[''6K@6Rr)j3mpe112`lebQI-JJ%+4'`84+Lm3jmJ!rcN
-iiU'C2V*0(0AcK#X&`PK9a)R49)[11H)'&a0341Z-N45@H$Y0%E@C*b2##RlTLVQ
-U+*-VpqXi+RRF+)YG9&1b)A'ldB(*"SL4cm*JK!k)r%1q`KZjJIL#bPPlURGqRBS
-b0L*#kPbUDR9AjDb2P@PF`4rSj8IiJ&+8PE#eP9$XVQXKYam(AG(P(N4@IV0T%Na
-bjCr-6#Fc9Rj8hj)(Y$ETPB+"TdJmF'Ek4"-m6M&P4-#9iC6PPYQS#JRN1ES@Q8!
-`H($GA3%YiM6()V&*PiPGb8M*M,[-9-MRS(SP9eAM!4*`E4lM3Y3XBL&YhiZlST!
-!f$2CT0'BA'N`b5iHX6T6BGA8J!-"HbSIdhMk*A29HmI6X6`03DLfq&ZSQXNLA[[
-J)kE+#Q[!#QF4N!!5(Gk6#LZXf6IKS"A5H2Va`!+&%#4J#X'19-,Hr4ZTbqllV2a
-kM-dpp5X"&pXT4dHr"J[S1N6Gp(4"L+@TB6NM3mIhdPA-R'&jcKFEj5`#98&'*31
-HJ%68`q@q(D*`C2+5+i"V6ZYq'qK`'Ll[#,!61JkJ`P,HJ%2H3&"dQGR&)AA#+Fj
-$pBk,"P)34r9`%1ZNDh!P%KL0%AVh`'cDUU,"f3d9B@3(DqXcr'J(pqE2Q@SV'J,
-MMYUUE9c-'AaM`S8P)Ldl6La4K1VP%+LjUNpKeEEZmkLFUEGpRZ#(466C#*LfaG'
-&5cG54U644RU(E2kHYmMGA)pBZ0UhQ@UVTJGS!$41arEYf6H0c8j%+Lr3-%PX4DY
-N+C-)M(CkN!$$32TK)R#5$IYX[bdEq&RfLhl4260aJMI3l8KTB4iL"$G1')NJ4di
-X3i!D-K3p'N(eQcN,I3ZpF2(HbrpAl-dr[G1(c1B-GK0V+'D6A4!3Y1j2lSj("cJ
--lk+l&Gfp#hd4VFD+!e#%m!'6K`068BXKClk%kS"9dr#+9Nfp![1I&9Dm)K81UMM
-Si1eMbkJX%hN!!F6[!Q%i14$CPTe6Ck4Y3LaPTm[Z%`S*je`j8@&(TXCRX6K9FBl
-R"lKmdMqqr6D5DbBQPH-R$i!L%+PQ!9#dGfpVUUf`@hD@HQ")[PMUJe'qVa"J`E8
-+9aU!N!$j#DlPSX'8!c"3%"01pBm[q`8qkM'N"d0kQMMMG6`ljj(TbK"'$+((%+I
-B,GIpU!'JGFlD"4!!@mQP2facklF9SfPfQp-*)9aNMTr&Xi&b)#Z,!%bb!%6`!!`
-#q-Ij0HYCRM+KfQ5p1Q#DT`i%HUJb4*`B$(&L-+5`B&@bpLhmZ#@&lGE)Mab4Xph
-)'$6r4kQD'BJRY"#Fjdj%V,)j1MbDSl+LjABGVP@$)28F9qH4'bl9jRZ[Q#YDM-h
-1TH-qAR!qYU6*Bc&%jqd#)+2aVrd,1h3bD3D0E9fa835"'hJXbQ8T%iiI)E"i#N3
-F!!`h6KK#5DX1Fi9m4-ZUQq%H(pGYVd8(hEB4&5)YCkAaS*XI`(e``J8k,4beC!0
-X-R&K(XcS!MZ(Lp)Ef6N2A3BbpXAm$Sqa4Y2AK-!lD`Q+(Me(E*Pb"U4MR*&3b1m
-jRZiF2Qd(Zb8k$I@Rj)S43e34Xf95!FHZ6H3k$aFcVQJDIY'%&RN#3'NZ'@!DNee
-)Ki)`F9GEN@#"D[PmVZU*+VJ`[X*9j$P6Y#D,hCMpD93T*%)6MV)"-XX#L60S6L-
-86jJV%Xk-BQcL8(SD#NDcGjq&fB'0,0M'U0)b3"kX)+ifL#c-,bk9JdJ464HC#Id
-bLD36"R,-SB'UL4"#T1%+F*-fe(-QmrQT2#bb[Th1J4%`3dK'L0*24j9"mIJKUXC
-DrC+jZ2I+eG$eL[0i'5[10HPG!@UkVer)KJANL1HN%MQQ0&3MmS8L',TUiU,0`aA
-)2EZ#CPj#%1d-a+pFpEaGFBl"!Jl3$3M1+CMRFU%!jNhEUI)RVV4m)kSke"DEjPm
-0&34UD(V+kCkXJ-CT621"H)Zi+j`Aic+B0(A`CYRjGr8"5R#KYY%!H(5C6"!kDQe
-ND*A*X,4(*S0k6LD$UQ8bU0P-"JBCDRa'hV$k&i8!Tj9)VY*`$Sm%)e%(6erjRTX
-BS3fS@'0*M-X9j`"UmkKDXpkC9("RR8#Jhd54PHk`5-5e%!S'lAiLS4bE*a)+alU
-)&#)d5S'd4EPNjI,CR+9Q8T6Gb',f4KN(J8A,6%*fji@CrdpK(+%B&@5QXAZXdc'
-@6%-dJQ'aN!#c!dj6+L'J%YeF)+m,Z2LML$`CD)5cEKe9FANR%%AKme`JQQ`%GT`
-ED!N0TqQJ$KaqD`I8NIakaaLA&a'd,Z+R%3PehX6QXb4%"b)'*0imr,b'kl1$H`Q
-pQ$PNa6'GLPQb0VVF8H9b@Fl,e9j9fh5Em'V4lH!XHShi1L0`cebBSq-(HQAR*0J
-ic5Dj'NFLM)mGQHQmFDIc,4d`&ML+E@3'kRLEXF3V2@NlD[[5GS+9G#mMNUHZSLL
--i"1$228q#q)33Tc%rN5Z(K0S`e$Y-+M3l!4-E1046CGLCU%HE1%)1HC(')@`ZC1
-EJh!H&l+!rkH`,1$(-X%SMJ4-Q(i85H3L*QN0M[Nb+S-LdkL,N!"CJ[fkSr`"Plm
-"F[k2+!B+-V'eipKD66!b`dM6,mJ)%5bQfR9IP0dbXh2XMb,BlFe#%,XVFk*Ce#i
-*U(J)9G9DBDLb%kLCX`C4b81&hl*!%J*+Z0J-!D5`f1`UV%LjDSX$3A[4bCLG*S%
-(J1$kk%Z(+dZF#kJfG"L,#CPpTViU#j2MJLXJ1Bf+)G'5L'3bJph8Jm)'CJ6!DN&
-Pr$DZdQaM"hCjd*b8$CK!Q#0$+BE-IQBSe9DFGaB+)-B4"KqMDI*J2+8V!VCLJIS
-2rh1$8F"-iV%R3!%rk*@CA&6PZH2!Q+h+-l,Cq0r)2bmGUNJK@2Ib`kf!3&BKfqM
-i8@A&HFdK+FN4ia"0FAib@k,%iS%`'jd9"YN`-*+JHB5I10,eFcqFNEZiDK-A@Ce
-E+"V[4b@+PL)#S#&8#rN3lUFEYIYXdkUdI94!ie%MA%!65h"MIHGXm`frTJ2U@6'
-%`2%QLVPErVrK`5mdB3H!D!HBrSf`S06SA06kH,P[@9,Ji@-dc)a'HjrRYr6BVKT
-HH,#4(JMS[&30A8U2ajZ8%q-H`DG6#L,SZb[!,68i9F`X"M5b5r'N!MKPcZ1-4i)
-GQ-(J,A#b8Q'+T5ZYJ-eISM),SR)4d3%63'N&-"daJS3U8j!!,3bN4)!S'%dX06L
-4h0+YPJKZk@)RLS33N!"Ne,Cd8FcfF+qP[f5d&d19U+@r("%@8jZ9c$!J24!D8Ir
-@Yr49L&C$6Q5eG+(c%,j@8cZC%)m5)eBId-YS(-@pPP"'1dm#QB*)TXDaVS2B,0a
-[C84pH#+LCY5qb%K-,Z'h(X4Q*L0Y%kiDL01eie5Gp"dX[4VJb3YIK%32@e4&i+(
-MmY#H(!9j`5c1dM*'AN[,eSDmTKeAN!"APJN6!pQZUV3KS0!f4PjT3N&H&b9dCq3
-PEbaYL"GU-p-N4Q",bf3%PTDS2CbQ`43K)c"dZF!XiMqA+eH+!"3H[S(#H6+V)L9
-)c(q5`B!UUUFCl8j'$$kA6@$#h$Z"#92`!NbB!TN*dqKaXf&b&[*'Q8L,GmTA#Rf
-iGQC-cS,m-cqC'C1c8'E'6'D!T!M!RKF6*KI3B$Ra6db(L04Xj06-TJAGc*K'*c1
-Q-H-3YP91CTYc@VK+!a4mZL"!M%h!I(`%JBN$&#X$)"TXYTp4M!J9Q2B&f$aXh#R
-UXY,,"S)!60fd9r+!c#D!iG-EC8+S(c1!SKTT+B-6M0K[UKeHDT!!#q@88LJ[X"A
-+V6IGKA*VVP`SVa@-NGb"Z"L')Bqj,`c!,`Cf5h"qHP5qSYL+kMc49hU@IP*lH1Q
-R$)B)S-9"-eGpB)E'dNmJTZ9"D9eC%3Q-Fi%2mPP[#&5l2B5+!q(aMZGkiCLI[+A
-2l&[3@lM%#1E9JN1&5q5TMpHld*("Nif$9G3%fR$8!)l+aS3D$$q!53H3!%QqRR&
-S![K9bq!ReFlk'#EjUMRCj16#ihG+h3NChJj!33@`d2$%"&dqcb*")b3'LU9@#`F
-62&+L9@([-81+c3Q+c8L3!"(mA-+R&K(T"+XJMcb(5Tm!L5*Qfq"aM8m-YQQk4PM
-e95A"30YEpeIF3%,2`)CZ$(lQC'V*5Npqk+*G2k+5X1QcQ&iZ6`ISlU'KVNGB*8q
-XAME`aTAqlAl4#%@VAcb"$Mf+1VZfJS*6plrcJchKlV"#YhMQ5e%I0lJ#hImZSdi
-D%L`k9!+MUMhG06HkZ%L,S0*R$&@IZD(l&6C($k&UXD+UJENVCY,)&a4EQ&N&K4[
--pX8Z)X%rV5dFR-lCj-(0p*Lb-QA`lGe2ZJVI'-"2YJ'4`5!QDieC33mk`X4jbc!
-UG1PPCjl"IkD(U*BUjQq@G9GVZZ#DS'G6995j'Bd3l3Z8CEZmCDG)rhJCYMA1C*,
-S-C%C#0"3,Z3')Ucb4T8e[RLV6&Bd`15k1`RdHcN*('aib&Be5-NJ*a@QLF2#Y8,
-*e))PCl8a!p1)f6VZfHjNRr9lq-'mJBZ+DYeMS9L[IF-S+mYC'3j'VN@(iqQacCD
-X%'3qDb[k%6"Z)1Y3@@(')kZ4P0eI4k!amfDkVBMHN!#hL1T+5@6Ip95*$Jb[aiF
-X"ZS!`f2X+B#c@)M(Nbj-4-6lVhPMc9'$p*!!Q!QcDl-"hYGHJr%,RZJD&*p`*'U
-i8#!@L[IaQLeQ`J$6l0I39&KJ'K3,Ecf+LK-,*94JeLf$m0S@$Hh`$Sb(fD$'Vk@
-1(Ei"FeJe$N9$cX@"3eL!US89*H,AYq,4FCU+Baiq++DcmQ8J!XY8#`IbNY3"Mr(
-qT+jV,4ZBrErM"RJL'1$*"`[%cE8XAV2B+#p99KL3!0b'@d!j2%fUV6!m1#K[r8e
-%U[eiX2PXfZ,r0X3!S"VUZLC92'X'@f#Hfh`A+b8jJ2*3Bq0UeiF&iQ-8j0Abp0@
-Gh'#2`(Kl0BZ[8,dMLZaRHS#0fAQiQDHl!NhMTj1k(B2r`C@4i6USiV'q!a#U#YG
-P$aiClH*L4*l+,M6cBC!!i--H)a%V)b+U*cF2hmXGRB[C16[(-m'+Xc!KCVXb*Jc
-)9aeLak!N$a!(UL,#Q-A(NlU`HJp0A'a$D'Z8'IQ61TNXJ38DRYNf96p3-4l'$+D
-N+5+'Bif%$(B$D*!!0F0($bVP%V+$S`eH%1GGcJIZGJR,*LjLN!!%1D&,F*q%QCN
-3-i&2@D#D3KR41ihF%5U5k*%!k)kY'S#-rFFTDkTFHKe%,MiJLJ3q4G%,,bB@e)c
-V!X035Rq[1!X[II%T[&c&*AJp@(`1489@X99fLP*)ZePHF,T(8H#"Le4qJCL13kH
-#AA9+FB!UI10FXI8PZ%89Rf-e[,2"D(VKibBlAp(5GpGbL$cCpJ!$0KS&JX@GMRP
-3SGC@$-"N8j,0[pUBd$#8FMXQId+a-##6!BH2dR81&TI`85m9L+R&Ti)0I"`I05B
-@B#R3q(#IQ#SCL'$XPVLNq(&jLr*9E-5-8k29cB,'d(qcf'kYlCL2P@em&pYp#1j
-VVcU"Gc"hBN)KD'9JB%S-pcDG3pZ'8iCr+8ppb$NdN5k#`&Yd5Cr[lHI#p#(E3G@
-6$m)!+bfZ'VCGe@4a9D[&95AR%1`+fEU@kmT$fSC4KX89`jCA()f)Di@2M[Q"CQl
-Hm*J1&8D8l2iLcZiVQc"CE-*+$RL,"R-Y$2%YN9d3+"296`MAiBU)!Ia8idGk')+
-r-0$V'P!aA)N"5MF048#*#fPj1L0Sr-c%crX2Xj%h%ldqaUY"6!@l+@%[e1RH')K
-P!KL08)I9&PpRG4KABNZl3e*Y+M([6Yp,jMHbh5Se6$d2G9TYm3&@TehUhZ)Gb)Z
-%f0MF&Yp,VMF'D'!Y@,%3c0l)I!N[*!-%0B$K0r*"*S"K#3H!Z&PpL%'5!cp%[f)
-@0`$)286bLr6`G8`RpF8MpX*f8Abmd"rXB*@K%(Sm6*p%)$b+[IJ3ZYd`DVlp,Yf
-VZBZ-l14NPP',M&CNe%4%MiM"Kr-q(a@EkC92T,f6Ji5-TRi`im9S5N&'HV"6Me-
-``L#a8B$+$`NB$a0kf-6!SrkYq0`cK03)5C!!J%82EF+V1`YA0"XCkF+!4IF*"83
-(1BYK(dDfTG8jZ&0dFekB46JBV$X$`,)2lV&9U5kch#l8dK$T#,LHBp9PaA1-mR'
-!ScXb%6%lf9kF34SRpY[c'r#6$hDM!3kHceiTV"bU$2(V+fPJ-Ni(ff`61`kj#VZ
-cm,2C9GPGMCpl,9P[!5MKrm*'e'ZqcLqi%SIH6S(&Cbm8rXS50RXV'd1TmdJG(h4
-bpAH!arXlMm(SPIKCDI8f21kRZ@kF2pK3#c)3[NK(cXPESBM(80Mp$Y5CC*E9Xrc
-3rGh[C1l*h%0rqN$1,Q(5$TIf`e$8VRQ8!69qQ)[(-C83Zc`3D!fLQPY!V`%,&Bp
-ff'Z%Z0p%CUShc-e-ChHQr[BQ-[[S4aEjReiM"kFFIa@cq%`RCC&r#!6jaVXpkX[
-[`Q!k(Xm08c!`IU%@`AQBcFr-B`HURj8@*ZA,'d0e(Q@B!VTi"bjH@iQVHNBr2#C
-2jZ%,Na'P!fq`FKdkM+*$$ffdYK)!i8PqQ)Y,5DCMh!(#AC&ckpKb@ApYpfBd6e-
-bhCr3TK1dk8jXqTLbk3lDG!HaN!"`L6[HXffl3lR@GP-ZNr+@%F2h@!`2GXJra@M
-ihNQ$[jLJG1%lV[,JPHZ)T2)@MR"'Q6*")QfM6"D29YkZa`4`[`c!23I!+i%bEKJ
-JIJU#'9LDKX*RMIL"@F4R-r&6!S-kbmCB!)&lfCqAmd36f)f"FB#ISGF-C'1!@l`
-[9Q1TJ$Ebi`6e%p3lCpd+8[cT!*A2ld#aEbJf@4J*+f8$$mj(c`1"R4mQeb)94e@
-N$%Aj@'*Q0-$96L3!H)-)K)Kq9XV9c"2lS&!S8pK3-DRfM9`8jkA9afX,hmM9P8e
-d55)(G4K5$PLKi&d2P3%BF,pE(04ajPj-Rq6FP-19IF'i+(h`'KX&iJ0Za@RBdJR
-$PV)4KZ8l4TfXX#42C`CBBKp(q5(`,l!C(("c,dbU)C)5Id5cY2r"+A!SFd6h`T`
-J'fB['ak#!CVe-%N,TXR[@!'UJbD,JF01@AJ%`Zr%)-jK)dpIcmjj(Sq*i)S)EN-
-@Z#JB&Pp*JkQP`Up!*+`F!M$Jd84TCiQaD5HR+cY2deC@mL19('jA959K&2Ae!NS
-F[UE4l1,AME@5@#m6)hDjLIimKH@ER@3&XcVf)ED%am'@Z9Q@Eq31cb-`Y`,-6mE
-mNXHB*1*im[HQK'Z@X(q2(r89KPR1'[c"'p)MI5)"0""5K[$r%5mB4YV)*&Kq!!a
-Hqd3#N!$c'KadlKNJjdb2l+aViCcT4h@2+0a4NYd2A1RVhXP1Q0hES!TbG0r&b!6
-Ahci'SM+Sh$-p+ph#JB$%#QI`94kH"@(cRNr`Cf#FX(c%'KX"TZ0YcX+6,R!aCH+
-(ejJbKX['kS3$TMlajhJJ)bdpbCY2`+#X*'SHimHFKBQ"ZPfj%"5JPSpK3f%8MV8
-3H&L*U-f+5`Q%`lr$aDf*KfJKKXL3!)diE2jGjBj3$dehGdLEaJA6#,(cQrU%l$K
-"(EN5[,!M!h`Uk!")DqA((GS%kE,EB4PYr*pc'@dS)V8@4YUQGaA1HPCKb#59S-q
-QQrL26E"c)"jE$C2NT8a@ed)jb&@F[f@%@mGjADQaa!PZrD[GJ)DJR1c[%aS%efX
-b`#dll`Bi01ETeU1jR%&dE&#Ba`#QcQ$0bUR[&$fid-BB9e"(iBHF9D@!V9pl`+B
-J1339@c-(bkqqeYmM,J+&0-X6+XirZ"",'X[++%)!a*UlmepL30Z#$hhh#K6U'`q
-LH'&fXc-*AccY*3K+,jlBj#'$L8PbS4XIrXrUDM,BaApbaRMbbF'fX5k0aa*8&51
-M-&P*ACJ&kZGT-6)kT+YL%*pS-06CbA3YPJcb3cApcZbTK8(e0q9!J-5ELjqLi$L
-!B4UL8cNjMH@Ni*fV')qm-IL[8*8Bl5L4HV5k,E&6pUS[(Zc,d'f)$C!!DpmS6Am
-68lp(8b2bJM,%(p$`#M8i)!cm!HE&V`9$-"AQ0qS61"k2)#S5I-%fq9"-(qAT8-r
-PDFDA$Ni-N!$XAXb%#aEmiZG`4hK%-pj45q4S5@5!4&CESjiD9CQJPN'Yb30RjL6
-F%2RaM@&E"blqZ)[J,NEPXBX+XI,*&$NEF+6+1JKLSfc)$K%09p*""%Ti9L#N59f
-b%q)@I,a2D,U0rY3GHHPkQ*9c3p)2kZTAqZP22XP(%UEBp#bZmGN`CrfhX(XBrDN
-X#MM%HVNj0Rcp%Plr'H4U39[Ck*,m4jPSaKZX0%f5VlCd(3-%1iM+3-8",KJD[$$
-'$cD!)@dZQ#"FcQCQmmb(H1KI92rU-rjXFY$LNe4"BjIYq"JPbq+Qm9VmNj[L$QS
-DN!#*X23F(AP8RXL%B'5*C(6)c&RAMcAM2rL0R%JbQCC'U)YG*Yl5&[kN`q[iBE"
-!"[Q-)Y1bT)jh[`rh(EjbR#CFN!!(+0XZGbhE)9qKE)1mqE*mMBI98*Cr5SR6'*4
-Xq"G+-N,L6pr3f*bNCE1r6E*4V'ECqIPTXmB@")0LJRN`UZBB(A!UHC6r0qe@dAA
-,(iBD2$,K%D)c,eJmD*-HB!!`M6-#J"VhBk1,R9[PLRGeRS'mc!jN)([VHf(f!+B
-cCbCNShp!PHbJh"EX(HK!bD*pX+J[Rak#d)Y(A%eJUj1MF(+#!I"HYm,&,Dc95ki
--cQ$+4JV&Qf0c#@ca"mJ`#adUXm9XDSR*2"L8rc`A2$4kXDk8rc`BrZ0Ji,kh1"r
-'VH%J@SE(0m2809GdI#Dpq+(%#@c`2!&$+4P6LR,L$"E$DADFd4F!i`I&0IKX9$j
-AdDH%aa%AL$BT%fKHiLCAJ"YL)9I'JTlUd+L(#99mKBH2c5!MJSUBX(360T*0lY9
-I$(!5hi5,CFKi(LVH69bG#B!%BiG,0c(c5Ef#T'hM6fl1c[Q[I$JIJT9*"RUh)AK
-[a3r-Uk9YiJIPik18Jcb8GTYQRQIJFB(44jp1*)Sr&N0)*K&VBaG)F[CDe[h2$VM
-l`I&'",BTdeB319B%G8h-j[J@)cFH2"MLiPFQ&8r!cr019!QRKHIGaTpD"8bi*A(
-dBSM1GV&VjR2mm)$35Ilc@b)HHXJ$2j!!+Lj1XKh6MDKF2b%)S$LJLP%&iRd3f*(
-94dU8Pl-'qYQTI#BPf4!TBcK"m+MNj3[iMqHC@+L3!0&8IrIrJ%"`(GPN+-cjeH3
-BI)kb%6ph6Kc-4%DD2SA&2`!!-BP"4%05!`"B)Jp9$@C'%4!KiqjKrffrPUVdjZq
-k[VQHj['jVUYkUVCk3I0%GP)h"Zc+!VeZ*V1cb*r(e[+3!)lVQlQ&%-)9lHHA(A$
-+M)K1McJA$K0VN[%mkf3HYa"Hcm*kK("k!b1%j9Q(dB#"*YdNlh`c(Z[[hprrph8
-G),ql*1mP,cm!&AGH*2-J-L)5)I%!%5)'AhPG*Q-ar-LqCJ'NQ"c!*L')CV-(JC2
--S[20R!1c&,&8JZr0qr1q#52iqmk#M2G`pECDKMbLd51Y3amCHVZK48lF$KFUBV(
-IrB)9$i+jGMADr*`4l'rh@haI,j*'%1&V@$'3!$VG3"D&JAKK))8c#+3,I1N**R'
-qR0U+J,#d[d@@iSMNQ$KF4Yka2ZGiShr!2`#`r@&r($qAeDh0F5L,bQK3@RaM-0(
-+iVm'I"EQ!l&N"+cJFTK`k@35*Qc#G2I$E""9ifAHl#RqDeZ%Lf9SP9)$-MJpFG4
-(,I%a,MkL'[&(2c,M3"SY[YDM,QA4,b@h!L#Z%jG$)#S[5Y8d3Vr[c#R(PeXFh5Q
-'2B1c&p9G9m3$fZml-mS$RIS$fR6*8CIT%CIaF6+LbT-UD*qdb*i0(EjQGF,3E#f
-b'F&d-d$N%%((G3LakR`CBrj4Qm0[*)ZeU58Cp6rXD9CVUILMYU@lYJ%jEKQh`A#
-VM&"r&`##-#p$%1HMj5%5b%2'aX&Z,k$'M)!D@DbS3(m(PYUc23a'$(r+"[qKa90
-L"&8#+92@`D@PLaQ&*2"5K(&fK("@jrR#mUhGNd&1A5$mrLahGlrP#DHa(%U`eCP
-AHiaN@cY!iqA+)aH94k*B'YKlIc6Bhf@%("E!ZZGZKp5GMhkNDJAYqIZ65@@"Ab`
-iZmY)#PLI$,5'$C6$b%*1DM"$ZkfpXGehK8d@#85Y+,,VLqj)JfA"Cq5NfAD#LLN
-Rl@dR#[RK(!F6fFLNa$59Q#E&G(+j#d$#C!#AjV$$bU$*'!cfcqq6UVYPj#X)%Ph
--b2#+dp1Ke1PBc*FdU,!",Cj!+UX($1R$aXEGV*TU[$PThAQLX14G[Y0L,"'`a[#
-@YY-#k+6ZSVbX!9+bmX8rDe&65br&k[aCP`6jk9l@[9$VeTUk@9K)h@MH1)SSE)K
-ZjX8Q8XjV-J`$#MLkHD'CP5J(a36hXrM53F25SiX,ZFVd!K-&a"[%e%V6ZQf`IPD
-*Na&-cF4d3N`RT9jBkej8#UXUKf,k,+Y2*X0G*(Mab-1+i+@m6SANB`(jl+1Kh9r
--aU(ZjI!m&m2V&R8E95,U8dG$[-%XNKld`+IL!EIjqc9)K*!!`,E0meDDcQfhB01
-Y,&iBAVH4cjNH,eq'J2'EFcNC&U$JP#CPf`RHQ(rH*`Vc)G@Ib8R$Nc45E4dXEM8
-Ni%)Zq%PF[!q9j1+H00'P@A@'HBT8%J6h$!`(B"+JPFd(8%&[QSP@!CBmZY$[FT8
-b+2+p*a)&A[8R+QCdKXSVA-a+SI+(-9'S(VdU&a19GSmZ[p%#SmIPTUkj!P)E,!4
-[B#U#BYLN#,N5e@r&%DKq)DpLF5(r5kZq2+hLP0EibNkPkS[T%,@H''#Bja9@&#J
-+L*+KjpS-EAIQ6TqINkC3[6[R!Z-Il@kRi)HCSAXC*"b8`+I+@%)+512ZiZr`D(i
-NfX3"@2Lk9f2QbENd&pm@j1,bRr2B,dAHHpL6Z46&6m@P)(jFkV@V+*KR0Nk'5+e
-!A,'[BG2fM&4lMhe9I9TjYI,B9j8VP&I'XDqqkPCHK@KVMcVZT$TiLlj`!`+TIj%
-aVk%09F1N["J+Xh0K#i2)jQ6TZ+faBlUdS1fqEd`"k,*Yl5cFbldEUaTl0eETld,
-eEk8TQ`mJ0*Mb+r1,%1(`4KBZ+h-#M(-%(Jq`@[@-U%9A@@MDC)$)%SXcKDVHj@d
-AT2VD`9k[Hd9jR6rBkkpZ8PjlMhN0#(EcJ[)b41c'SmaBT&IH&)Nq4m&9'*9Q9iZ
-dcc`,!U)F6N)SCh)jb)j`NSi)R`'f!da-%2U"M`pKNQ9@1@9EBT!!hK1@lG"UH)N
-*k,d4e&0iJqi5P-jb&9c'ZqJ!p`&6S@-B8hhMNq&*1mMeZl,e9-2A(aFE5$K,V!$
-K0'(5GQ&k@+`94G'GFc$CCFBmZY'+l,Z5`hmE+K(QbL#%"R`PV3SK-625h`&J--S
-GbV#S5+M3Y"drjUr[389SEb%p2r@hBDX5r0NTF9h$56ERf8(#Zl3jZTi$qkA0N3m
-aUIV$!55eB!k4-hmii,26X9BkYY9SGdZmm+'6e3"3V6A1piiM`,B[b%K@U$L4CK+
-Gc'U1GiJ8"5H!(11r2A"EQ0Tra5&HmDSi!(-U,GE)`0Ld9T+CMC2*hBAaqG5cJKN
-kSU3HAQE'Z[,rhNHaXD,Sl[8L"$(-(q0cUN9bVV*b)66h8UaD(FF(NcrF$Xe9aYD
-TLhT4c"Dd&MBBFAKaFQpp+,pGcYR!S&C(mm&B+&q1@e8RZQ"PQKKHjb+f'-ZE10c
-JJVB3X59@+G)UraIr,r)rq#pkc(p"j6m0r`A`Rhj3eS)8NL@icl"XK[29`rK$d%+
-0`SSN@&!BY-D'r!q(&%1ZqBG$"cAN(CcDC82q,b`k'ENah+SNkHT51(blR+lJb3p
-M#p[qi4!HZ$L-BqBLUABTbq@d`C1rM5eB3jCB,#1,NmrAYl@(X-$*AD'ZGiU04PS
-!F@NA)kU,Em15EU2U6%UB#Gm'`Ci!0&GZ0E@3!'V4T()E8+fTPVq'TFAU&V5,)69
-j-FTTJYLk@&e&!#a-L!,DqmD!k)Cb1j[G)cCf([%iUA1YT-lPSXlPSmjeQ6UAP"G
-!lKV"f2mEEa1klIreRcI18rKG9d1TdIrI,j9d-bZ2['PDm+Ki*0&G[1+44cMerX,
-GKYJPP,@dlDQYUL4AN!$*j6#-C230p&K1V)DjXa0Kif+CS!)aUA$LDV0m!r'B9#G
-i%Q(&MdP8&Mk6&["`%YDdYmL2fB%MHLmN'B+`JQa`JT*[K[R&8N6L@$im5BG(eDJ
-M,Pl4NNMaah[Aqj*f!QELH1dP"@kH3rV81TMb*6)44M#AZT6kfF0PIrQp*8lU8J@
-1fISA,XGL-USLmIL&2#BKGi3RFqr+k#)+F-1!akZNi`%qI"GK,C,jH-P-cTCcR+,
-qEPk'`1kC2Jll+SpJbVH#J0"fhQFfiia%3"Q-[FpN,m[TS$qmaD$a#K5+hBJ6l,%
--,T`J2M&Ei5Dl8RK5R*4MYdjm2)$$rq#6d@SiX2`"j-aJmJD5CJH"5[*aUScZ"DR
-E-4PmrMk!'CYalaQ&4IJR*Z)6Ba+ZR4X"rMmFaa&F&)!mpf`M*RFU%TEfXGJMA+"
-YjiSLT-6,1-$#NAr!RrHcpP3Hi48cY15d`Xi`fi)rQf'"1#aAj6-K*E41$BHL5iY
-#8-[hVLH(`I98i+08i0I)H1$S4ae-bVh8h@5NP6SI!!J!$HkX[IL2'TG!(ReCHfq
-qZ0Uf"),H0S1$'3+m'(heFm5JhMIZI4IKq,#G`6N!H@&M"Kqd43BbFMKNJJlaCZf
-1I((%FV"$USBF8MAd%&QLEd5qQ,k4iXL3!%2UKKa5Gm`KDr50b"[T'bQ1$MQNGXJ
-KY8-18BIYJk39,r*`[G,i%"D*CfE4`XRQh@Yhh!H-Q5($K0[,H`K&h&(m4&8$KUI
-"3+a$6DIb1Ged@'3f)E+*[HXpeTQPJYc5[[@qmpl65l(UB6Yq+[[cLjE8'"X`3ZV
-hB$SPF#+p#G-SChG2r0Q(2kX"#qlMp"FcNE&pB0m1FCJ%X'81kQSIM'Sl6(NIEVE
-rQ*0NF+p%Z&X2pQ%C`ZE9"VTVE-AZ0h[206%FD&16U9ZX`(cj-a*`h`Sea`UNPd1
-92FbXpBf$A*8a#HZGiXlHGakIlHi8ZB1@B$-V0Z$SD9QjApRk034r4R(HGXlh'Lk
-qST&IpqVGJ3q(+ep8la$8$F#!V84akpe!J4ZLU3'P-b5(JrZ@8(3DG3)%eepYjNk
-!)Qkp5JR6c3dM$`Bl(,Uq*4d'%UPiVJ)!Vj1AC@'UllacbZ9AHh'jebG$KG$cpmR
-8V`pfjiN*lXiC#G$J*T6#IbFi$Kd!4IMCli+d!VDeim9*Aj)!V*0[R8DDpM354&h
-'I'2A`MIi*6VD'"DG3"%diFD,`MVKD-mJ13`JE"[IASbmqU8l1$)lR*@[EKSHcX[
-'*@3N#(Thq9I''HChRFr1El2-GF2-p`"X1&'BFTh(cB(&#KNE"@bL0KF#cprRMFe
-PXh,$`+bf'"`$40+!bbj-k#rplUcdE69#+2"kF8R3e`&fEmTXh,d*K,U%#68"q18
--'[-$Z(PaG+0D83KFL4cqNNK))%N(pm4#J$l8m3FSjM#$(lM-$Ha!FS+"LXPLb[l
-ZKUi&Qe,!0Gcpi"$&&kLK4eTL,dVTk&U'V8l,@(C3C0AEG6L@PIAhmY9P4I+YHp8
-PSm'ai'8j-eCG4H69,!lDB-69YIK6``'@FIk4%XN+IF!lIZ5`0''L,K)3a!f$,QF
-bd+HEYQl%CAcMBM-[JASIJ1LQ2,-J,SB("KmVAhUTZY*Y'Mrmihe`9iE*FC!!Jr!
-[LFlR%N&FV"bJ!-1UV6RT+I!#GN9hrDREp'lRC8B)")%A@i@EC&9Uj!&-FBU&`q4
-KDj0)ID,DCk[h6!DHNC-%SLkrcNB)V'5XHLqE0UTC,N**``A!`'SIUbjMBM)9b@X
-!K,3YRHMm!iScfrMhcXE1ar*JlFIK3JQMpYJ*CSVi1#4-ZH2'Fl`j*!6(P8"DK$8
-1)L!M4$Km4%EF4$`Z%ZQi8Vb4#-S0K*rR2-A&(q1RU$K*(lZ+Pr0(eFe&APd&9[#
-R8PEAUBmR2N6T`dMLJdBITK)I`[5K)[%K3KpbB`%e!j0ZU5j4ME'!1mSL9jXaMG!
-dP@-'l(GL'DVYVbjcG*X`%Pm48VaP"3H)r10'B%XRM-lekrY5+XTd"aGq`A6RbC3
-Y&1l1IpJa'@5QVkeM8U*T!94`fdQ!T2&6$8r0XTV059qc%HIdYT1C`adrCPHDl8I
-HJ"VY)MADI&RUc!EFDm+m%BpFYiNf*'8Y40(+bY'6T'hr$ETbZ3M4K9!Kl$)@pT6
--DflV#iNe6@`$*,Ca%YY8'M[G5f,V)l(G*E%9Np!F*,5l*$5940DV1K,#1T83dd"
-#3#X6SXNQK&+!8,b+8(S53M%63JN*S6LTQceUJ`0lTK$SEpp`#ijphCj@JiV)Zh(
-,Aajr+GClr*ZQE(VM5$f+BGjTmAIj*P+hf"Pf@Kcc0rJNj9TMSm2#h4i0G,3V8R4
-PYC5KFe,H&lJ6#3J0US(CaE#MBm@Yfbp5S"1T,VNpS8!ZJ#Lq8Z0kJ#1X!2dd*R,
-#T4X11A"EBjAcI#F$d0ML@(A0kA1fFjD@kPUR*@U*eFCLZ+Pc@N"ZmMUji5fT9P)
-CmB0erk(!0,N3Nd-B+c8+$Za`JUpM*hM[GQDA&-8A4RGMiBk4F--NeKRe-KcPN9S
-JKh9b@Z!+[A3UFe@"i%D-m`cZ*"j)#8C%GLU3!&h&83m!`T)ha@[P%1[",[,bI[d
-LR[Khm*Q+c[lVXl%U9"r%%+!U&l'G!DfA,Di("!!*J2#h"!HQT9C-)XIFjIa)5AL
-'[mhL5,Pdq"A-!!N,%02N[0J`B#[qD$9k6c89VUV4SSF)CKX%c$L)3P-M0$%T*HM
--Y$%mpLA*F@dT"4dAkA@4(Lc&4K6BeS!b9Y2K+Ib-b8ba"5a-d565`a[AiY,E6M9
-mIX6e!!T!DVZJ8Zjb9kBIUmFe&P6R#KZhh0FCjS+*p'0f&JNN6ZJ#$"j`YPq-I0,
-0,LKbQq(bCb*VI0(q#ijED*!!j&c92[dc%IJM`BB2D1lc%-#a46KA26ccYVMiBhd
-`69l-DQ!%651Zb99'dM1""b$!aeDkf%9rBHCYU,`4Q(8a2KESifdm-KTT`BGQqM#
-,iKRPK*U2652$bkYYh"eL)hIfbiHS3Fp$I3riTF'(C@6TUBCAcr,PBb0XkVajcaL
-1cFLH8`f,0[(+Hdhf'2q%"j!!DX*2mYGRC8ifibFV%Icam6rJQq32q!8H3JI62pZ
-P$cpKHGB2SrG0*$DBF2'2IH[1rXJDN!"YG[3EF5H*E+qQQ`QkfCIKQqE[L`ILp2&
-!J@p+(k'25b9b&6kfd32&p!#Vra%LqpYj5QaZ16hJS`IfL)@4&X%Li)9AX,ad8k#
-E'Z@K$a9RSa(h6G&)LQl1dJhJrQLBa&SUQ*E'pJ8l'CXT)))q'!K5bNiXX[P0c`!
-BLYA-"U0ipKRaiRcE15C!"S$cf)'f#lLaRfVB[edK4M+bcl!c('[B35EHcc"4H[r
-(&m!@Ii[%Zjb2`jmf((Q0(3d4,Uc&iKjDl)ET,m1&Yq2#cX*mY*h""3D1!!lBH4+
-9RT3!*J63J)I,+4QdKiiZ1p9`Z*6"A[6L,P)Ga9ae0*l`XY+k2F[`,iU-(CIf'Di
-X1`I9C#dJa0IJJ,6$(9G8T+Kk+cHU-ZcS0#[J"2&q8mH4*JiJP)SGGHQ508-Z28#
-'Jc5pCq@9b&@0&aLQY)"b544DBU&`JGjFK-A01IQpJGJb1Z#h2Jdh+P)1!"PLbcb
-pbUBQ5#(B!H+X10,%5FMBDLGA+IlM*UT8r%UNT2j`2EE+$mCj%YZ$4qU84kV%4iK
-E6%a&0CLiP&bhAe`F8eidiKp&edSK16$+AH[TY528YC5ZRS*3&lKl2Repj!&ZEJp
-fpDH[d+GCdG'I[JRfmPQK0TjqEH3"%e485[@%LCcq9Qe@@"@UR,r**mMX6P*S59*
-%-&GX2m4++-dj+bZDeic[ELBhIb5k*SU-CHfc`d`b'lYmSk2ajlSDfUHM0pS,J5h
-h1Cb#!SL$Q!@Hlq3JllXS#0RTq%##('MAdKScQ)UEp!3h@10N!eLR#VI4B*QGbma
-[lbib9Z$BepZCf&-3NC'Gl,6ZXiTQCm3NXFX+8Y6Nk'%4$G(#D3f16+1)NVr1pKr
-FS`f%del5"U#+8hrr*DNpmSBaAf3diT*rr`B1#3qQ0kh@c+#$5*`53"22D%KF+Ha
-$E*JCGM5XBp8ekcrT'dDhUk+%bq-JAbBl-[hd$$p8N!#q`XcmMp!B38E`!f!-2qY
-N819dSmCGA(+U-eQ3!2jfRh9brYK,9A0LG)**S09kM)0!Z'+-NrbFCRAf)Z&N,rM
-GVBrBcL!je'rK"2eSF1pI8F%pKH+Z"32D@3MX[Xp!4$EHH(V"cNR,aY26+AUS&Jm
-pTFiL"!`HrK)9[YPiqRDTXI&`24FjhbkB4N!j@MjhDqpIJ4312TlK`fEC$DP'@8+
-ITLI!20j#8iFD@U,aC5#dTh`bGJQ6@XqX%GLY#jA"ZVUSK9YrHC*4"A"@lfC$R#6
-h"RDR0@"jhH,XK8YR(CN%6+jJ-NQ1YY0LN`2iU)82S+BepVF!5IkZ2&C&a9@(#UG
-LAcHi)BK)jeHP-@i%iqIBN4pX(X6[4&&RLJ$RC'"X-SZ1-bCcP%k[B4FICJYC@#!
-!PA!iDhC($ZA[rQ3J-0iprK-81C0ldi%NMA$G)RHb5VeC%%'!V@#6*rlM-U$dfS,
-SYXQ#RJ3q3CIm'KXAXfLLBBI-kHcDUBEGebPY,RdU-lPJ[RZ-HHlBAV2a(*b&Q2b
-dJZ`!NZkr`"8pFT+f$fJEA6kR'SDpep,BXF!%+YIE)R-)fQYl6kUk-eA5m3D$(!M
-C9r*@I!A96"aT2Yr*abSA6JeHH,DF'$EG@@!2QqXB#K-&QEZ-JX5$'8-8*UIQEk%
-Spp"RTm%165K1DR$-l(*iU85c-jQ&bQpQPCrZ'J43dUXA,c8(+,0+"Vkh+-Pf00k
-ja`iJ0bj3)bf#qQ"Nf$JRe!Vjl,b!B1(X&',&0BS'm6iR16(C55#l%,,XZKK9P'N
-KTiZP)8l03%afRc[U@&3K8iK6pECa-f'P%F8H0#GPjALIhA"10@cCUC!!pFHj`ab
-jJ)*!)L'69je82'CEGq1Yfd+0rd)GjimrE&+ea4rqTKZEV&)+[C8+c8`)2*836M[
-%MCH1*[&)BiY-6F[U(8-#P$T&M44QlLdb-cbDECm*BM*QYRm2B6*3aV#H4Q!(,Sm
-$P@hQK!J$C-2#F6E5eXj"Uq`Tj%f'm+0`I"1TeGmKL9rPadH2q2!S2T6JS5!%9CH
-GT`YDp"3)1C@@NXS`f9R,hdi0e1&NaZj9&CrkQKI4c&jkMI[qAXmP4A#2U`jf"MZ
-(VSVL6Tf4T9*e1FrhRPrjU4R(CIjGQ!-E`bHhf!3f@(b&a@lPS$ZHR$M)Nc*(CB3
-UEP'Y-i"PeEL5!,S2)d%$EVJIe[YlI38BS8PXKpdGAE633G5!6(4Da8dP1X3jU9i
-aIQl)Q)%bb9k@C&SVb1"c"UN2N!$p9T!!r9D$Qjr"PElB22)A-2Tk)`q'Ni'Y6@U
-5!XKkr0QNZ!eCS8!DXI8H928pE+f((!JdGaCE82(a(e%Sfe$il+VQa-([X`+MlU8
-djbI&e5-8&aKA(mM2M'k`bX!$jH5d-"EEK$reHY)Il-FrSJP,)iH%k(VfUkEL#$Z
-DJmX%3)ZDf(X!,lI$4A92V"`1ZVYLCHbQ'b["bjGM0@#(NJSM*L09KYeKDE`e1i$
-MAmDIrILcLiFmq#@A,KPbk8@q0#UiR8M,bmhS6YDaf(XE00q%2`Jc1V!"Rc&C2A2
-(VhQX'c52I6MJZ#1D,S!pAIEGCA"@NM#P'Xm`rc4LZ5F$J$X5Uf%h+U!6Ed&"m'4
-X'jB+*eTD#YJ6S&[ChR&ZE+Xb8e[H#p!cDalm3EL)Pm'BYY2&[-V&A[CB$lDK'3'
-F,Z03KCZ1mL8J[P`KVMG"Ll1!&`F$ppMlNmY*#C86%`bJm[GRpG""-RYG"c@cA#J
-TGB$-cd6$KM,4)"-U`TP31#UreLm%CYJFV0UFl6HLL9qCEcmfe!SeC#8bBb48N!!
-"&@3)&45V!N(K-+S5cAYU(#F,pJfhTZ@k$iFSS[@k5jAaK'c0X2-+KcRVL95[SHk
-bU8KdPhC5MZh$l`UR3Ma3,aJP&02laT65A9BFT$XXSqiJJpq!8XNUAD*4PF%2UG&
-0bf9*,0"U"YlC[%ccLV4+a@8%3BQZpP#-p8,Pa9B8mR'S0b8"fL-DXK*m8b"SET4
-!Z9I82MVk%`KdYATh*JM9qJRqV&EpZTS-RP*8IKHk!NMCG+RZQK,FGX`V0[(9iN!
-eS9D$c2*riU%ZiHL#D&Tqc`ECmTGRBbh#lC!!#dT4[6r"`k["HVA1(!F4Dp'*'%*
-J-&")A&`hi-!1TMH2elp3QJ2XJq1FqBJ0k9X0$4EfE4KBD)9$8+KaB0Sq#YJ'M34
-U$lA%eR0LS-%bf&JrGXJ[ICUrhrFcX-P`beR*a49Tb(Y#lQK$h[FD*hPJI%&+64f
-JMf#YBJHHjm6Y!CK"LVI#D5[aq8J,J3+fV%PU'bR%-p'X)$T,-2%frc83'bRhRG'
-BlH*Nmj8J8XeKE[c168he)jd-UHiM"dY85EKBEV%mDQ1S&daI(SY#rc%5Dr1&AfQ
-&@iC0C6Ce'C`!IS*+lH3'Kh$A+eHh1DGkTeDf%URjH4UT%8N2*MEK9`*d`$D&R*c
-)-%6I"MA3"RIp8R89E6q!lFGjFfJqe()QLNl2-)60IpaAi+B#(MXqEH*2Ck,%a2i
-fYNC0dI3K6'8NTDL&M3QP-+1$hP!$M9#F@9),0P),YP-0[qY6h&RA`,%G#T*!l3Z
-LBh!k8@E9diTkf*LQ(-4&Im%APDq6JYJSe!-,"FV"aL'rc)+*c'BY[cQ1#Za5&)5
-KQh'rjB88KFcmMJmUJEVi3"fPT)ASeRZS-`pPr-S`,)G9"fMiD1SFXT*6SQZ'0Tf
-h@NPeQ+3k8JVBpeQ!I6i#qciR3ZHIZKR#"$PUi(5QCi$#i`'#qel*"&9R392J2Yk
-`$[Jj&DE5#[D[hG("i"j#ead("rFL2RD5,BVBfMhK*)(8dMi)c[&3-Eb4Mc%!%!0
-r5'ip!AECC3Kh4bZT&6r"qaG&FPpZBP9ep9hjUH+5Pe)!EcX65Jabi54)#+`q'm!
-NNTcIc$#Kc("6J*Brbm+k[,+`k%qqM"RFIp1`F!`,ArQc,Ia+VE*3F6FP'$S0`-J
-F(-$3")"KYDB$')$#P+CH02M)++Q60Lj##0[1$TVM,mP`E!m)`q@-R`I@Z#`jC-i
-%qc[8-35mafp2C!,p(D2DFef1EJ5[28L'hPF5Sp('il20ZB#MLer[r5[peE+1k8q
--`1&1GYI1cMFHAj!!`H[Fd4Z26mZJTF!+%iN!0*!!Q'#DKJcGCRG,J5kHJi-X
-94B@KBY3i+IYbGFcr")B4bl!DTN0VP50,P!2VP!2VF1!1p4!89MNU&GH2B[D),N+
-U-[Ukk,UkHrPZ#e6VGV#!&NUID&"pB"MQq+(J(XY+'Ef$0V["k!"DM`@8*N-i9!3
-pbND6rRk2M+lP$@*,e+"-f9)9YV5Ah8FE"aDH`b3*XV(cQ)dT+MbU%&bSjI$3V89
-fdGD#Y$8E05B#!dc#U`4TX8'dCY[e3[kLc!Ah[M0%I+(qMTa@hZhSf[X1a"FkI$m
-"98"mR&,Reh[Id9me3(b&d"@0)3d#55$!b#'#55$!L+h2Em4[KX%qlm#fA)12-Lb
-Q9'Q(8Vaa8BQT#[)B6+%U[+L9UK+PUU`H@XJ9`HKT'I2ImE&K*p%(l1SB9hB1eGY
-`"aZC`8ELMAH`N88K#N%qaD!Q@'$ehf+h(eldk2qq+$2q[LR9QQD-TaI#C$LRCm1
-1EL2Hf,f`PhrJ'&$#30c0*+GI'#jA,r'(4)9#kHBbT%,#X6##kUa-E28i0pQPVD,
-)j$ZL1-4@pF@mBEGG321+5pfMkZ0`NQKc"cCB`#"S-"YZ`,XGkE8iTmV8#KiJ,"Y
-R-'l1JV!RqL-iP'%5a#5)53!6$C-`*J&-2[i4Zj!!S5%&*KXC+-43,H*5j80$0(*
-BYbSTUK5D#fKJDV5FI@aqf5h2"&3ch,#-94MkkCE2ZD+E2J(D-cEaB&#qH)%"2aJ
-XYTedacCB"SGZXUE"5@Jmd$$4`)#4NFqih1EhE9IJ'Q!bf&8&jV&Jj0GrKjPPT`X
-*DRqX8SFri&jh@53C#RjeN4e&j3k#)KQ!21hLBEeDPD3aZ3HrfXQ$E,Mh(,%CB6a
-FldipBJ0T![RDbSrFi`(k8Kd33@"k"4a"Qr@%BI9Q2XaRCa8)dd!)Ka3e!&B-Ge@
-HIMXp$M&8&4c(Aj8A`0LpiSl--9KIkad[5[hm)hF@!r)K(2'1pb%KbMG`&X4V)bK
-H'0dcHF1"C1d&ESL")Ep`f2T4)jA@Z++1#fZPD)JeF88D+5j3$2Ph"`eVeTjUq+0
-G$0l0"AKBU-2R8'8AX`Nl1`Y,B1q6[XHK*T1qVj(5V()q!B)2+0f)$eKqE(&B`+C
-9Q3cY-#K6q3bR'b(SbAN-3[HHF2r*"XCYKbfd94H(i'fGKIbcH&LQ%2lKZ29qKKN
-miZBl5(K11(""Jcp"S5&YS3e@463&B+I-*eCLif212!r"KH-GqY'm@Br@MarDYTf
-U-!(@*L9Jhq6Q[JGT64BVGHJDA6J1KSJCE(Bc3DS!JE"%K3!N9km53,+[K`NY[4U
-MbMEMj9VaNU'jF&T$b-&"VKK85MmH0pDEF93`!rH85LjZ`maBe*j*[QLVFM55aGA
-MbQ8[+TI9Ab+a8Ce6AVif5GY*[%4$K'T6H6Q$6J9"I+m[Fc8"G&CFFKHlZDYYC2F
-[%iqe8YSja!*#Gi&S-6KJRG4q`%RT-!'1#9G9N5"1VdbLL(ap$p)+TDr[35*&I0!
-LTS9FbE(%3Uk@NEMPLX4jqkdh#PH9E@-BYBf(A!m'#aTT+3D0`fJ5bJaK5QdQf-F
-eNhmk,kdc!(%if)8)2X2X5pm$[A'%Z@J)Nq2&JTNd`8cf`M`HChALCcA*5Qf9mQU
-PfrPhhX+iXGbAqXf$9eC%MEQViamKJFkT"5QI02U0CFcf)U%,9U[R58ScKihlQAj
-12I-J3Md[8Z+i8L6Tf4AQdc8Bd"%-U'm'J8LYm4crrf9f$IRdMj8K(cre'eFRT6i
-!j+GhqAEQE4a@*3Bpj)9[MD2DfNb1@%'`PCY,qM"%SC(d#D$j4EAA5!T9`afNUA2
-U-LIcT2%GGXh`HkIJBT'#'J%,KdpS8L-D%%fLFBZlP5HF,#2h5k4Ef+%"BVRHakN
-aVZKT*-E!H#14VaRRehqH4DG80iHd@j!!#dqi&aLIF6h3%er#')VNXrFL(q,2$EG
-m0KrjmjPh)fYrL@#h#F&5bVZ8a!Y("0`8dH"0p@$[r8K22m3GI-[G[JF(%AXCLje
-*%EClV1$hR'S)Aq*'h8F*rK0Uf2l*hhNcidEUB-+2G"Lp*2be*2)6*(!-`'PpL34
-H*EVJPeFS`TiecZY$0AUh'lhr")&(eT!!`&&XArjD3Z"mkp-&rZ8`#E`'S(Q01rp
-hAQr[jmIK+"!qHN0`%@Gcl*f"H`'!d&ii%I5`U+TfdZ#LCGcJ@M%-+3pa'1c-Se0
-Gd98qQUSN6)5A4lk"#X'XV!Bj+*4jHqmGMVa(*S0E%+m80T12V$*-RXK$F,@Q&"*
-prQ$Q@@F[Nefi4+bD6)*N9@*jbq6(iXCGr(-EEL#bc@fF5#j)Q"8ZpU0D0L[I+"*
-[0b-Yk&TJf0)$eIm$Tk4[2a$0#J&6lZJ64JL5CNb4%9B*%IbSrZ"'5!T*`',,2A&
-R2a%cKf&b-j!!MCrcD%82UGP6$D&C%0)8f!!(*mpHl64k"B(KKN3mq1IQ*f&drHX
-rciNUEJ62"UGIU#rY3X`!iD"iSCHGj&%GFD'eG+&A-*KX*AGAA!J9MA`$&h)FFb%
-E1R3r*E9$aNhCJk'%HrQbQ4Hi,)1TNJCT)AFi5P#!f$qN3Z8%QQ!!JPPEaFcDi!#
-MVBNKYTL"#Ud@3pRk3X3Dl4*$d[)2ZU!9)UdM4SVKacTh6MKaC2VGelj[8iF(3hS
-mF!mEk-B!!a63-j0QQ)F&+e@VX&,A%fa8c9!fkNT%6@&SiQk2b@bGSi--3@hXQ0f
-[6kIc2+JV-8e0B*VQ&+DTC*!!68*('l`T-33$eU%`5dd*CURfB-`5&dB4#N2,-'Z
-%EX$$h2B)*Bl2'jM&9$jVp(QG#-9MG9#4Q`"l`(c51Y[192HPXprk&`$dh8c+2'%
-eKHDA+IUC8%0&R2aU`6!%mUB9!M3"VJPia8*(2),A69P0BD1U"YNS02j-dU!+8m6
-XR#B@VISJ,&Uemcbl%)*4UrBd8i2&-0a[SCSL%d+jkk`BZTk6f#rH4T)C-,%4JiC
-D0R,#B3e$CVGlV+PfC)%I3NSij8RK11%L0qTkS"!#&)AG58i9+*aB&@kEZ8ZQ&68
-$5@$KSkYC$38AD$$ET+HBLK++IGfX+%L2bZ3kC9'+d+)8SCq+81-Lp!mm86'R+D`
-JP%YE8b(23I-ac+!e8@"T$+(Fc`aKkj!!)3Xi(1+ZM3&T6eCFa4EI36I&YT4!kh6
-EK8cH0BA"K&2XM1cqS`mF+kqkB`"DSC,Ir-ALeA%'[$ZI#EcjZ[l"0d*J&!qeB[*
-Jd38,GmD-%'mqmGJFP)TrF[l0#r`*3iP(hicKd`m+8UKkHLL1*JX3h8qV'&b$fQ-
-e&&Z@pfM2K0jm[H%d*S%hEk3GS!fQM(8A2rmE''3hM+@Mq21R#9E0j)%Hq)&[BcM
-Af$TFj-A#94!jGZGC"dDRqMFBTYBL*bZQVe`k1r-X(VU)2jIGX[lc'0b@h%JSZA!
-#DDQ,X3m"ZYbBi3%E2`YRqC93'4H3!,UkM!6AFXqFG4i$YTchqJ'&Sd(#qM&q$!b
-0C@d+L4`dL2[9YFFABZ[Ka0SbIICf8@b0Mb&k'KVCJkl1JeQTcX4MCZ+a%$m'T`5
-k%)BB5KcUf8Q,3@$-#qj("90"fpa'$mqabffX&Bp[JcSc8#d3P`K-Bdk1Iq3"Zfb
-1k1T@$*1VUeZmQK&$#@2"#9,Q)5BRV'!63`Ac5hIL*4,EcXmN&[A4Ll!J0%FY@kQ
-rrM8lpfPT#ifdKH'M&ND(,%blS#a*@jJkGU%m0'4KbTPS%NH[0`ejEDBGHb(Y@2Y
-4aeiDXY!qH#`2hEjm[I%CIK'P,UKr-M,iN!!BI)6*@3%TD2KmcKGK80aX2*@2`-R
-"jAHdEqLBVYh3-DXCbI6"4hKJD,#'la%cc1""-l'+M3K-mX3#[LZ+QiD#9Z#%m1+
-9Q$*XX4JqPD$jf'-mJ'aNkfm%d`%@ae3krH,9Cc64aAP!F5B8!"e#9f*i["jNS)5
-'$m&3m-2,)PP",#Df#a*#!r(HP1B)'Mq#'DVbrR(IR`Sh&Zi-LJ+&bT`SJmU%dJP
-HHhX)#mSAj1f,Lk+,,M,VY1iNA%iaLC36ZbGH0EZca!M1mN&*mff['-EYKBk5Z`6
-lZHj-Rm+)"Um0(LGAZ9e%@&eJpe,%("Y[$`Q-MMV`K"K!&1`5+ZcY4m"aHZdBKTA
-[4e01+#pfKZ@$0,'efKIFfT`)JpB4HdrJL-YVFHGT+aS#PHAN`S2U4fXiX)9SEXc
-Ne4`(*Xa%9ql5+b3[L'+5Vq'Sf!T@R(LBKbH'SM66JeCKGQi66@%Ub3@fXQ#U284
-8dJM)jJrk([5h%lPTpqe0$f,B#)R4l(GLN!"iU'Sr$`-[0[69%S)Kj#pjq21*Kjp
--IjJCP0*&FQR'j90G)YJXZ(MSprqFrYAX-aA5S[ac"!$""%PDHC9GTL*R"IY!JhK
-c+M8j+L"#r1-'&(C8RIVLNmYb9ih3fk@CF5%'AZV4"e`DSr!'KTNbK5(cJ9k6"pR
-!F"Y64LMGH&1CN3H&%dA1lhpNT1jDVP6D1M*jZ)jVlMiH9[ZZaGEKc'F!qlDGH$B
-[QLM4P2jT%*UD(*E5e%j!0%qYQ0TTfSUTPDB'TUddG@*Ud$5$UC1Q18`c0-eLQU2
-T0Nbc0&h%G"Y0+c"GT'NHd`UD$Q#DTqNiTJ-dRF*dR+BZ6+GSfSZTLkCpQ2E5G!6
-1Cpj-J*S,bAr9-S'"MQF(T)NrG[baiNmVrKK'B!Kj6T)BIF@r%Q*dINCKj+qc8H!
-I+lLJUaYGL9CI5JaTa-e%Z,XFQ&bZQdH3!*0-U3,B"$$PqJXB[eDErN)RkkX[69m
-KXVi@IpB`@HI3dP1-fcEHN!!lJZ(K[[M0CYi%[d,hlY)ArmZhE[rUk-@q@Gj506I
-iDd2hMS,NVSf&b$8J432L'QMU8H[qH+h+K0BhKim'%U(E$VE-(6[i-LMc)%,e$U5
-iLTajiFVrXCX-P#'50UqMf2Rc[iJc#$kSB'[TXDi4JJUU,Ab*kZYS%[F1-aI968X
-d$'Ce&eqZQT2"cIpaY[TkE)3ZraUr4KLrJ%2VaD&Va`5Vb-2J`fNp35")`5"TVK-
-+TGKZR*(1AU8"GGeS(!-D,IDamfHPcQ#k,%3mTYBl"d0mN!!M#)Z9&CM,#e$U$+&
-Uf-a))6"9NHA468j[2HQp*e3X&+,#NNFUa(!r[UMMP[+CeH4,Jjq4hNJD[3k%4(b
-*3@Cba@P2R#kB5L0b"d5K1-jb-99I)ZC+9ZpP9i+K+H+VeM%aC(0F$"Z#4'lciIX
-CqpD1`Me@PmC!MSF$DdBUKCf9-830TE21FZ$Kk1C('VUQbaUkCYNGZFIS9Re',`r
-`Xkc$YcLUZBhR,*`DG*XBXQl+#1T&T@bcNNN'#ZQ1e#J&G9*FY!$QkpRM8[X#,S1
-'V0bJ*FN!&)8j28BA&i0"EXrTDBDVj,6+AI25YGRL0!A,3#%FD'%J(c*CA1mA8&X
-"$!4F*$UQY3dGYm8$ERTJ+#12I`CN8KPLA-XTLI,aa"%Q-3Q1V9r#b%([bYR'GMJ
-!qihJiFlLDfhRp1SU"mA"@Yf6XcVB'#SQmkr6e8"SJ6lm1am1JQEA#4T$DM"$&8(
-jp8bH!hJ+pPbMl*C8LF5AbB'R-3m)(L*Lb($QhQ2hC"KrN!#8H3c&"QH3!,!R3fj
-5E&JQ"RHUi$#0Nc[V0M1XNj'2BH"qQ&U(la3YQX#Lj&','0lP4CqN,CV!STiLmj'
-23%*)$6VU84JEqfmaBa'lH98-')N+"eC4Q2R[SVU"aK%Lp@pq,Rhi*$%iU5l)ra`
-Ub"*GN!$4'``9N!!J5a4"KY)&'Ee%$a`Mb1KV*%L!6Y&C)FMS91))Hd+3!*c35ZQ
-#I,@cf$a@N!$4CK*N5JF4Y3q'#P+lN4"NL3,&L*4@68+Bi9H&--fMK'Q('6Bjf35
-Q#Xrarf4U'3*q8dMFpN!ijN`H2h%5P(d1"Z!C(5USrlcdVlpL39@@TJR+$N(K(qU
-LCFem,*E'$l+8c1+VC@P,QfQT4NZYbP,l88Y"$QRT"fP,VEa8(U+P2FV5jS-X[8e
-,h@P,HfKT%beY9CCDMc9),"AER8YEfSUPGfPKk3X[r*pdbFh9D3Y,XE!8F(U,q#G
-'%XBFeSfj@MGQ0U%Rdidj@NE'A$,8Q-8!*3@#kiaJBTK(!HeY93eK$S"dHVCE[Yd
-1Y[6Vf!)(35(ab0$"4kiZ-ZMhC#G",D2-'MpjA3Q6@X(X4Mh0!)4i!+U`Z3bDM+"
-e%0`mIjT"Q2cN+3+l@Yf'#&)m,*JJ"4dD(@IYSb"'RL3@[j,r-5eC$hMAlcSr&Vr
--iGbm%XkG4c2f@p1ebfljAS-MJVEKPXme'ZcYKS)2&!9helXX3cT-NE2h"e$`2'3
-L1bQicZFfU['CHh2YAlM(lS2-E0+4hG2lm9#RH'J1`CMM!U8I06&i#QeZ$F+BX-I
-N&006F33'!ra"$d8)d!R65k5V-*aF"4-*cbKh,F-&*f0lJQAA2jRTRr!c*9MjTe)
-S$%f"EDYd))%('F2,%)A*!!+C1ANUT!K"bMmR-8Mj)B!XFXb$!9r2`('&#YYbUU%
-f3d[Y[2#E!j`-%CHV(FAa$IqmNekRp-rrA%kI1d436SXXp1Q9Y%mc1+Ch509kKe4
-VLN&S,Q)DlN`N"j2L(f)#9#2KE1pIrpmi4+$K8hR4GbMP&MELBLJcKQ25i)8J`GE
-@CMc%Jld##"l$[bV"+6SFZRjdF%!fIV$iTlCca6h2er1!1G&cl,pbbGcbTJA$)NZ
-62k"j-9`INCB8,NZT3@#Frr%MEVL#MmG!jP&,-#CPXFRrh-R"AV19&2FFr4TG8I)
-rKmI0rQ)a0T+A[mkK2J1K'@8aQLC*VjDf0BKI@SmjKSG*6BQZ#fJ!#6*b-c(45!3
-0J!QZQ)!jYb2Ga)dI5`BE!kF2``8!!#-E384$8J-!9q)293eQ4!)3)H,Z91r"58k
-mfLZjQ#[$k#Fj,aH#(%fYie+UJ-DF*cfZB#RMZ[%8lNk-r2i@N!"5amfF!5eMhDi
-D0q0f-PNhQdN6'`aLaY"EkeVMC"a$l@QXieLEB4cUd&3003FPS[$hrhl[ppeh`1'
-Cp0PRRhPq!"eQ2L34%#m3!"!3!""4,j@*[fKU`KraSeFSN!$5B481A*FXl*'maYH
-8V$&P0li@53akdN3GL+E--E2PNq8[P9Pl!Cbc)d@IcCmB%HfQ69D%%KXA4a*(HX!
-#39VJCaFkE"jBfEKVS%`%Tq`3CDrTE`C@0LfQJGZQaXh)P-kiD1Zq2BBLBUrZ*)9
-pq,3#dkC$#)GD4FIA)a3XkM6PI[BDN!!*)0m!`QikdABZ8[6&*"jS[eejIY+Pkm+
-2-@i+&Ef6CMDEkX4jG(!C6CSpF`b"@a3l3XpQMMehpCddeUP$kD4A1RNLL8JT1[@
-JNf&JAP[3j2j'%hYkSqcTG[ATh(I51Pi4RD3-kqehdL+*I@pc%HM#d(ZB-S-VkMh
-m6-HbaGS2a``&ADIMjd3Nm@#Hp8emBZ+I"HN$2e$LSRCF!U+dF6-'pQ$L88aXia2
-hi'Gh*0'qJclS%RT@qe%h3X(G1F)6@5Tek&c*TbDQ9V-VNqTmqrZEQKJka"CdH4T
-ES*Y@aKBid-PTE)&MHJqb"@hL9EDJl9%4p)(iCE"iV,(JC,p`a50mXB38V*Y`UU9
-MqLJqD0JpTJ[ZKaUX0p4Mfb0,6iee!$PH9(NqDDJBImaGD62LE@Qdh6)SZbkdcc`
-ce)`#MB3@F`,mLCQb*bEFBp,41!2PX`@fpIY9l-M%VMpJ#,$dYbrXhqGEJLeiQ4K
-"NKHP*'Idp8AVdU0*bDL,&Lhk9NSdp42R@SM15pPTC`rQC'JCmNT,5dNqQaaG*2C
-q!3reAV(f5N&Qh8RV-)keap"L(0HZJ!QpK-43!-cTX`lcaABF-KK#&CKPTi%[YQ5
-1D5($'H-CCbM1-D'%iSMpX0NYNB6Bj!DldT5B"qaI&1Xb#RlK[)dZA1P)l`CVVi3
-6jCM*6B&fS'*ZcZ!LSM!i!XB9r-U8)rcBF%4dDb'JKK&LXY-"8T*6Fl*e@RT@0Mi
-2T#GRTICTfGSa,IGXhCQ8R"0489-TI1"JPLiRr8`d068V94Q+CZZ5,bTMNUSSk+Z
-%H@9U'cA#qD"Gd38RRcFl5)@aB5YFYD3FpeJ9UQT9,M%X3@@`@&J)m-#0dj&%3EC
-@+0h#(APer$)#3(Cma)fQZ9H&K435pdV2GAbGrLFe+5aUma!)&`F(RN5iI(HPF)"
--RJjh"Q8UC8LrS39EFbbY0&)Sb%2(X!i$l3$b*%$@&BL*`cT%S*4Rh34e`i#(2cm
-U(5aQd-De@P2Z,aBU`kDN)`+I@iPKiL0b&UTji2K-J+EFGcl&"+m"DS-3U+S'iU)
-TGdiT2Jj%LZDXCBSS$YeqKeHMCV$11bG-Z6%62QlLLSM5jBrJF*)kSI-Xh[%"X0N
-'pP5(6FGCe"'2[Y680-p0$j1VH'"jB(&hbiY3R,$JM`-CINPP!B8"JY60d&)cUjd
-Li9@$dhS#b+6'@rR)8Q,lf0YJqd,1pK9!0%YXlqY9f&lUIUfC!T@A9T)l&-k))*K
-re-LZNN6)I)S*K6dNN!"P%HY68(CC5%#3!$[dippp`GbPKH*#0+0Li8+Z(pFmA-J
-pp3ZjYCHZN!!b*"lkKiI0R9C,apFjbp3Y)+!j4-q*fHLm1MlDm6iE@)m21YC"BJ%
-6&r*BUX)Ne&N,+5k,bfG6)(D5d2EeR8e+LQCRD%PC+9V@J@3YbkbPRXh@4Id@@F`
-kNf8q`fFT)T[N8l+,K,HEA$*I+lk@dB@P"kB,UN!h08VC598G-U)4!9#($'$*Q*-
-$()HDZ6&N,JpSNm'!"0#8M1AJl&S0F&DJCL`*bUH83HEJ!Q+,AVLjDI"$3`X2qG$
-L!AlG9QPK&"ZE-mFbZME8EQb1cS1LD4J&890Zi,Y1X60aXB-i0R0`ITmH3cLl(T9
-,3%lM@Kc4Y2%SB#6"6a[p2`'3!!QL3((,M($@$h+&JQ'GV0pfKkYSRC2efd+ULRM
-hDl8%$N'SYBlBL8!"B%SdMS`k&(96KPcZP*CF6(DcLIG310rY9M1MEC3rYF1C'@h
-peCkk&fLH%NV'3)KQFX6,fqM!`KH8!dfM53@@9a4J#G,0JfQVV9hm%N&X6q+QJN`
-9B()488&RU*Nkk0V""Pi``48E!%T%3Dpd`1kK&IHZh59#9,TUf8I8,90)8k3Pchi
-$@1*ejd8A18XBEbV9qqhaTP)L0A6Yh+5LA[%hr"6!iSGmq%TBX(e`,`FEVRD`9kT
-YGEMQ9R(dI#ILSX,-0a&Z#5N&$&Xf6SdQ(6bE(Ud*1Cidk+Mr!EQi2$&#!Z$NC9D
-Pr5CXPEE,cbTYP9p9QJ[LZ!EJ$3Bq*lF-,&qfQUUh&dh#5d"`%F,f$T5iC)X,bQ*
-3L"!Y8,$3f%FRqiL`Mh(fB@!IHTMkM$@9Q1SXb,i[AQ02698EQ+"U"Dbd"XbeQ`i
-1F(Q)LbL-!XVcXIecY*!!#JDam`amRL)'C#3dG4`N%SQ62!bB-aE)MHCQTIj%bmR
-@"P*6SYNjkFkS$SM#[RT'DfCT69*CUI)l5)8`221#d$2Jq@Rid,12+IBa34mG1US
-8Ijp2a!&9I[85#*YKG+C@)LG%d[&m9fjANMIIPA8"fp[P9*!!ckJS+$C0TU"e6JA
-j1Qd9&02`l&BB%'UkmD6MfrM&fk5,0mNZY[#,5c"KN!"GA)+I5TRL'f8ASq0R1qM
-Lr-9#ba,LCR8eK!$+Xl,6I&rq"KLK`MT%f3je'G42rHM3QRZ-!6E,''!MUbi6RbN
--%11&41G"0XN13Kd(*3B"!pa!*9G(+XeKCD,Xk)qeb`HcdMr3`T!!rMBCV%b,eZ@
-N*&-Y+*YEp96r@#iR1bGCl*A*'Zr,R-dHJ0qRLI3h5#%"Mr8jFC)BD[5BH`c'FmF
-`F!c&arY3d+DM[ZlRK2CA5c#SiDF2"9ShLV1GND8M!PRF"a-UNE5rHqdhGk#3!2%
-0%H%NSpj8ep4%KNf01b&-([UJd-5G1kaJ5X1VdE@pB`Bp&NNmPjNjKSTKplBCPm&
-%M9YN6,5@-Um462I9f9,Q0B)j'f-bjPcMc$cHN5U$VG,&YlGb3Y8S,DG+MF)ldL4
-#Y4M-di,M-l32K2jVcABa@@ZZL"pLh4*'!E*!Y%mF%GiEDVGlGQQLia-JIrC4F(&
-6dq3Y6#cmbd003TSk1Kf(PKifm)G&d`3l'#NcSEejDN`eaI+e$9PZG,eT2pjlaI1
-PQ9p`I'hiUH!cUardrU(pMcVrFZX#E9(hLiDja[Ie$idq0h9la$VaUdGqIZIh*rr
-Xb(rUqfhrYirY(acSf(ISN`[[QLk&V[Cm*c,QrZEij,P[jIdSmmr2rlp6rrIC-r'
-cPp-cSQEGaCc$(ac-cFj+qZqT+FN(dRjFpj-6Ih(d[lhpakklVpBfhl[jrCBrZIA
-6krrPKrrMfY,TcmriR`rmml6rqS0rrI$[h[[rmrr2TrrlihpmlHZ[[,Ai'fm8,AQ
-RH'("V*IrBH2VqGp0r)GYhp[mRcIpCYG(ZrrqXErCmGIE(klmhDTI"*DYH'(GccE
-mlGTr@r2,2Epqr*p+rqAqAl9qEZHrPhhjkDqXAllbdBU[E[NX9PliaC+AjMA-RY2
-B*-P"9KTUX!2C@XB"AX#f#6IXRDfGjMQM8Q$9%4S9Gm$30cMS5,5rl4j,%q5SpJP
-H$%TB%`TVNTK[5G8I&SDT'k&la,BS[UjYYp3*EqINc38JPaLV)p`d[KL9dDJBlcQ
--Qbk%lTiD-hZid`C#-e(J(KX"8RZ6Sd1KZfE(lAFjS)Y4Kem0ZXF3)Vf4$`220&m
-mHl`@aNqZA2-*dBk(Y"Z6pf"XNRFD$hDiaicdi*!!l-&pcJFR!L"Tq,AQa@NLG0-
-XQUDFJ1fVmpN#bKMC,C(`5TLkB6j-HiiiLbX0J8ML$`JmVBK,iCD'9ULd$m!MU)3
-F1E&(4ITfkNiL2NV&0Jm##5H4"5FaR!r'AdX,#(NlZRE+*MZ3!&9!d84$PhX-drS
-`d)GT,f0D*EVEDF!*FVbLjQ!l$9TX"e12"qiDBBENX+31&0mPeijj0@9#DJSCe#B
-GhmJVV)fm`QVi9!CX&K1`DDL-**CINi"03b9qhT!!!C[&6Q$$1hSjX%%493hd15*
-,hehCd2VZ9bafr9984TQb`hNM5bGG2pTd5$`c+1j`%f6Ra'"N+8*AC#SM(mB823@
-&,,*"E"(2'Q`[$U%`SCY"l!h%1)kh+C*iG$Tp%&Z-*0LKDIK$#J'[[NrCbLl!ie#
-MCUY'Sq#CAK3cmd$!L)l809p@V@lMkYS@5Dbrc05e$6mIbkV9(6*eSH0ARZEUiZc
-`d#Q'S-aqM#f)A9D`"GM01j-Y`)S2"LQ-$REP*PrC@FRD@E9+e"5`%Fe!M$)eHMC
-hEm"MhrJq,IeL02f$P!1j@Qj15ZlCj25,[b8k2`R9EXECj,0D6SV'+Qmr5$J3bQX
-BkIh[B8R[-Mp*ljKIT2Gm!-"+kj!!NBVi2*!!6N6iP3XJ)3Z)&1jZiD6f2Z&Jj,-
-p91XH-a1*YUS'DB4UmqRh6,N0,BcdJh(rPlDb6&aR5rSpED4-"!%@NmJZ4RD$N!$
-JC&HPl2,G#[RhG)H-r![)''52,IRhjHf8Z%!KZh(S)!q[Q&km#%YK$bdN)q%6dG3
-X,5X9T*MZE(*1@P5lI-"XMUCbUSSST3kqMQCFbNCf6R+1N!$(EU[-d%YMmYbY3B6
-9FhGIAcfMTd2fkbR6$#d3$-VU&SQi2riT)qjlkb2ZZ6N`*qj486MZYk"+#'jdA4l
-Z2SbK`e$@d+FMF`q6f[4!8DGVc9B"P*d(ca"'CS,Z)%&2DZ)LlY&CrRDa##T"(HF
-K3aJf$h1$[jZd)2GB8P-m1)N&2BF+bq0`5#E5mL0fDLa)ikJ6XNXkC*GN)!&5-&'
-EBG5'VYfc8MM0`i[i0NI8L`F`KBl)3femJkPDmGfSjG14q%a8S,hGaiIA6VV-mlS
-(X!A22k2lfPTkV('$CXN%d@9aQRrR&JY*9)Zr&%j8LfIk*kV&lAk*kSlk40Aqb-$
-b&DBR)kSlBlDLHMbCLG-'@e(GHG4[8Ae-%G@Gdm+)DUQYU1l8j+)U&e&X*(MkSMV
-')@mpX[Vj%&Ejl8jTP3qITVLZ-&8AekjErSNVa0("KE9CTpFXefUYa1Tf@hD(i$U
-3!05)Lkmmb-U2`CQRD3QT'%PR,-i+["k4YA0aHa9(8B38$L%5fTS()qE8mi1PDha
-D$hI-H'b24N4Er!Lj+(NR"'6LSpf(HFEl)C,bM8"iM%`-Iaj@$1ri+BD$ISPK"F5
-`K"*r'&RJf&KE*`aA1f#f(@V@RGFXX$!&4Be!EdQ5$b(H%L*i)%K&X9CHQ1XPJj(
-l,DqliPh5*cP1Z$J8a4lRA5b[5bEJ*IGGcQ[-#53DQbdXQEI'Qch0p%6ZG8kQJHb
-&fIG9FNTj[(*h`L+Sdf*4-j5l%`akLd9V+ff"kE[RdQrdEE1DfjS*h1SRHL`,QaF
-GXPMd#p3T50DQCfi*FJXCTL`@E,&EkmPXFIcKdUEZYS9hfql5G,UbHk*6c()Ca'5
-cqIj$(A54rSb-h4LiqN)a(F0dNBMrf0-3!8CNd#I-(!`-Z($4lp",iEmD$Ud,e0f
-J6N,!*SJ#QeI('AAikF`a*&d+m8F53dXN`IT#+K1XqPeJMGBK#L8M'jUNJcle)DS
-cRe+GSB,TT33$8Y9N9&88JL$S1[((JD#k$9KqLT[k8()N'D[f-&Epml#XHYj29MA
-l`kS0QUhbCpk4+EpLB2N,JiVbAaMd@rNpe0fJ6P+92j-A,"J3N@G"Ejk8"9qUU#S
-,K&042#084Dk@-a%&mhNBAeS8FPF&lcLm8YC4PK($'f3CN!$+-Z#2`fD!bmm-Z1j
-A"Y3j9FFG%@$i&hBC@ZCbGkd@bKacEPp9m&DTNk3d`C9fDUaqP98$hKiCm'C+U0E
-&84fmmf1"&GB&phiXkL3GbpjFeE%@e(ci54a0FPZ['`c[YZD%)3I#Q1!CjF3KTNd
-KkEFH!BYlU)"NS4!pL&0b9HTkRfNq)XCV0pk,PZU(0)Xck3pRN@Q-4Iia,)ZmjLH
-,&2M&)MYNQF%FY,(cf(J"1A,GiE+LJ'9&8HcFhKL%%lT,&q8)Ll#Jf'r4MZ[DaTF
-UB!m'+if5S2J84r0pZ(Q(*1B!1*`A+5ShmQ5a$H6d+QrR!4H2,LP0J#!XP!DPlC8
-r-Ji&QbmJ10A"hHq%$$,N6(8)C#-5@4D9Yi8%N6QkQ8kh(9f04qpc%kBKR8HC&*Y
-pLKNVm30T@ZM8Q('"6$P9Q,U8(r((e%A3NDDFM1AJM'A+I4e"KI+E4Zl!,'F',Z8
-R0VVFBaPHbBbJ2*N0CaZ3!"!Cj2Ba!,#CXU!iIl$m)VVemJQAqB5%k+jj!C&&j%6
-df'9(19,28I,S#&'Be@K$ibkV01KQ,PaDK!`Q-Tk!UeFMpflj)6+5`@''Z5QC)KE
-FN!"-!UAPa``YQEC',6!*SFTI3fEc5r,d!Q)&phlk56+YiFr`,HXd[X8U(KNRFi$
-YP)9D$bS&")h@M0+5Ah0G9Lei@0Ed1*1-%ZY,$'PN!P*qLV[RpH4SP`DkKkC6jR$
-(GrPlQC*C4%*Xi'6QP(05KQE6TDKm'VP`q`A[2T-1)@FV8VkHJ4F+#F2!"1!a(Z(
-(IQrT`jVp[UZdKIjIha*SDA8CLA4EMH0ke%H)000c`mHV5lGARl$d$3+hFU9E19J
-Na`V%eV'`%X6[YFb@c$pC@'NZe#lTce3h!YBc`)IM"3(fK#r'Ye9X&!Ni'#lh8P'
-i''CE'Fc!`,H(&mpDR3B'[Teb!i2baG6daiTl5"`iZ`!+Zj`R+@aTCEfEe4!1X(b
-ZKB)"bcETlGSK8p)TN!#C&"6d28DAFM$FUhpq[$Ec1J"Zi5paQ,M`4@jM5P--`@i
-lQ3E$f9ma0Dce))P$6'qrheakRIjIIheY5fYc#+E"jVDM[QdJL$1kpYcFH22b2*M
-iG2'$I8`0Dc#(IC!!LMrDZkDN(Q&p%mAe![8!5'DKhILQ5cqBC%qiX,bT@3+eG1K
-&chX%#9#JfENmCl2-XePQfLc2fba2f5bIP5hGY4Z[4kr(CmUIjGA25K6I,2Qe'3B
-05L3bAe)N+C%fdLp-5ABBJmmTipA+pd&J$9[Ij"ZIcN2M[$"JZ+Q%hG1Lh*J3EMb
-B8#EEfJ)m%9-!UiH$!5G6GVfSJ5(R14Q59jbE@FAjF0L+Xp,2LR1YAa9R@A95i@I
-p9C-+AT98S+)-*R@M+,193&UkGm%MC+iTFjX!B*dDLjE*#e5bcEDbcAiel'Dhq,R
-C4Vmf@k)Bqb'CVLF9lSM3UqRYf2+j3('R''G&X0jI#CpG&,mDh9Q0a*2!CU)mE@$
-jQJ3)KmAFP01"(hYi%S0hjF4HH8C9*)BTGf'[T)k&$iC6ad+[IqTBD2"((E1p-M)
-5&@P&XN*1QLjD-&"Z'&Mq5lG8P,%iD1&ZB8Yl[3@D)p4TVYSCRhDTm%,Aa@C,K&E
-jaUS,,dkLeq*a-Y)#Y4K5i9)IPX*h3lE(MZd-eA*!0Xc#*G+dSe+P*&2h"&2hYm1
-UqjLIkJljTHj-HKLUZH8--+)+"d%9LcZh3!'XmQh5SF@jHY9mKbiaY(!L)-5R*0i
-dUdXNM9RKV9V&dP9)m(#B6hilFfbr`!+9lCD5L38U`X`3-(IEdMLK9ZH0+a8b!NJ
-krLdNX49XJ@)NM!r3#!D+q1,6%954D2S%VRB3Qe[@R9a`ENb(-'IM5PQBmlaL5V!
--C2kFDIZ(Q$%"R+%[HVNj()8kcpQD%bbMC$eEpimdcT-1fl@G"lr)j,4A)6c5cfD
-64bS,KUDD1HFJ$feH`!G-`$"f'N(-lja0Y`eU3JQ2Rki5S)!YD+U(,kcpqr'Ip!H
-)p5FAF,@8bY55VkJPm+'0@T!!K,ql69A,4PZe",J"%#9NB@S[P061Vhqma[8)'3H
-1UGHAF)1)a++2eHYIPPf2cVrBaC4H+#Rp"T%dL6R&p5Jp(I(Ej'JeY8ZM6d6aiE2
-dL9p1KJZb6-8',5Gj!$&C%3K,(JN%9,VQj!)fT!rYbq3X6FEFURTl&+I!UP*&[6`
-SLB34fJ99[4&Eam#U$&)[Udime49k-#Z&YNYqd'Sl*p36h2KkCH0)aZP!X(48H+l
-K)%C"cAXFj-Pa36c1cNT69$(8`d%$ZFTjN@G,+CM-lGRAp'pF'HYPbR!V6ScIV91
-93@k-PC(%JMj9'BGX(4Qrbb4P8%"h'3j#(iT#N!$2'4)PjY3"$Akq9-#$N!!`QqG
-Kb+153T4YYq99frC15E4X0MbZE,LbYIU'YiE#EEMbSRc$h0@JXX#28h-J5Y+HT3h
-cS5Hfi5eUCC2`ZEP4qJA1S28BCeCfbKaE-&CCq5&c2KfcCH#(2qDEN!!D5[,)6I0
-X1AE[jRR9MmXVkca@@DH(VD`cr+bXNrbUV1Z8S)qf4+UDDe6$-m16b"T[2UVi@Kk
--5Q3%4`ZUp'&L)PDpVjC23,0HEFV!"*RkE1,2Zf3A($APcSk6Qd+kV1PC0cXq"Ui
-6%LC8Z3[4G&h6)4RU3fND!X'j#emK"j%-q3C$YQ'"aLHD2!S5UTKJUQKaETYI8qH
-MX(+E3Jb,632,pdbaT","qNPJkX##X)rYK36HaM,kVm0Qp(Br-hU$AaNpcBDmpr*
-N6caj"SL+!)iqR39c[EC*3DTYF,Ub`6HEpl,"qfb$MiEGB)@I'jcYe`CI83p,"UC
-f-X['"i*mc'RC*KYZJpY"!JbG+2DAm54T%XULSSi!Y8U'XUZSFd#p,%-j9&358$r
-JE#DK0"9e(5LA$$@SSX#UM@D*i6M+TD+3!)LdXBH,Q!m0XjBbph`VFl58d3F8-,q
-HV%*V05UC60IdU8YkENTGdV'fUNXk[N0GdMEEe#A8-5HQ,U'f16Yj-)i)Scf-#*q
-SedQfKEQ%4d@CfB)U[e9eqAM*jH-KjeM[CH%c6[bfV5[5J#5i'PScb"5Aa9(aJ#J
-@P@)R8[1Z6QT#JjDP#!3GQNY0-D,49AkPm0hKLF1fN`'[6mq4E5V5bj&,10+6j'0
-AY+'Dkh3HiTb,%0`!Z!bS)l,M19'VJ$VR4,QGU*H"5R+L8Kf"ZbTb'T!!ef9)688
-H"HS9'@T349d'DVF6e88+8TkVARNG8bU[[ir,$1GPaXR#E9YjlDE!d&BTFj4U+q8
-RZCHc$SDam2l1Z3[IbFU)(ZcVddAp-24f"Pij%03iBHP"d+U9XPiE3Z+d89%U$jJ
-5'iI!eXr+Ua"Q&X!c[6A0p``e59`'!i&5lX,fQE[Je'q01rLbc@cAKJ)Z%"5Y'lM
-4cCcVcUjiISI86EHT!d`"-i4@@`-M4Ji"BDDUE,%S9CTAY!RVjKEB*B"@m%`iJ&D
-`fMq!9Y$Y&d$E9#0TVTm9-LTbab,ZPMZGUDT"er#N+pAh,fr0(C!!3Mi`B"l@,*2
-0-+VSP*PM)&!4U0hJNP!JUeVR`S")VPUCkNDBkRiE9RApIUV1j*IUbRLL),jT9&P
-l&#FPrJ5T)9dbEk'%2'MHc[1j&UYJL6F8`k3e0BKF#-iZ%5EK6Ya@`(l6SL6F8F%
-F919dMpB`%MS2#k@ae)aS+K-cfi(6-3cD+Qf@'3C0Skc1V-,&4iempZJ"A"bSA$a
-`mYQlbE(UQlb,V2CdPk%i`KIQQ00K4Z%Fl5(K#E`P(#pLQJCA$DPaS!)"l)H%BpN
-e3KHr*B,T)ae[JE4(Kqk(e'[EYDI3('D,dF8[q9GqKI6)6UG,MBHk2+(DA&i0ERa
-&@(*9JC3ae6R'9'I$-Y9P2jNUfaqQQQ153PUrlR@'Y1Tc2IqkYkU!XZSq6h603qF
-H)LE$1Fi*cBbl@UXLY6Kj8e5qMK%0j%ED)6pHZ)A6qDP@kc4j&k[@LmTA9@Rk8N,
-'&P5SB`IBkDC'R%YBSC''eUMCTCKP&*8hUNd%F%+0KU@3!%*K(f[DQaBMlM'fK2P
-6SCi+RK++RQ&,3PQi-pLV-h'R-`ee)J-G6X(M#5h+'0+aPiXkcIPUiJ4Xrj5D-FT
-a&4@cBciV1h+QcC((C8q9f$`e@12)298FqF*H,V)pmLlCNGH6FeYaAI#N'q6JAFm
-[UC!!M-E+U4(epB3S[+0H(Q1)%QP4f-X1,-4L0Y5YZ4HZ!-!r`4+ac@C6k&LVfG6
-CkY5JESS0+"-l`hEfQ0Iaa!G5iqJaFS1f25Bl6)Cd'20@0V#kaN%p5'abAYjNKk+
-'d20%%V0V&8A%C)USN!!TSN+f,GXMHRA8E0TXG3XmdE6T!`U&&KkZfGfmSZ0j`pA
--@h0$F,RGUZpJr0QMNf5Z*ahK935L+Ta*Zd9QM@6fFFAe+LADCXqR`@`!eGYF0i%
-AAZ4"+,X`DIaj[L$"TJBH0H83"j%@m22Yp+2QC)AUB$EPrMSZ0F"3Q'mk5#jVb3&
-3@'!-CIldI66dBI`T9DANpLjmJbYqMj3KKDm4Dj2C-*NAm`lcHBHe6,f[)9(,9VE
-iJH+8,jc"KRl)c%'8c'LK"1rQ3*`A"HDXYdRX,4N3Kf6r6%+MNMAB`#PHm+GXbAF
-fRb"i8%'lbVDcfCR"fP8T,'!m8bqiCFBQe-3&6qV2'CSD)+%KPNQPf&UF-Y,UB&Q
-i@cC"BLZ(MPb5$MBS-H%9+4aIH(KbHSd*AR2!pJRj%9(pR@!9kII$9U3YIPDN-rb
-U5*0B4CUfPiSdcEq+G&IE`2,(KbR*-SM9[$$9kDM5#F44RM2jmNGG94P00ke4%K$
-`*M!XI-U889$LB#3$2UTF4XBY@GNRI&mZiN6P$4P*Q8I,$Djk#-Z3!%*B[[j+'-)
-bdjD`I(e#)5cTRh4!iMZ@T#"F)Yd,Ce15Rda#ADNa30Tf'LAAQ1SSlPFq,1c$cMi
-ml-2"2S,X`mXq1YfeRPTZF,`aMCZm`SbLNXM&ElTimqhfiLA8p,)S`!3pA%K)lNT
-6aiXp3Khbe4KUUc%d9'2)8Q2S4SfKVKT$EbT$-,j!mfp4dA3a(Uaj1,MjFI$S6Ja
--G&a,me(6`++ND6e-b#DSNrEcrYQ"i[lClk2TEldbH+GIB&!mj1UhS($+"lX2DEr
-UY`4)XBF@ZIVYS`VL%b$X!9,d*d"iTK6%"5!m!9,m"5!F)`VLA5!F!FU)Gi%)`Na
-Q!Ui03S&eJ!`'+(-Z!HRPb"+',!(5'k!-)f3RhrEkA$4('pr+1mCBaaJkmLhaMP!
-!bpBe,&ZRR%V5NjSQB*+IechK%5r@G[+"mH)H4@hV-*!!Tj(a%6UF3&0hr!Sh$#S
-T-@N(%T0f5iP$Bp19"+IP+ja*4Q0Na$*-$fShaZrK)F06a8H3!%k"VM91i($0qI4
---5@D9j+9FM!hRi'jSV"JESQIB#lK&jLlCJZQ[RF+)'LA(f"U9dd`Y6PqZQ"Ummf
-pJkQ!5`kQ!UkU`G5X0[r!9-'Yd`06N`HcI[aN`&4$krmD-0A3qKmhQ'TS26d`e9$
-fT`&-0C5G(TK#FZJ+8S44BT1*pj2`lm&Bf+HG*eLN6`p2fNHI$Z&JRd'H`*!!2Vh
-#bcil4HHlAi&i+8pmc"MR%FS'DV5"NRVVdB4$3i89B)ih(eD%IhF(!dj35-!LZSS
-hQQEK(3*'N!#$V(0JP!`Lf86pN!$a"X#DJmK,mq-dj5JPM)Cja+2CdY-`Dc@aj2J
-%3LRTr(S#""A6F#8bJ$faR9r,(`#JlKUrL3-EU&N*p8M"+#Y3mZZ0@THcZ3J'5"p
-MJ25&X)"dRCq!Y03[3*TIdb4Y@GI!mRp+0V6mAQUf,U`a'R@53'LJT-S!#L20CFf
-@V6D1Fb0b0"6('jZ509a@Z%GUq'hC5Z'a*DDPDp"F($YS`EB&5T)5H90a5fcGKl`
-4258*R%Gh3QNk%QDdlDcTVeTH21308ZfeH&KRfr#AAY"'b)M8bXf9#r3,*$-bGL6
-@I"9[RT-+3TE`cGF"3KmiQ%aTdMA@'+@XpFNReQK8`AV'9Lq&CDYjrV(9V+kUf5T
-dHpD$CJFk8PEH*m5X"c2(',-&!#)Ih(GSAmiRha[ifF"(!pmDh$6`YAdI$UB0IRr
-`pAdE"Zm0CJdQG9`Fr,Z"dAdIGk4dI$a`8V$r!*!$+aY"4%05!`"TZa"9#f5C!&P
-YNqr@ET4DPQB-deZ'[)aDkTcEN!$&')l!fdfPeV'9EXK#5&UhYGedep1cke-)Ke9
-h23b[Mmej$"J1-BD)'03&G8iLdSJh%I%(`aJ3BN!%3BKkHh*c2$YLl22prqrEkpZ
-QQd$1ZArh04e@0L32%4!3!"!3!"!3)HlIe5Y4M`Gr&088FU5%&GQP)Yq%Lpa5T@c
-DaeaN%2ice%ZZ'4-CTXf5B#)f+F5%8G(bk(!3cX'Ep2@(&'GpE2"1-5'Pc6d+"-3
-dmh3eF-)FFrHTG,GFmRMUE5NV2*klTV'EraLQ3Bi@-QEjKr+N1-I#qKV&Pl*#86k
-M@krTeXPZh4!0K0Ud'-)ZcL3T6R3$-$`!rShGATCMYhpeqZVdR,*pT@RTp[`MkGU
-pf9bmV+qI@aqMSq`#%b8b@+0FlCkJf'3ReUf#F[T2chZ(i,!GTe5'mq#feZ&@2"M
-RDBdH9Xam19F`+TU6iP3#3S@YdFb9*q[*a8D(DS03hHT'Tk@*%+RUKI9QpK++26X
-3aiqjhRV-A6X9d4'ME36qmE!E5fRbEU8YVp0BeSNI-hjXq2(LTamr2[`d4Ha"1ah
-ejG+-dJU1'X"CCFHQb9dMKRlb0pA01L"*Y!&P*c401MMFP8B*(38-[$*#)Xfl$LK
-1a8P)&HHUKN,0(-"F)9`Vl2BMkDCe'q`KVDBR,6FM4eX@b%Q9[Mrd*lZp1+h`5,(
-@ATSCYMmNMlrkY$fK0%1&led0Y1m0p6aH[#A!e-IU,Hk$8jr9T)3YKi5Tjm+0q(-
-jH($UZ4"8ZGF&aca(G#4kb$heT1KZQ(l0q-(T8lX[,TRD(FeFlSXqTbK(MNR+Ph8
-h%$D94)dA6*GVh*cTH-jd(*L1$ih@@i`B6K$GhZRA2!Q'Nm"`%KK'L1%[9[XaA%i
--JlG(#0(r"YpR!d1SYm&pF1ecQXTSjYTLQ[EFF$6c-ATmJC4-0bf!65iVQlA286A
-"P,rb+9qDTMb2abd96[NVQe*b+ddT-CZQV-IMfBUQP0`U65RN8il6P-1V'&NPC66
-PcfmC6#Q8TRc$TcaVQJ+b5[396[Q'69Pj0deCf@+D!V*@0P8dCHAGI$2Zi2+'d26
-P$@iAYR`l,bjCANHJiQSISfR[EX((T`JBeSpR+bmZ@41MirTrA,lCm+-DNcXcPpI
-G%9AUf-1D'$f)Z&(2aTC#G$X*F3YLG898JZikPc4P-`h$-J%#NC9Prf*m(%0!X(i
-m-rlLNV9"1UEracAc$$qU-4NN""Jjp,!fb-KC'qb+($jP(Jd$Z!,NE)F6d8b9r%f
-l[C!!4-[9IU+PEJF%cYjX8c8bG3Q,%`"QK%+cS-j2FB%b*3S`b,I,0l0E%[piV"1
-rl5aAc*fP%+JGdXHRq%HRmFFeXD)IPfmfrSK"BqMih`FSe`EPfcAcf+h%*P"dZ69
-MLV*H'kb!K(R'(`'N+(8prYd1Vk)%X,+U!3a#2U*aGQaaE(IA+#1UX`b"0A9Z*5Q
-1[cL&6QN%iTKh)Bj(h0JJ90',2)MqL,bJDepKF9UkeL6lrS$e5J[YQY*LEAkZaVj
-IPS&eKH9(8ZdjU8G+Fp,afFkk35B##H'4FL@b"ZiP93XMj%Jq@c$XBCY3dR*r6Rm
-ZSh#X9Z[Uk0I,4lplJpr4Vhq&4bqXN!#D`XIRk*0GM3FcpE4&K1@Lj8U6RaPJC1c
-`KD+PQIQjTQ292F4@5Xp*e4l*R$b8jHjb1q[X8,h6d*ARZUj0eqE3e,(J'GKIV($
-c,pIe"f-!e)C*YXcLq[6bY2fC4c+H'eXq5"la%+2FM$*YUUBiEIpB-J*#&P)A5Sl
-JqVQSfJ&8E&e+"`+PK6E"ii%DjQh(BSjBj)"LM[mT0RAD'bbb5(6GR2X+&TF2%Fi
-r8RK!Fk5dH'`Bl6FaZMBYHqaKXIr99XkZkm&B+fIA2!1&aE94VFR@dA"9&@XLBS8
-fh)SU&Y[bSUdk%R$C(SH0&#X%aF,f9,YBGG@U`L'US&KGXbQ9$m'#2,kPIP6aG6b
-#6C)SY[(-@A!5&1HTPhUf1TcUTGMfpDC9)M6Slp`TMSM19$&VYpBjUGV4JSh#@1H
-,l3X5A*V&RHSE%E,FZ2NP6%D)j8hEHlB*E2YrmSML+fZRfa!'"+2H8B$MAFIC&j3
-cP[V%qTJ%`(dT(8%P%"IfP,K8YJ3`#284Qi`[4DFFk,QZ2j`HcXh*'#XekL%pBXI
-f'4rEKQ1E*hYXFqF)dR#k2[CQ(0aX1VB!TQBFfPE@3T0aD$-rX0Gde%SkDK)lDRY
-`*(6Kl+M4JIAm`$ce`(AYiA59GL`2c+X0UKr5+j!!JML09d1B+0S$iE6dXH()A[a
-C3r0,$3fII@PKE8CQ@TQfk+)(D0%dc9M9r@+$GIj-c-T+8bHcI&H+,CVR$G1rTF1
-p`l0F9&8V3(H%P"a*F6CXAd*!UU$X[DkJmMBTpJH%BKk@%*S(YeZ9fdZhm9bj'dD
-h[q[S[pPbLjpLEeFqMl2eH$aqLVfk0SSpQDklCrpN&,[+acEMf(2*0@!ppShkQb6
-&0KhlHT0bffJ5$QhHEU$Dfk(Dr,"3lIJ,fie9He0Y9(YLaNUY9EYVMSqIDRHpk0L
-TGLYh#!$"UNlUb!2$5F18H0Xj6)J2R%XkaaaekLAcb[QI!,e'Z'HQ"p2`VcU(Z8(
--2h9X3+,[cI5"MX9H`!)aNC5Y-m6UB#+hX3mB#HZ$"hF["+2)V49-(f*65F9E
-KB43IJX&MEZe4pK&,fP``GAlP8U6TCf#A-U"06U$9@Rc8$Q6hAHCrXUdJZbrle35
-CS[bKaJ"N[,ViJqa2Y3ECC#T+VGA5!'5R'-L-!@DJB*XNF$RTS5*`@B(eIk&@DBq
-A@[f50M4dT!*)6i-`A43DeTN([A3E2`aRm3@iMpH,#8%[8Y*dbQP0qF&bTFlc&2p
-c`SfY1P8l0JbH3P)#*5Y`j`9F#`Q9AR%[Ra$M+Ef,()TbeF'pRJRLhR[,PG1H(i5
-48YCHlIR"(YHpDXmE520m!``Q%)1M@cq2`r!XE"f0%h[im%R5m%Pmq'8-[icKiib
-'la%6a!"F4DHVcIF'2&IZcI"Fm6b*G*XR+FRCV@M1LKrMaBr#MCc4MrDi$RlXbI$
-Z&K-1"V#P'q$,A-#d#jjRi!DIJ`pAHkCK1k6Dm`bI-Qf6#aX4hX&Rk"m2-F,8P3#
-9"FcpMHfG98UM'!r!4$`[m$r$!-m`dZCr#G$q0m"i2`$eJQF0T@CB93)G@4mhY2Y
-JD-GcB2fhBd5-Tm28Q-@,)(Zm42CiN!"pdC-+XZ-jJFY"hR*+`8-+GN@Np8U1H5`
-20pH#52bp4h(-+4+l+AYFYkU9dpbaFBDrHTQrH(Q25h66mM!NIqRGM9GAHplL!hl
--!I)@(rCM$K!!(SU56bDRHXQlHl!C[,86P@RG8RC,'`T*`l5"(Xfm2ir3pI2H%"`
-9NSZk$EFm2CdH&hYT%([%`%e*h#@+fh%!feE2'(+E(RJ,!q"N[&md(E6TB))RQk0
-aYS6'Pd$N5kQ*qYe)i4R&i8Fe05"NpVAP5S2RG@ca[6l%RBMBe'SAMf%VM9*TXNf
-+1b*[8,RfDBTcdmZlUSF6#pDV*(SN3Eh8+RVZ@rV+4FqV,Cl6(NIac0+JXaYY&U8
-4,YLq(8XpV8NAS&5YT&3)15YCi3iL2(T!dCR-Xrk8$Kr5*+'5&KbK(f&-Hi*,eB+
-I[!5Hm)NYXHdA`3M*kc!3bcUaY4IaRSQkSRT52lMS6S4Ff1ULVE-@T(pXe9j&4+M
-k+$9H-ZaZcXe),br9j)bPZmk648T!+#GR4I5SJD-LbqUSX#)aHCi*L6P!HU89DE6
-TL+1fmmRcV*0K[&EkGc&*E)%YeN(SCQia)AQ[Rd1NkSFUiJjK@kZR1!Ta6"ZP*ET
-rUN48hV#2K)6L#cD5Q0$B`Tk)LlB%)DM(ki"8&(jJ"2Y51R3b`8D1Ql"A2`UKeZN
-q"&GVNlZ[f-H#'-RG'M-a2)k85)JqK0k(Q11ec1YfNIK6@3HG$TXjZe2L6YT+Z"-
-9cA4V0YhD"V&B"+EpVVf+Na@#!E$X"UCieF&9C80F6KSa!U2A%%M"#S"8Bq(!0VZ
-l99lhD)BaN!$[Ye@MF%LraSQA%3l%8ql4iM0q3$5HX)B%Zp+2LK1MRkpG+Y(4H4K
-&-JihiXAC9$2[BXk)"a#)r9%a[cRXD$Nmj,##1"AXKej3kTeLBLFAmmk0pFTN8$*
-Sa,B+D*&CjDqT9L*2%iZN1*1B,M8)A+U1SV%,@bE*k4pmSr[kJdI4d@r@j-(aVJ`
-p44fjBY2d5cFNA*a)r,EKC6kf$@j4kG$CE#Ca`%331[m&[20I`%@4ac5m$S`V2C3
-3mT&9$6"mSk3)Ni`U5b-BE+4%[RXcP1pij[1T'c")MjqVm20hr+b5EZC$$"%4'b5
-fYT31G*2[iHFQhVRI40f"T!JN5-dSI)'M0Ei1dfLqjqqd[8%Tc%A%+!G!ie1-r-E
-X3EJ0XGbAJhFLlF"#)T`'hqcM*0l&MCa(SD6i3qQT)(i"42jG)6)9CT(4%#aAE*d
-lrpCEq5,50+J,@&5I9cqA$J6LCq(Q,Rk3!%5rBrbA$ij9Vj11J1lJ%XL2PilKFa4
-,JT3R1[aEDpM$MFD2B%MH"4)Ej9IIRFE61Di(%BXk2UNf$pjCrkP-rU90r'8R%BM
-dAeH)A"#r`a!U41BhL"d0+H(Eb6A"#dpLJ!k(FP4c%2BA!@"r"34@KbM0EcBChM!
-RE8L(JQ(kYpi9lfQqp"p1B2rF@LAqeG#pA[8k!9mUhf++T#'eU4j13"L(UTMN+((
-Q`f(!YjCb%mD4m`!Z[cakk4fP"eCB8V5`)Dj,4CbkYD)$9HfiA09SBieAY$DQD*D
-0*YG01lNNk4'SehRSC3Q[D1KSj($%6QP-(r&UpP'5T+U@0M"dHMC,VL8RN!"d!6m
-hK&X`l)+Q%S$Ic!hACf&mE[D8!23Pq2KX1)CL`8Mk6l83kd3R@0r!MH@'A56!h'm
-[pGb!aiF`GCL+(+1)kE"L3q9jfr-HNIRl$-pl(Jq[DZq"M"L[V"-Sm2'VjPG*e6c
-*50aAHkj#94p!+X#3!,c*b)qfJ4pYJhbdS4)XprmpXcMVF@!5PSVj2S#I(1PQPL3
-'aNR,HRN&HJNr2q2%rDaL-6$d'CM2mMc!JDFh!PiIIUlM`1[M`00ci%d#m25Hm3$
-HH(bF*!([1L2JA@F![1XNi,NNi,Qimir!pS!%YJFJAYEK#-GPp9qmM`[!U`*aaAZ
-YJ!NUT*)!bYQ++RlMbGXYIY8q+f%Jh2JPG91aM#qjH&V'+r%bL+D0*Y%dalU!$JX
-8G,h!k5ERlARq5mKL6EH6"0["(ClIF43YNJT"c1&#M4HmmIbZhLBKD*%IJ[lV&!Q
-i6d&QcGHbB009+0LHjF93fG*6%%$H&BKM"i*3ZX64YmS)IFrMCb0(hr-FIDXiqXB
-!IDZ3!%*0DFG)cTA3Yp%)I4X0d,G43YpK#Af(6HLl5d,IACKf`P"iH8iB#DppZ@-
-RZE,PP$&QF*2)B"[f8&bqlE'5a!8+jARIG66jEei`99%j5DJCE@YG+V+a9P[cr`Q
-C(2@5@B1GEL3TGj%8a`(C4!&2VG2aRV#+##bcQ3@C&0EGaK-%*FHHMYrSN!$9613
-!DA,!DI$"E2#"`LiNT#TQ8fKb$`Y0T!&bH(+23AJbhdS@XB6L9abLE2BIq(Z%+FC
-T2+kHLX,4LF0I#NIrC0qlBq5Lm[p%U$NaGm0BK*UZikC3mjeA0G4m[iUKCLf53Vi
-RSHD)FDJTT63pAU(Q5+e$c9GKbqGa#$9rCa"UMKL(QK)3M5GX+K*U9MXD%'TZp`X
-eGA+SkErPpkEVHaTiMVbL`229hLkEiKGiMR#$H*2'6#Ne--e1fM)m(S5FCk3EXiJ
-A%$e8$*f&P'%BaZqVUY'&E')ICH&%KKJh)UqM3)icG%U6,R%MC6dQVIFc8(XP*CP
-L%)Ef3V#fA3[9mYc!Tfl"S09'BHLA2!4&J9R*`0RL&m$p&6rrj)E#2`d-8#6BXi-
-fMS-*qSr*"+)53"VhX#-d[L#&SJ@'S5JRFh%&SHJ0k")@aeFp&&dmd9$dHKcKZ(5
-8-ii-I`1)#1C'@qrM()c@&3P''lS)4Xp@5',Ai@L"`B4DKU166r@5`p(Y4F24'*(
-'`Xf[B9EaMASHN!!fM0+$U4*3i`&9$dXR5ip"@$SLKD@5fMNE6)'T0ei+6"YdRS9
-iGCCA2`K![l"d2Dpikj0-LQYCbXhc6E*jAL6Pi3*h'E%`G6X3JSe+)$8,a[SQcaU
-S6``,C2'L[j6m3%@-&KLCl!Yi@VR9E-IVAQcf[+fAYRZ-JPB8IIV)m`iGiD%-ccZ
-HKGJiH3F%T[#+r35@H-*2*-b[-'5G,i@X%Eq3!(8,2rB@kl'(@P'Y2r(FajP2-`T
-DCdP"+phF*`Q0DAj"d@r`Xi),M49&K%Dla(i-AYmAG5&4FKB(lqSZ`GZ(Rh95)%[
-JAFh"1`AJAHejA3,[&#VFD3,[1L2`VLX#hR9qi$8)DaqLB*S!1`Z#DP%&3Hem",A
-4#S*DAm8LT2(CbB5e"3CKV9A-946@GV9%B+`#fm@e$Qc21+Ul%*-I'BHfALp(kf+
-Mm,D1SrM,,P(m2(9I8V",+2k5SrKPS2K,cjX5LPr'cjXQ&2FDSELh#)Tlr9"X%2S
-#aBXp#kqP2bF-K@3Y`Yk*TX-EKEdM21aPhAL0+I"e0KL%[GX9%T%8pT,SE+K0f$Z
-a8-3Sl(hJHa,f2V"K)Q([b#X*HhQBa-,HGakhX2IpUSHp%pf%03jl&m+S@#JIjGT
-LcViK&m820%F+Y6Pb%EM#R1I#@Z*KYp1(#X-[2eEA2mX+&aLb!P'`9`ZcFa#')kQ
-RDij&@0kbG@)XpdqFT8X1EY!dS`eT&mI##dYF+*9p'F,Z(NT#S"3&+YL[A[*K2M8
-qb"-8PR&heaceN[Yr'ID%A'kICM'UqXXKPd'5`Kb@T-"Z+8%"dhK$'MfB+TUp0fU
-3!!,ai45q!"DXiBA22NqY6d5kJXZ8VZ#$N!$aXZ*d9&JqL%)i5!bCM53'Pbi"k5)
-ZeHQ`46rDD6Qqqk4VQeT"FfVE"+KSTH,N4Pi"Eqj$CY#f$HV+Nfh3m"i2VDMaU3[
-ee%62KASH%T9Y4f,-+*UdK*!!IRIkr6[h+56%)-aMeHr@ImS+!KQRMN""el'd%BM
-E"ph6Tij6YB6`4ih#IMSc'DV@)d5LR2aHASLU")dIC%93,"!(`*r1Je-Rd5(3b"%
-+i%dG,lU4U-m,`0UAF4-$4pY&4kZ4MMD01RI6dISJ5QeL1hrejX(-U423$81SHel
-RM5iJp)$`IE1V*'Cqa!J)@X0-S3S1ZBSG8KF,pTR%F+&aHG3rrF'8bi"5Q9elQk6
-[Tim8NblQT+9b&p6AaB@bM[Ur-a9YCFeZm5EB3N'[cR)l&BC,C%@c&JXP!p4YPh8
-'3d'%`MGpJ+4V)&G-E1Y$J'YKiA8C,k)Z0j[PLN0E"+8[D&qe!jK)4A)BUUPlqXS
-X65`dIH@H3jNVpkc-#KjFQ58H#`BL1d9,&N3mNZ)Y-iF4Z*XMB6-DUU%QC+e&ML1
-Xb,&A[H5ICb+m5e![QGN8'4D2eAL$&h8A$GRAJ(ePSTLBp92&U6eER4Kk'Xb8qNq
-PiVjkhK(RX3AIePHEN5MeX5k!SX("K#F8TmBTMML'1VB%SlUG+2lEcJS+5k)B4H%
-qMm1f%4Uk&FpaSSq*!5TL&rNA%1ifUF0HZlffSP)'*J4iH4T+HD@Le'i4-"BB(E3
-!B#bB#"LcLS$4"MF8Gq'0G+*j%5X)r9J$K!Arab"m[bJ)UpK&9!a*3e#Z-MV`+S"
-beGL$FZF0IU$dB`e3V[UI$-VpB`R+fKFMRjPN,8DqmZJV,dBqmaI@BZ3VXkY3M$b
-,'PqQ*K"3Q2SCc9(CJ6hieX8P+kI*VQdb)S0ZhJNB1,#a$%mMc"K$)T5@kF,TEH6
-3jX@aRe&M!91c"BA&4p**YYVp3#dAQQ`P`"ThN[kUPU*(8HqB62Vl363Ge-T5YfI
-Qb`C)%%)qQMNcAjTbKVS+iq-9)EY6,[$jljP($QMYA9-S0ce+95JS05B(NkNrdP0
-bS8ah5hXplk,h*SRZMJmkcI0HShp,ApXi2'[hpedq*IlFf[@IafNAm#4*YR'a[5`
-0fGYf3`RC3d8jk(rQe(bSJEhKTBScMk3I-#+&0I$3MN1fV0a3'$QXq%!B5,%a8Xj
-5F'M4plP4l%56"a)qdFlL982D1!%"kB9(-LUQSS[P'A&M4i5U+"(r+K14NCC6HbT
-i%lCIam(*G5DBTTaDqdPCF&rlGUIY@+1LG6CB(,cBHbq+ZbmV[Ml,V$4m[ml&5EK
-"h"NIaaZXcA9eJS5FY0a`'"@m!Pb`PDUkd0+*,B6SF(),3Ec"BDG,8lbGD5K8Y,i
-Xj[9&ADIe2eQ[A551k-J0G`FBl5mYdfC8U$Q&p2pqa9pGDF1#e"@'8$q3!(9flIS
-bhqf@@ml!qFq%D4e#,2hDpB%il@`M"Gf&T6+1T+CD!pSL5PSB+14SZ&f"Nl(*eY1
-SP2A,`*K6h0"J9QM,J)T9`m`dKa'S+@K'[X+"&RRJFIdaaDG81#M2HFNEajRf
-,@h,$YMZMZk0rUFC@&M9ecaEb*Y+V5N@2CMc$3p*(Tca&hih2cXQ3!#5D52qX`J&
-HSk-e6)D4B$63)C&a5CP5a5Q#dF#crJ0j8m`ZD@J-6&eX-'rQ'6G[-QQQHDi#"*+
-53-QFC&Cf$Yq4TV63`qb6r-'XQ0q&)U+`ej1+'3f[,jPC4X(qi$CdecZJ'UH0`fb
-*Db%93HZL`ZCrA@c3F-4T@L`b$0HZ6@@$'idC&bmM))ZTmTLTfe@$#rk0r*K@cjD
-F1DJiU+3q9&,GfIESD23$+F(+3pA8De%[q@-aYMdEN!$'hYM[#P%eA5$Zj!k%b3Q
-$3Y*jUPe9AHD4L5e6N5M`@qE6"LbK`e*e%!U4$VKSrEX9I'l!jdSbQb+0cbZVGjF
-jRfq-*!DR+Q*NUP+CUVMhJ&0hcG"A!f(c'PFK8[hMQcY$SC2Yde$BiR&i#1aqGN!
-laY&Lr$'dqpNpfUAH2"aq(Jjr03kIPQ[#Rk%TeV-h9-T%5iMq3Vk%*"(cU4IJL%"
-P'h"`%3G[kM6MYK+hZKVc[#[dEqQ9'iCR$93R'S#MUA1UST2!-FB%$N8j*bD%QXN
-4+Ri9hi&Qd"lh4`kJF`k[rfF1SMN%)M1"k$5C"4Q6Ka$T5)L,qJ!JYGqiFP%5Ja6
-LM%%P1iT!d4f)BeARamEeeT!!p9lr5QV%D*jkbD1AUm#Sd-U)#[X$@@EapePYaAP
-8A",TZE`"J1C-R+l8DR+AiRm$8@5QKdHT#!`*'jhaDUH[YRqXcG#Q`N+VJ2`+f%5
-Ub+E3'!M86"eV2JZT"Z4iGF*9Xa@AI`L&UA(Zqf'L1[Nfbf'Ti5aANY`%N8-Aa@8
-ZR-b0%Q60E-ePc@`CZ&&Q5d@IV)eVlIF6UkpqieU",Yl*33f#!h)"dPBS'[@Ebp`
-TBN+%YR(G)K8QaSZZ(%IL6YjiQ'6SZlkLRNH9mHUi9+$UK"RZqT5k%2GJQq`FKlR
-rZ99GikS"A)3V-ae5!aFme&bX5-9eI&,M,U+I$KZ#4&D%1E+*Uf20&ATYIEFJPS,
-`'+kDBh6f)QYJ)PSQlKK&b12Z`64rTbJ5T1k4A+*SRQVfDUY,&!hV9HVkYKe$'1b
-F1@`01lHjBCBl)m8)pP%d6Q@10#HG5aM9Y*U-Zhh'$VZVkl+eK36Y3%qf#69@(0"
-RJNQS"lI@!"ME5GKmN!"#X5JHZU22mFEpT$!8J5CYQ[CVmRJJZ!!IET3HEX6$$G,
-$$AMiKr6`$cc-PalQiq([dX2ImA#9p(!9(Uk4(Ul"`ccTB4iHlT-HlX2$,1PK&Ki
-HN!!H(UKGd2kBcbKSelrbS2faZif#p[86#GTcDE13!-#V[84X9pi[IrKUA5!Z*AI
-J5(jDDSkL`19b[fDlHhV"l,3c#IJM(LbB24-&ieE1&Z'm381-q*Ma)%r`QH#H[Q)
-CNJ!b9ba,D4[%3hdpFbZ(JNPJfDFpA!U1B,PL$M&E-8FmZ')1-5ZB)c0E-5F$MZd
-9ph!fph!fpcaj6dTZYpdZ6CI-)bp5i2[$&YFS(0@fAGLqfYFDG!I1"mk6%+b2K@I
-hMX)Gbjfam@&k*)GfZ&92'eh2QVH5-++A#4P86*%C6Qm-3L-23'4R3)cN&ZE3BUI
-f)9J5+qZ9##BrSGJL1HDY36GF9ZD1,6`p,$Hb-l[eRHBDLbkaT,XX%S%M("p1ePJ
-+F-%BR@AY*aSEUSpTH%QhGVjSDHY1$8$-fC!!VX,*L&q&jNMi!YY!)-L,XI!f2ND
-G)TYkQC'ART[2laJSEJCj2KJZ684%q,YrD4Ch[[e"*"UqkbpYZp$JXN6db$re[cT
-AkAE281d63hH@NrP0$V(EGLUf1d2Nj-DY1A)HblE6XPr(4iC0$`q5bU$CS[0hBK"
-qE1&@-D4[#bTC6bMQ3ZHf(YSFqacJ1mF),#l0B-3TCq3`-l9e8dGiD(G(f,Rl*dL
-qi83&4fl5rqTmjFlPefQF`5F9fr+rDFb$cB0JLXD$NDTc@bNR%hp`Db0AHK+DjER
-!&XR0N!#@i@C!24$Ek*U+5EMJQVME29AaSUNYjqifh2DVE&Lk$BpC2L5Eh,EEYc8
-Ppf5#"%4MA(2R*CQ!eI@+lS9@hEXEqX*$qMijQ!XUcc[A0dGfr[1[iB9k1"Yaf5+
-,r&+R30Abd*6(Tl,#SBN,01f",B'RmBUK1-`E,0@TcU,a5aYV0Z-f#0&G"&BhE9a
-cKf,ZC40akH&L5H&EcJ#-69"#-Hc8GfMbDlBK*6B4j0%Ph(B!01'8h1#1hf`+IrU
-AjR!VJA[MRNfZd@B-DGE%$VGZk9L`jmkqk&CaEfAJLrIJp)64B3@b$VFL"2PY)h5
-a'mC1CYYX)LG6QkV5fY'NFMC$,N$P"B,lJFlQL),d!RhP$L`i3a0L"$"Lp,Yh-c+
-FG`,dr0B-j9cZSq3hjflF"10AJL6G6k%#kc4$JbHk4ViK-4RD`cR-*)2!D%A+B1D
-+eXifmD[EGLM11r!!CF!ImE9$1eDd1Q,dTr1e1hD3!)RB*kN20Ei5*(F)QL2Y(&R
-aL@DSqEf95eDdDT`dA(a4CHjXCJ`(JI,"CR&(d%iZNQk6!P)h"8&NbaY9&1rhKdB
-pRQ@+E43TJ%TC(Llad%JAB5,dDeDKiie48JfFc6cC#4Y&A$&#CHcQH+V)hD,Xp@9
-D!%IFEmqh9[B'+[3$"(pRiqJQ9l!a(#KaP3eP"rMamqL`MKKEl[LbT,KJ&-lfZ8a
--NA!VJ5'6lc-YfiZQ!qB'i$!lj-E%"SJYjeSkqJ+CKC9JaX"i+Yca1`2$l-9[T'i
-F$[$8Y%al0UbYF&TDF6SRQ5T8reIR@CA"K40-3TH*DYe1U-3**"1d-m&-&iq$qM3
-rkj+Ec+9dEJP!%pL0CL-AL&MkT6,YC"Br4BZ,#-iLGb,)K6,8+jA8e6c@p,Bq%Vd
-c!21P2@P8Cm',ZNiR5b+T9'S8+$95AN8NZX!)Fchr(r-(a-3%&bk8XlZ`(),d!pe
-jQ$j1RI[9Z3hd&A4VTcPDM&Q(qQM*!TIf%Gej)M[9aT*Re8Y@E(dEKAGJI!8!cUP
-+!qXB6ZiY29b4122GV)2,,&ZjL%-lR%N`3JT1jVH+&Rq'`@M5X#lUEY-FMalqcK4
-kpHeRaXMr(+j&A',2rD[KbUJHbA6LF9`bbqcJADQRp5XAdT,ZkFA'*j+(EGf9
-AHY*`m"`hKq0e-+1TB6,4R66-',lNMcK0k@&YQ49eR($4N!"`G2P0[cTR5,i1j&G
-'G`%JPHH`S@2@L-&i8Ra92c8Z,*&LSdmid*c"%i-c'!Qr0P3H2b*iT6CVmULbi[M
-(5Pcj0PBaIR81f`j50I[f-e3c$1M1j,`NCc%jEZ"LZTi",FL!PZ!2Y+#LXh#f,I8
-5NCm0"SLa4(#5j0,Ydk4U+Af#+Jl!8GP`U9'[am(Q4&A5B-FM)-+0kMZ#p1i@PG5
-Be'F,3HDCS3-,Ed%cb`FJKC`J+3CA@)Z+40N)c*Fe2*!!bMf2+)@hH)Nc-(('!@q
-mP0H[#FZKE!mY"aEcjF+%B-,DBZ"-5#"61"laLN-*He#"1pYrEfY8(YENYDp#8Q`
--$c'0%`m2KejM3c4AFCFEY"HjU$N-(a"p%)(Dp#iCaMM$KcR$KcR$Q$($rl3bc%N
-cBNF'`feSNP#*i)q)*#5GiY02Jj-(#8Rij)1M1[H+RIUjX"d*24TYUT("#G3bB(b
-14MUbi2DKBRflMK)M1"LM2(fZ4QQUT`ES,UA!4!S2P9##(jU$4aLTJeSkJlKaMkV
-NSNbj5,$3SFN[(bi@De%509kC#9mQ"+03B31[82aiT-b)+*r*4BMP)NLRDp+CJ`M
-'9+&G2BUZ3SC$f0`b*&3J3X@j4+B"H6iVHDCM+l*UATD4,P0%*)N%*MSU91eKMFf
-U41Md2EJB&bBL93+Zf%IQSJ)d&U#B6RLI(LNQ$jUTQ4401dqHIjKBb"2#PK*AjRB
-[66)R+(mdijU+miCUP0X9mfjmT0FF"3d!Vq9E&abLTmfr&a[CC$C3SF[`QPP3`)q
-a,XL6E$4j5-E6D@T`'6ZAaQCGfZ&P%rNRQc%a#B4%!"YE`K'iB,hXmcQl(Df,fFR
-0`!d#!-%F2Bb'k&Ph0GZ0T1e-FYY'#*c%"%VFBXa)V[JrAja%lUrF!3di&M+3!%)
-8HMQLkH)&qRF)R$Y0)(Dk4kfJ*@A6m+3Ll5N'-)5-3kRl0K'!Ak3#1+UEB6k1UNi
-Kc"Z5`@%UKX%[eqX(0K%Z1JRa5A%b#P39)5Q2N!!ibrbe`Jj'bSJdDe(6+5rcmh)
-#3d@6MB(UlC0CR9A!V-&Y8H@&B`@ZUM$L$dMU0b%&EGcj)F9@)9+UMC!!dQmLC+S
-b&mcUPEN101@#%*Ch1ID4J)3Hm#kd+Mb&JM)CILS[!93@RpJfTJTh,+80eldm5U*
-jm#5UU4-0cX6a$BSQ@A3$V8j8C+QaB-DQ@m2PY&(+24EQK2eL042$&98kpNUZC!N
-+NF8q-S6DF%eAVFfiSV!AAbY-C*R3hX)'bG2jT65NKH#FNaUmb9r$LbF0C5Z63aK
-M`4K#92NBkYMREJfA+R6-4(,ZRXCa0T9LQ4eeMEBK&-V,JlJI3YAGTMb-`1k13m)
-AP@&2$6VKrQdJ&DJ3YbNqqS$J)G,a'"ccfj5kMF1BE0(L-RYRKViH1$NJ0Y+3!'k
-l*NG,2CBL1bRbSq5N'*!![TY%,)`S+eJ"a$`#085AY$`6L$+S0$U$`rZ-$ZmhK3X
-HA%T3!Pj8Tpc)Za5Ub+Sb'@RI+USNaYa(P5,2jP3XQVd`#he)Sr'9aA$aLlU#UBU
-[d-a!kQLJPfep8$8BZNM6)l(MDm-3ZYL%-DSGHHa4%KE(B$$Y3aG&65"%NH!!iaN
-1J'BZ(VaG(`0*cECGk)4N4,,2!#k9QP)N8mS'%(YK(0DcLfhNEf#"$J'EMDYRJfa
-bC5[l("deE`U5c#YY*KVdj9h-+6)(qTPCHlCHZ6XX`Nb'Uc4XUARaf-!'9f@Lb[E
-bJ,JMp*Th0'&!X`LGf9R4%K8'K8j,MQrQNfJkbh,IX'YhYk['qFJ9$+m6Gb5pKJ6
--+[m"fr8[h,kKlhkD(M0pA"5fE('KdXDNaIXdLl""HTL,)Z3'&b0NcF34e*3QXq"
-3&1iakN,K"5e0Xm-'06QfpR'R&P3M-bqF9q*+ik+&JKe+2e)[qD,KE6dCPET!C#6
-FZ%+['KTX$MHZe@2KQ+D&Ua3A2(a+6"1Mc3"bjm%CE%NjbET[HMN!GcK*%c,hB-T
--rb++jJND#59ZHUKQh3JZFN20@0RF3R`FE@m$m9&(1ahLZhSFiKjb'Ri4c@iN3a!
-Q5Q'j9ST"dLMRPiYGMR$Y""KP@)#U1&f)J3R%qRDJZjm[SBZi81MN*1q@T3X8mb$
-BENG$9@9@RPd`jDciCq88Bm@,mjSB[@'hldmYKD9[iN302,mKQlkQckJkcKqGiJC
-YqR2TGXQU*j0abZdFPI4C-XRTF`4"!KF0j9cJ1SPYZ!(HS-6CCPl3T3%r1NHPHdp
-Dbj!!6[P3583J+LU*$Upl6l(0p-QV*(B11I*53A#U4fbNDN(C&eE6&i6CHPeGESY
-JmqRTr9#``["cKT23+!"H$p2V6"6d8[Kr&i5Hm9F0#epGqFpcU`H%6fBYq0N#BFZ
-Mp*rDIGGG3UVk0RA+XHqV$kQcNLmN,aILm62QDI92PmkD)D3+*p91YH@aj+`VDVI
-`KR"0mM2khLmq&$+%[`XjFj,A#MeU44lBV[jdG[,8bqUI#e1%CFN[*hrci6FI#@(
-KMp*)BGR6`UcNbmN6K"2VNVqC*ka-[Lcm,hj@#qA6K0q1&j,(#b@FYSprm1$jTmH
-0HhT`bjA"Z)%Vh30#3#J62RlkeeHq%Akp),P$k&Z``b2J8R(+3qSI6"2HIr44iAm
-III6MHfB)Sc1%jfF)Nai6PTiBk"EHQ#'X9aIf,%Zq,6PrF,m`@hhdf-(Nlb4r0IL
-QfYBXR"YmF0Vb[42DK,p-+qQa#h(6"0Ud'Lmi!"*lYlU-X4AHIf[4SLr`)r`lAKb
-j8,$L3X&bGFTJQr"EGCl`dK9K3$hcUGI9Dki)*eHG%-je#"d&2e3I6ABN[b8F&[j
-Pk@"LEh*1F[0J@IFh`X[5L'pqU-j*rQAbQm*[KG5PJc8I*KFQ$kJhFXVb-Fla`bH
-&kF)5GD2`3q%DiIM6*eF)&iA"RY@[Ulm9[K5Q$Mrjc@@Kjm,2ZSAA&kPI[0)RI(c
-0K!Hq'G-Rr13(`XAahH1lCj`I*h3[RcC&+&`jir8C*i@,mi@2IrhM%bm*&em6[Rh
-Q0d*fKr$-VrYqG+jlc(N!N!-B!!!NL!!!9lJ!N!-)!*!$)!!!2c`!"kR`!*!$#PM
-!!%U!!!"+J!#3!aTZ!*!$!AB!6R&+JfBL3Hd!)#!m2c`!!#)mUI!!!8T"CJ4+3'F
-+5%")35#!)8%!"%+R3IVrcY$m!3![##mm!!!CELm$B3!#V&52Cd"#1!TH3UF[2%4
-"9%%r2!69U"p`!4(!#Pj+RfFB6R%`2+P`TdC$qJ!U)SK"qJ!J-$bTF+C(5S0R"(!
-"6R91l3!L6R&+JfB#UI4`!%jeB!B!N!8"6R%I1[rf5KpQ%NMRi1""q[rU80"1ZJ@
-Z60m("bmkrpj1G@"b38a"4%4$69!!!`#30&"b3@e)jf$`G&#I`Lp)!#!J6b*8-@N
-!&!!B)8!!*$&m!!%!,0+4)8%!,U!#hm*-h`m'6R9+1!THC``J+J!)C``J3#!3C`B
-[1[q%6R9)jam'3IVrRR!-)LS!"-+i!aTKT'B!!6j)H[q16VS(EPK2X(Vr@QB!!3k
-K'Li)##S!3!!%C`BJH!+QS"XX+J!%+LS!#"JU!!5Ae*A8)$Vr9U%H2cJ#)'B!!1a
-86ba))$Vr4#)'`VJ$'PK"B3$r6#!krcc!Z!-D3IVr1##!5S9Q"+%LB!3J4D!RCJ!
-!Y#T))!j3J%(kr`JJJ#!kr`T4J%(kr`!JJ%*R5(S![#m95(Vr!LmkrZ)[1[lL,cV
-qbLmkrXS[1[l+B3!06M!ICb!r!%U&C`JJ6D!US#YJ"#"0S#-J6U!I)%HJ'c(I!L"
-JB#"1S"mJ4k!EFJ!5"1F*iaRN%3!"!#!#!3$J)%fJD3)!!"q!!5"0S'V9e0I83IV
-qGNU3!'F)F!'JQ(!$S*JJ659)!!K`!%cIB2K1G8cIB2KJ!2kq2`!J6U!I)%HJ'c(
-I!L$9e0I8-$J#)$(!#Q#4b#9)!!K-hf$i6R919J!!51F!1#KZ!!a(q[iU4IVq+L!
-8X**Y"#!5+)"+J'm5)&-LEJ!)SLiJ&0'6NC*`!'!%-$crf8cI(!"1ANje6PErb%M
-R(MJQ,J!)+#i!$#KZ!"""q[fk,8Mre%)ZrmLK'Le)rma96kJF-"mk!!a&!!"[A%K
-Zrq``"90&2`#S$e92,blrl+J0-"mm!!a'!!"[h%)RUCYC6bmZrq``"P0'2`#S$L!
-I,8$rm()"(`'TQb"Zrr"+N!"R%&92,`LTTM!I5-"b"-#"Cm3[,[r`UD0J["!Z!"4
-R#PP2,VJ#TL"IS"Xr2+$m6VS%KP42,8$rd%U!C`!"RLm!6VS$ePK25J"R#R!"(8!
-!&Nlk!KK)E[rN5'lri%KZrpK1ZJ9U6qm!$#!Zrq#K(Le)rp`J#'F!!@3J,[rNS4i
-Y52rS)!KR!!&8,blrj#m)6VS&Z&"2)!0Q!!#Q@8m[2%024%9#CkJI)"mY32r`5S"
-R!!#1)%!L8()Bdm%[#8kk",4B6h)$X%&QGL!0)%"`+0(!,8Mrp#*Zrr!N8A!BeF!
-Y5[ri,`T1ZJ5k@%mY32rm)'lrm+!T8%SQE[r8*dS!+&P2,blrm%kk&F`J(h,Sd)&
-4J#G!!#a96dKkrM)[,[rd5'lrr#m-,`3[,[rF,blri#mZrqK1ZJV'9%m[,[r`UD-
-NE[r8*@lrd!!-*@lrh!!3*@lri!!8*@lrk!!B2cbKQ%kk!eC86bC!2cbSRdkk!dT
-86b)!)!Z`J@B%F!"J!R!")!!P3!!F*83!)#9-!#4)H[[-2cbJr$mmS2a1ZJ,i9%m
-I!%kk&9)r2+'B6VS$$&425S"R"(!"S*JJI!!!!9S`%%M!i)"b"V#"CJa"qJ#Z)R`
-!!!-m)SJGI!!"rmJJE[r-S"Y96kJF-"mk!!a&!!"[G%KZrq``"90&2`#S$e92,bl
-rl+J0-"mm!!a'!!"[h%)RUCYC6bmZrq``"P0'2`#S$L!I,8$rm()"(`'TQe92,bl
-rm+QQ-"p)`()%`)&R##mZrr#TSQ$#*'lrm%U5Ca"96bm+UDB`(dM!FJ6!J@HU,`U
-TSf#N%#lrb"e!!"C-haai6PiJAdr[!!j1d%j@rra)j`!`3Llrr$mmS2a1ZJ)X9%m
-N3%U!Ce`[!%kk!B"B6dS!Ce!J#LC!)%![+!!-2cbJr$mmS2a1ZJ(H9%mI!%kk&$J
-J5b"S!"#J(b",)'J!'+!I)(`!!!&D-"")`1#!FJD`J@B+F!!JI!!!!c`JJ"em!!(
-rr"!Zrra-h``!6Pj1G8j@rqK)jami@8qTG5!I+J")E[rSU(3J$5"!)""bKY#",8$
-rr#"!A%K$l[rX)YJLf&P2,ca%394"2c`%eDQJ)"mS3#"!*&!b+J!)NQS!"$`"0#S
-!"T4U!!)q!MBZrr*)`cJZrqj)a*D%1!&)a*D%DJ*5Jq+$282rpMBZrr")`cJZrqa
-)a*D%1!*)a*D%DJ*5Jq+$282rp$BZrrE@36e$rrSb,[rddN)p3Iri@8p#TdKZrr4
-)HJ"QFJ%I!A)"2`&brbm"3LG#TkN6)"mQ3#m!U(-'K3#3!hJ[$#",F"$4`#m)U2C
-C6kPe)"q`K@3#B2496kPd%"pQ!Q$fF2mr!%*R)"qJ-Lm,U43[$+QM,blrk+Kc60m
-Fq%jH6R8!!J!!6PB!!%MR!$!NEJ!))!SQ3#"!)LJ!!Jb"38a"4'B@)LJ!"Jb"4%0
-08'B+-#J!#R)$X%&R"(!!B!*`!8cI$!"1ANje,`TC6cmmU'j`!4m!6VS5H#"I*%K
-C6cmmUQj`!4m!6VS5CL*I)%Uab@B'-$`#!'!%-$`%!#4I6R919J!!,`-f,J!)-!0
-)`!+!!!!)!%U!E`4`!@!#F!!Q(djH6R919[rm51FF!$BZ!!Jr!dkkrma86ae!rra
-b!E!"CK!#3`Ir6VVrJ,"$EJ4`!'!S@8mr2+LIF!%I!%kk%I!J(bS!@8mr!amZrra
-1ZK(J)"mS!,#&CJ*`!%cI!$K1ANje6PB!!%MR'$!i,J!)*'i!#L"+)"!Q3#"!-K!
--38&%CLJb+!!#$%&$8QBH0J4brlC"CaSJ+!!%FKMLU!+!!*!$rc)$5-'`J@F%F!"
-J!R!"(8!!$NcI$"K1AL"IA%p1d%j@!!"96dKZ!!K`rcm!6VVrNK!ICa)JEJ!))#J
-!"()BiUJ#3!$rB!*`rdjH6R919J!!98p)EJ!)F2mr!%kkrf33(fF3)'i!##!S!!3
-#J!$rN!0J!R$r6Pj1G8j@!!")jaJi*Qi!##KZ!!`J5c#m!`&`!#4-*)!Q2!!!!56
-ANJD5!!!#5!D5!*!$)#Jm!*!$J0Q5fC)S2!!!"*!!fC,ANYQ5"T)!N!0m"T)!!)!
-!F!!NEJ!3*)!'NJ#3!b3'NJ#3!b!'NJ#3!dJ'NJ#3!cj#3%cI("K1ANje6PErj%M
-R(cJQEJ!)+Li!$#!,+%!Y32rSF#6C`#e-rqa`)0R!,8crm(")fF!Y62rdF$lC`#!
--N!#,X)9M"R"P6[S!XN*!2J"#3$e!rq3f"h!NYN"N5(!%YN"N"(!!B!a`!$!$@B"
-U!PD!j)"i!$J$,86rq0LZrqJN4"5!)#lrq0#!d+lrm#"!-+lrj(!"&"*b!")#if$
-4E[rN8NGJX%*!2J"`!6`!0JG`(lC!C%4`!EC!C!4`!'!-F!!`!e1!DJ*5J1+!H!!
-i!be%rrcBV[rX*%38J#!Zrrc3J0#Zrr3J3$#'F!%8%R)!%J,MB0a!8NGJY%*!60m
-Fq%jH6R919[r`51FI1#4Z!!JQEJ!-1Li!%#KZ!"*#3$`!-J9`!$!"d)!d"R)!-J+
-`J@m83N!d"R)!-J,5JG+-)%%`J&*'B0T#3$`!F!)p32rb0JDf4@3!!,K#3$i!3N!
-p32r`F!!`!q@!d)SJ3#!3,8$rp$)'F!!`!G#,)%!B%(B!&J5f4f-!!))`,[rfFJ(
-!3G&Zrr"`!$!$8i!d"h)!-J+`J@mq1#lrm(B!0J3Y3rrmeS2@M#"$5P"Q%L!Zrrc
-3J0#-)%!`V[rb9'lrmM)Zrr"`!$!"d)$3M#"!-"!p32r`B"B`"G"!d%Bd,[r`FJ!
-b!Y+"dS`J36#!8NFJ,[rdiSJY32rdB!$rE&*'B!$r4%cI(2K1ANje6PErr%MR($!
-NEJ!)0Li!$#CZ!!ib!h!!-!(QJ$J!-!0b"m""1J"`!#e!rr`d"()!-J,5LL""%K"
-`!"!"0!9b!$)#iU"b!F#"dDlrr#)ZrrcMLG+,)%%b%(!!-!%Y32rm8N8`"A))X%&
-Q"N*!1J"54$)Z!"*`!$!"d)#`V[rmB`*JUK!Zrrm5,J!6dJ'3!!&-h``i6Pj1G8j
-@rra)jamJ*'i!#$JZ!!`k,J!1-J4`!$!"jS!m!$)%G!I#3Mi"GJ!f!0D+)%-3%(3
-!&!!Y3[rmF!!`!63&FJ!b!Y#"jS"b!V#"C`ab!E#"Cb"+J'FdB$)d"R)!-J*8JG+
-+)%%5%(!!%!&b%11SJDlrr$3'FJ!b!P+"dSSJ34)3F!!3!H')JDlrr#!Zrr`d"h)
-!-J,LU#e!rra`rh)J0J9d!$3$NS,LU-"Zrrj-h`6i6Pj1G8j@rpK)jami*Qi!##K
-Z!!iJ2!!!!564VJ!5)$`!!!*)dDi!%L!Z!")Y32rXFL$6VJ!5)Li!%Le"rr!N2!#
-3!i$9VJ!5*#i!%Le#rr3N5aJ5GJ!@"#e$rrMQJhS(aN953ce$rp`Q,[riiS0k!mC
-&9%-p3rrQGJ%k,[rQkf-p3rrSIN$)"h`!(!3p4[rLH!(VC&0%286ri#SZrrKq!FU
-(C`Kk!$S%8i9J!RVr28ArhRJ)286rj%T'CdB[,J!5,`!r!e*+,`T1Z[mk6qm!$ZG
-!d@lrj#mZ!")[,[r`2`-[,[rX6VS,#%r[!!i[,[rd2`-[,[rX,blrm%kkr+a2l`!
-13N!p32rB-#lrf,"Z!!aN!!%k-#lriQFk*%!r,[rS,blrp$mZrq3[#dkkrBj2l`!
--%J!J#R!!%!%p32rDG!!d!05Zrq`J3K!3FJ!5!00Zrq4J($mZrqBr,[rN,`Y1Z[h
-`8%mp32rD-#lrjY&Zrq3`,[rDX'lrhQB@-Llrf&*ZrpK`!$!"d)`J3%)3B!$rHM!
-ZrpU`E[rJCJ!!P$!Zrq*R1L4!2blrk#mZrr3r,[rN,`Y1Z[d'6qm!$")!)!T`!"!
-"28$rfR3!0!$8V[rX)%)3%()!%J$6E[rNB"`r,[rQ2blrj#m,6VVpD&"228$rfM!
-ZrqE4E[rN9QlrfM!ZrpT6E[rD5N"R!2m!1#lrf(B!0J3Y3rrm8i2@M#"$%"!L,[r
-mdS`J34#!8Qlrf'$1%#lrhG!ZrpXd,[rB8Qlrf()!-J,5M#""%)"J!2kq-Llrj(!
-!-!&HJ1D!60mFq%jH6R919[q-51FI1#CZ!!JU,J!-+'i!%#`Z!"3Y5rr)F#6A`#e
-,rq"`)0I!,8[rc(")em!Y5rrN,8crP#Bm!!!"*0HZrj3J2!!!!NM4V[q8F#$4V[q
-8+$`!N!1!fDlrP0QZrj3YE[q8rl3S2!!!"*!!fDlrP#eZrj6rZ0HZrj3YE[q8rlc
-CV[q8,@lrP2r8F(c4V[q8,@lrP2qN)$`!!)!!dDlrP#!Zrj53!)b`K@-+F'8p3!!
-S6[S'HR!!,J"#3$e!ri`NE[qNeI`!!)!!,8VrU#eZrk6rN!!YI!!!J!$rk%KZrqJ
-[,[qN)'i!*%k3!&"2)#lrk'B+F'Fp3!!S6[S'0#4Zrj!!8NUel[qSBfJJE[q3!&*
-)NHlrU#e)rr3JE[q3!*(Zrk3Y52r`)'lrU*(Zrj!!,8Mrl#!)C`iJE[q3!#*Zrk3
-J,[rXSLiNE[qNeHlrl#e+rj!!5'lrm#mZrk3JEJ!N6T!!8%mJ,[r`X+lrp'3+F'F
-p3!!S6[S&`#"Zrj!!8UlrN!!3%"e!rk"b!")!dN&636e"rp!`,[r3d%!p32r5)'i
-!(#!3d+i!)#e!rl!N3#m-,blrZ$mm!53[,[q3!%kkqr*2l`!1-J!J#R!!-!(4V[q
-3!#m-,blrY$mm!53[,[qi6VS(ZNr[!!i[,[qm2c`"*#mZrlJ[,[qd6VVjA%r[!!i
-N3#m-,blrZ$mZrp![,[q3!%kkqk"2l`!1-J!J#R!!-!(4V[q3!#m-,blrY$mZrp!
-[,[qi6VS(D%r[!!i[,[r82blrd#mZrlJ[,[qd6VVj#Nr[!!j`!#i!3N!p32q-,@i
-!)2qX)'lrV,(Zrl"N!!5S3N!p32qB$'i#52qBC!!!`M!ZriaQ!!#-*'lrN!"55VA
-ZrkKMD#"Zrj!!8NL4l[qS,8Mrp#"Zrj!!NHlrT#e)rr!JE[qSNHlrN!!Y52rX)!K
-R$L"Zrj!!)QlrT#!ZrqbL,L4Zrk69l[rX,8VrN!")E[r`,blrT#"Z!#41N!"36b!
-Zrr#`V[rdC!T`Cce!!#K1qJ4#)'lrN!"5V[q3!")3F!!3!5i!F!Jp32q--!Gb!F"
-"d@lrQ$)ZrjK`!$!"d)$3V[qm)%!`%$e!rjJJ"q+),J"6E[q-B!$r1!4Z!NMrQ!a
-Z!3$rQ'33)'lrV&+Zrk`3V[qCB!$r#!4Z!3$rQ$JZrjKf!$B%,82rq0D$eUlrc#"
-$-"!p32qD)Llrq0+ZrmJJ34)3F!!3!6e!rja+3'F!!-)-EJ!BriaL!!#B*'lrN!"
-55VAZrkKMD#"Zrj!!8NL4l[qS,8Mrp#"Zrj!!NHlrT#e)rr!JE[qSNHlrN!!Y52r
-X)!KR$L"Zrj!!)QlrT#!ZrqbL,L4Zrk69l[rX,8VrN!")E[r`,blrT#"Z!#41N!"
-36b!Zrr#`V[rdC!T`Cce!!#K1qJ-S)'lrN!"5V[q3!")3F!!3!63Zriab!$)#ikL
-1J&"ZriaJ!2pLF2pb)$JZrjaf!$B%NS2LU-"(d@lrQL!(jUJZ!*PZria#3$e!rjJ
-`,[qBX'lrdQ3!!-)`,[q-CJ!!M#4Zrj!!8NUel[qSBfJJE[q3!&*)NHlrU#e)rr3
-JE[q3!*(Zrk3Y52r`)'lrU*(Zrj!!,8Mrl#!)C`iJE[q3!#*Zrk3J,[rXSLiNE[q
-NeHlrl#e+rj!!5'lrm#mZrk3JEJ!N6T!!8%mJ,[r`X+lrp'3+F'Fp3!!S6[S#@#"
-Zrj!!8UlrN!!5%(!!%!%Z!(!)28$rM$!(FJ(!3G&ZrjJb,[qBF!!`!G#!d+lre#"
-!-"!p32qB)!ILL#i!8flrM'!!rcB`,[r5N@lrQ$JZrjKf!$B%,82rr0D$eUlrj#"
-$-"!p32qH)Llrr0+Zrq!J34)3F!!3!6e!rja+3'F!!-)-EJ!BriaL!!#B*'lrN!"
-55VAZrkKMD#"Zrj!!8NL4l[qS,8Mrp#"Zrj!!NHlrT#e)rr!JE[qSNHlrN!!Y52r
-X)!KR$L"Zrj!!)QlrT#!ZrqbL,L4Zrk69l[rX,8VrN!")E[r`,blrT#"Z!#41N!"
-36b!Zrr#`V[rdC!T`Cce!!#K1qJ&D)'lrN!"5V[q3!")3F!!3!63Zriab!$)#ikL
-1J&"ZriaJ!2pLF2pb)$JZrjaf!$B%NS2LU-"(d@lrRL!(jUJZ!*PZri`JE[qX-Ll
-rRR!!-!'4`#e)rj5alJ!JC@!JE[q88UlrP"!3)'lrV&+Zrk`3J#"Zrj45V[q8%"!
-JE[qX8UlrV"#!)'lrP&+Zrj33%#"Zrka5V[qX%)!`,[qD8flrQNT!C`$lhL"Zrj4
-5V[q8%"!JE[qX8UlrV"#!B0a@E[qD)'i!'0('-LlrRR!!-!%LE[qXNqi!)*!!LC(
-!,8MrP$!ZrjTR*L"Z!"M4aV(Zrj4M'L"Zrj45V[q8%"!JE[qX8UlrV"#!8flrQQ$
-8,@i!)2q8-#lrQP0ZrjT+3'F!qfBJE[q88UlrP"!3)'lrV&+Zrk`3J'$F)'lrV,(
-Zrl"R#("R28!!+'!8)'lrV*(Z!#!LEJ!F)SK#3$e!!#K-haci6PiJAdr[!#"1d!"
-`2!!q)!!!H#!q-#!Q*L"i)$`p-c)!!$T$Efe`FQ9cFfP[EMT%C@0[EA"bCA0cD@p
-Z-$-`-5jM!!!m!$iJ!!"i)$i`)#BQ)(JJ2$dc-J!!1N0[EA"bCA0cD@pZ1N4PBfp
-YF(*PFh0TEfi`-c!a,Q-!!%j@rqK)jami2Li!##KZ!!`f,J!+F!!`!cJ(FJ!b"*!
-!JA)"X)&[!!'d286rk$e$rqT5E[rS-#lrk,"Z!!TN(()!-J$5M#""%"!d"h)!-J,
-5M#""%K#`!@3#B0C6E[rU-#lrkV"(Baab!$)!dS`J34!30!Gb!$)#dS`J34)3X!&
-M!Q$B-#lrk,"ZrqTP!Q"b1#lrk(B!0J3Y3rr`eS`N3a)5F!!3!6e!rq`k,[rUH!!
-i"5e%rr6BM#C%%"-8J"DZrqdJ,[r`d)$3VJ!3)%!`%$e!rq`L,[rddS(5VJ!3)%%
-b%#3Zrr$8JY5Z!"!J3M#")Llrp0+"dUi!%#""-)"J!2mb-#lrkV"(CJC54f!!r`3
-i"hB!0J3Y3rrieS`N3a)5F!!3!6e!rq`m,[rUHJ!k"Le&rrcDM#C&%"-8J"DZrqd
-J,[rid)$3VJ!3)%!`%$e!rq`L,[rmdS(5VJ!3)%%b%#3ZrrM8JY5Z!"!J3M#")Ll
-rr0+"dUi!%#""-)!J,[rm)Llrq*!!J63Z!!Tb!$)#*#lrr&+#NS+`J@`H,bi!%#m
--2`Br"%kkrPa2l`!--#lrkP*!2J"J!2jF,bi!%#m-2bi!#M!ZrqT53$m!6VVq0Nr
-[!!`pE[rU!!TJ!2ii60mFq%jH6R919[rN51FI1#4Z!!Jk,J!-*Qi!$LKZ!")Y62r
-`)$`!!!%NfF!Y62rd3N!m!$B'YN9N,(J!1!-Y42rif)SJ4"!3)Llrq0+Zrr!J34#
-!)#lrq0#!d+lrp#"!-)054Q$1,blrp#mZrr!r"8*R6VVpXNr[!!a#3$`!0JDf4@3
-5F!!`!p#Zrr!J3%S3CJ454Q$SF!!Y32rN0JDf4@3!!+K+3fFb)#lrj(J!1!-Y42r
-mf+lrm#"%&""b!")#*Llrr&1$eUlrm#"$&K"d!"3$NS,MU#e!rq3d"R)!-J,5V[r
-`)%%5%(!!%!%q!#eZrq6rl(!!,8$rk$!(8dG+3'FJ)#lrk11))Llrl(3"`S+!J5e
-!rqJJ,[rXiSJY32rXB0Jd"R)!-J,5JG+Zrr3J36)3F!!`!H@!d)XJ3##ZrqK54P+
-Zrq4J!2p860mFq%jH6R8LAb"IS#8ZJ'S#3TG1d5*I%Km`(dS"C`5R4Q!#SdBZL%l
-4)Pm5(c!I)&p+!@F%TNGJ!U*(6Y%!N!-+!$LJ!3!&!*!'!3!!!C!!Y`!"MlF!!!4
-B"Y-he!0D!*!$(!1q!"0%594-!!d!SN&-8P3!#J&+8e45)!!"!Fj3Ff9d!!!"jN4
--6dF!!J(b8e45)`!!!KC35808!!!#)RCPFR-!!3)ZBfPMEJ!!!NC*3dp1!!!#8NP
-$6L-!"!*H4P*&4J!%!TT#6N4-!!%#eN&9Fc)!!!,ZBA9cG!!"![TTBf`i!!!$%N0
-24%8!"`-H4%&833!!!hj659T&!!!$LNCPBA3!!!1@"!(rrb!!N!L&rrmN!!#!"Y-
-h"!#(rrm!N!2@!*!&K[rr*!!"*JE60``!J2rr!!!"T`#3"EArrb!!!J8!N!@#rrm
-!!!*h!*!%!qMrrb!!!Y8!N!@)rrm!!!-"!*!%!J$rr`!!!pN!N!3#!Irr!!!%&`#
-3"!4,!#J%!"5!"Y-h*!5[rrm!!"63!*!%!3F!0#!!&3i!N!3%!Irr)!!%B`#3"B,
-rrb!!"(-!N!@&rrmN!!5$"Y-h#!#(rrmJ!!56!*!&K[rr*!!%S`E60bJ!J2rr)!!
-%X`#3"B(rrb!!"--!N!@)rrmJ!!66!*!%!J$rrb!!"18!N!3#!Irr)!!%p3#3"!5
-[rrm!!"@m!*!%!J#3!b!!"38!N!3#!3!()!!&&3#3"B$rr`!!"5%!N!3$k2rr)!!
-*@!#3"!4,!"!%!"+U"Y-h&!%(!"`J!",$!*!&J2rr!!!*G!#3"!2Srrm!!!Qd!*!
-&![rr)!!5HJ#3"3(rrb!!%TJ!N!3%5rrr"!!5h`E60aJ%5rrr"!!8"3E60a`!J2r
-r!!!9c!#3"B(rr`!!&Y!!N!@#rrm!!"I8!*!&Jrrr!!!Bf!#3"B6rr`!!'G`!N!@
-!rrm!!"VJ!*!&JIrr!!!Dk`#3"B,rr`!!'[B!N!@$rrm!!"X"!*!&K2rr!!!E$!#
-3"!%!rrm!!"XA!*!&J2rr!!!E0`#3"d!!!"Y[!*!&K2rr!!!EN`#3"dm!!"ZA!*!
-&K2rr!!!EmJ#3"3%!AK`!(rB'dcFJ!!)!D"`!NEm'dcG!!!-!FK`!VG3'dcFX!!3
-!I"`!p8)'dcF`!!8!KK`"*Xm'dcFd!!B!N!!F!8RZ"Y-h2!!!rrmS!A80!*!&"rr
-r!!&e0`#3"[rr+!"KZ!#3"2q3"!!"G5N!N!Err`!"MkN!N!3'F(*[EA"d#-3JFh9
-QCQPi#dPZFf9bG#"%DA0V#d9iDA0dD@jR)&"A#dPZFf9bG#"%DA0V#d9iDA0dD@j
-R)&"A$NphEQ9b)(*PFfpeFQ0P$NphEQ9b)(*PFfpeFQ0P#90PCfePER3J-3P6C@G
-YC@jd)$)*8f9RE@9ZG#!c#90PCfePER3J03P6C@GYC@jd)$B*8f9RE@9ZG#!f[f3:
+2rrri$rrrq!!!!3!(rri!#!#$!!Z"!S!)3J*!#B3#)!K)!K!,N!!$q!JJ!!J)3!!
+)#)!!#!N!!!J+!!!)$!!!#!J!!!J)!IJ)#!2m#!J($!J)"Rr)#!DJL!J-S)J)$!'
+)#!d"L!JCI3J)'8F)#"Rr#!JF-!J)$rJ)#!"J#!J"X!J)!!!)#!!!#!rrrrJ(rri
+!$rrr!!rrri!2rrr!$rrri!rrrr!2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrr
+i$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrr
+i$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!!!!3!(rri!#!#$!!Z"!S!+3J*
+!#N3#)!T)!K!+8!2i##!!#!K!!!J)J!!)#3!!#!S!!!J-!!!)#!!!#!J"q!J)!r`
+)#!F-#!J'ImJ)"U#)#!bJL!J-!BJ)$3')#"Pp#!JC4`J)'Im)#"``#!J2q!J)!'!
+)#!'`#!J!!!J)!!!)$rrrq!IrrJ!2rrm!$rrrJ!rrrm!2rrrJ$rrrm!rrrrJ2rrr
+i$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrr
+i$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrri$rrrq!rrrrJ2rrr
+i!!!"!*!$J!!!!8!!!!)J!!!%N!!!!!R)!!!6j!!!)!)!!%!"!!#(i)!"$r"!!K`
+`)!3Cra!)'SS)%M++*#BbmM*10!Bj*QAd-K*P)Cr`)"($!%!)ri#!"!B"!!)E
+!J!"!!3!!)!)!!"2N!!!*b!!!"*!!!!!#)!!!!8!!N!1!!*!(J!!!!F!!!!2J!!!
+(m!!!$rJ!!"rm!!!rrJ!!Irm!!2rrJ!(rrm!$rrrJ"rrrm!rrrrJIrrrm2rrrrRr
+rN!-rrrrq(rrrr!rrrrJ(rrr`!rrri!(rrm!!rrq!!(rr!!!rrJ!!(r`!!!ri!!!
+(m!!!!q!!!!(!!*!$J!#3#!G"8&"-!*!'"e0PCc)!!3#3"!G6C@Fc!!*r!*!$"e0
+PCdi!!rm!N!-(39"36!#3"KaKGA0d!*!$!8P$6L-!N!@%4P*&4J#3"B3!N!-d399
+c-J#3!`&*3diM!!-!N!1!!!%!J3!#!))!!`#$4P*&4J!$!*!$J!!"!)%!!J##!!-
+!J`#3!b!IU5!a16N`,6Ni)%&XB@4ND@iJ8hPcG'9YFb`J5@jM,J#3"eG"4%05!`!
+"!3e6!Yc@"T2hdNE0440Y!,6j0bkmfddECX*X[UX,hi6GX0[NhAE9eA9K!!NiTBM
+rG!Ak'M5Q0Klla*eVf8k#LE$6%2V!XqJ!D*!!aElq",i'!!!%!*!4J3#3(S%!r`#
+3()%!9#[r!*!DJ3"8re3Vr`#3')%!92q3!e3Vr`#3&S%!92q3"93Vr`#3&)%!pID
+3!e6fN!3Vr`#3%S%!pID3"2MfN!8Vr`#3%)%!pIEfJC!'9[IfpL[r!*!1J3$ep[E
+prj!'r&EfN!-Vr`#3$)%!pIEf9[prpj!%JIrhpT!%+rm!N!U"!2AfN!2mrIG@Ij!
+&Uj!$IrEf+rm!N!L"!&6fN!6rIrCr+Rm!N!089(p@+rC8+rm!N!D"!&6rpT!$9[r
+iphmUI`#3!e48UrFVp[p8+rm!N!5"!&6rrrD3!rcppeC8+P53"AqVprEfrrp8+rm
+!!)%!92q3!e6ip[prpRmUN!989(prprK8rj!$92Mr!!$r+e6rrrEf9[rhphmUJC!
+%V&5V9[D3!rrr92Mr!*!%rbY8rrEfr2hf9UXUJID3!i&rrrIfN!2r92Mr!*!'rbY
+8p[EprIG@Uk[rN!CrprD3!e6ir`#3#2mVp[C@rRrhN!6rJIH3"2D3!rIir`#3#[m
+Vp[C@rIq3"S(fN!Ahq2m!N!cr+rD3"[q"pj!$pT!$prMr!*!1rb[fN!2rrrMrrrM
+fN!2hq2m!N"$r+rD3!rIhq2H3!rEhq2m!N",r+rD3"&6fN!2hq2m!N"6r+e6rN!9
+8q2m!N"Er+e6rN!08q2m!N"Mr+e6r92Mr!*!DrbY8q2m!N"crq2m!N"lr!*!a3Ej
+"4%05!`#)P""9$@99%3!K9Hj'RckIP9+A1THPQ3[p@HHXJkd919ilR0"ecjZZ,P[
+Y"Nk#VV#Y"GcclQX-A$KHA-'"#b!1j!a($*R6`fd),X3[m6M2QjaRL1F40-C6ipF
+JAjmh-ES33mJFfrVqqr`qEAmG!b'AerIr14e@0K)4!J'3""%"N!-43Ji!A32IQ[E
+j"hUL-`Km2d5"rJbZdI4iYUQE[`3Tm6XAhiZ&e28rqjHmNSQ(K@lSkfQ#6r`iVi5
+1%R'3!"ppNiMDBVVe&PPM2LpJ(+*"mm&3LHU40Ie0Ta2I!E(6NmKV1Sd&"12cP@Q
+J+GX')Y9EJeDr$H6H,`GrpKGRmP13!#bEXSf"1qIEaTUh[$@iaYbd'mYIm@8%bje
+mf8Q[*dT#jjHGTGF6*F&@[Y`*SR$2XV1Gr`B3[)iqlT-J)#BF!mrN18-Q*db"*Xq
+Iq-$d9ZHrJBj8$b*c9I013I3G00mrlfl2%H2BSK"2V[aQr(XLJ*m3IS+Y18,qdhm
+2IfTqeKB%XFVLV!J0LIqCqZ[NN!"M++XipJ#IGMNVq'*Ia'@Zre0pE#iIbXiNQ11
+4SC&2Ba+$fJQ#RIM'!GA82c-"bfc"+$+J6QE-GGQH%Vl1l5")aN45M)YY`T4rCDT
+3TH)rIjhk+cA-f04IfF3j$*[aXfAd#Ne&V[$T8Iedj)V%bPk-l4X6hfMqFD3[fLH
+#H8,PN@r2lqBNJi0@pqIGL4`4AIQImFqaqFqaqFp&X11(k5,@e[)$GB"[2AT(3"d
+`@mceeeYLZT9(L*@rFMQMYKmqBGlUiUmUp-GEIrM%PDe(j4`8,PBaG9H$6N`HFKc
++EC!!qr1l1q*%0'hYYpjL69*@L-TL(@Jkc3ET@%K,bNjT*8+Ta0chAIBL3ZcDBCm
+eU4edkBrm4iR3f818(5LU1JkJXC(AY0Z",GUp@%D3!-QBE2[,'f+d'b4Jr)GXZ4,
+jimk$3im+-C9HAbM8cpIjYh3HK-S#%2[#D,IjrSdE6ldY2$!)Mcc3&(-QCGFq%-%
+lDdBrd"3Rlp8(*jUN!'8I"PX@-MqJFJ0Vl#C(elVC6UrXUXk3!0qXrNM1PM@b[rS
+8b2jq'c(081e*Q1rD,,#CSSebGZ)lIp`X[#!lKa,q@25H[Ce!m)r0)U6jkFYc9-m
+i%*3SNq61qEJX3iP5fer+bKaGJ3&RU&R&Yd(&F5QbFT,BJ$pkMJ6C$d4"`"Hq[*5
+,FpMPSG@fiFhr)"DKJN',eRi%H8ePa*Uh#2'5&M&XV3-&8hmBJZH9#,CQpr`'&F(
+"MV5eAJUqL*41(T!!Ye"%5B'E)JT"'T%IQeS6D6,Z'e1TV-L!N!#4!G&CFk+l0Dr
+*+#IY6e*dQqqhLI43jrD%L#AE!S,)fp(1Jkh#E(VrXrD!HHLpqZZ(c#D6UIkcZ8H
+PPf&(*V4(!LD6f@3IRi@QRYRPp&Nqf`3KYL!Yj*!!a,5*[c5EfJ-ThlMqk&f@KQF
+c[6A24N)[raKECdbGMkT8*4iL`eQ$P+dBX#'Uae4&&M'aa5qU"kT6cAR0KjYbQiU
+XL"b9LM)SQPZDEFeh)j2M[jSdeE1UCmPMaT5F9'6)&0kj1&%h5pM(UB+HY$Kpq!R
+&r'5FcA0L845jkTK2'QUc$1CEJf[bQMjX["HIDBdR1aGrZaJN[+MT,6$@)C0`ciP
+ZBf!#i(Cec9-!YKY2I*UVqRVMT$aQ2b2,qNXG,V[I'+S('8qILIHTUc%#TYb-P&8
+b[5b2R8R2X)Fa"5Sar9hRiZ+06qeG+aV(q'IT8hY9UXE$TVc'[UIfLQLMUA2aVXe
+!r$Pc@NKJ-3F(c-JDbPY5KjqUcKNrZ-B@0beZRR[iZG#8,GlRHXV9I,dTVrNQ)SR
+JCbj8r%AR$2-e!hXRqU$NqDC&UNI`8if+HE2U4E"8dmqq-9Y&mkm03lqkqGGJDac
+)Dbj9,F*N)reSfGL3!0MB%#3*[d%%$Eemq!*q[Y#bIS'Ipl5XmpR3hrcV8r9pBPM
+B"TUIT!`9LiA!&@GSIq"8Yh*ML+VVejLE(cG1VA%eEm@f2h3%l5d6$cGrBE69aU$
+JBFFLeH010CN"-ZkRc'NLp-CIJXK+ACF#a4QbNRCC+4X*3"G3++%XAh0HifMcaeD
+H05Q5c8p6&U*))ZTf96q9X0!,9202'l*F$-6r,MK*c)mX4C!!RSH#a!'5QR2%pUU
+jITZ`V4&HFhh0XEDpILTGIA12a6E4UalpUpF5BZ02k9rT6qq`E$eL`f5Vf(L&rT9
+HZGkb&5$R(DrC!V2S3-KFVh0KiF2"bp[%aU[dVr6UcCDYafcZbJFI1AVcj8fSUZI
+fr6fUeEmI&#'EEfi["Vj`JMePK!+)DHXq#fAiQkYEN6f()YP4r9&lT!Y)cTpFLL[
+Rh5C#B`00(jVIfc(30-hmfI*MBelcHmZ2E3YSd6Lbp9K+mZBMK`HDlMCr(fac`IE
+DBEIjqmYIk`PXr)$qPAl`q*'YVmdk"P6kj-J03!bIXd#YE'i[Rr"aC2T(fq6)2Te
+SDDiHb1ECpiA9$XS1Skbli4S!GJ10NdkG,N,CeL)*iY9!I8PmQdMZfbD3!$d0%M)
+b5#R#'QqAXf1kpKE''#4'H3JjIdQ)$f0Yr[rPl(BcYYdKhfj3%,)NNi654&YNY,*
+kb-$-+&LX,848PKd`eb3+B1e"Dj!!MU!UQG&UTL@Kd(aX9T`ZX3AEiq8bAe8`[hB
+Gc#F9c)G@CeBp3`EHG%CKjXr`c14F9A(car5aMUN+9B90c5KiJb,Bp%eT8UL&ZUN
+"L`$!d'rUK9('+*'-@mRF35i'10l5,Tkf109'rh5,A8De@8'C0mlKRpmR3RBHr2C
+jLG#YfUrTMZ8EJp04A"[GB'k$Se*)bM*Y&bQh)%[&4krYQkcVpRNCQS@%D[2(&2@
+b*US$0Ia@*jVS3QfVNX3@ZSb"%pdaRRdEp5M93eQAD#KAQ2p"$NET'[G*QqfTN!!
+%8(D++2lTk'G0T2(m'P5JM9Pb8Q14A@XdMFBe!0XEdf2Ym4ia!X80Bc&P68*p&A,
+HiQ%dCR4L&-fjaF8k4,ID-E$N8AY#$MSpRdY9N6T@J8,%L*rcB*)eh36+0cV$)K"
+439-5-+XYR+&,8j%E%La6D"Pb#TKki0$Q80mc"`(A@+-6'0&FQKqMkV2YJU(l
+$iA'C-Uj"dNrLF!81Z0%mAIcSq9Q#60-q5ch3I(1+'P'NYJidPe,60H#I*D$%m92
+G8+UEXQaq8@@,+iBMXq+f)$+P&0RMFClj$NHPj*l!hX"6JmdhVHPV,ReU#!Ac`dY
++8$$2j8Aa@Pi8#c&2HqhT$P`,T#MEIVV$FU,EZ9FDLP*8BL9mX2K4)l+$[$3"0ip
+LMSaKiV)YcT9Ilk!YUCe()i0ld%*3l3eMQeRTf1kPF@5Qj1pcdp%p)M)ifSe$CPZ
+CZ4i!5V&#JAaVT-!d`4#Yi)LD'++$P4!GD%b`5cVCTGUT9cIDiPe#3TH3!,9j`jd
+-aX95TNDUYNPPY922,@iZYEI-b'Yqh"iP!)"8f[a&p5qXAN,qd65+,+H(,X+959Y
+FqF+q@AQ"P8c!r`T-#0R4MA!dJN'*6E,$q%TY6''+kb4'Q*ZDf16EUcpkC9,)+2!
+3`#U+AmN@VEm!)Q*!%[$+AZ2aJeQL#i)5*+Kp09'mQ*e#F2%daGZcjAA1VR)%9h2
+"ZH*(@X'%+"-,jJiiThbT&%qQhDV2V1VKJCXUp3!82YBre2QmPCQVDMp9p64p)69
+VNhBkKZNJQql56MX`lC@QcaK%E-+dQddE4+c%Y)p0'd43"QD9)A!3H,[rCUNa$l*
+P)CBI[$8)%Q-KJ(ebij!!Df1ca,iK-F8"N!"d!1kl#akJkPFCE'A(8'N"XTl9,4&
+,EFpH!I!VLTm@%2L'*dS,(S"Sf6J&!NNV`#""!-mXiI6CJM&!(A*2`@BU9YA#$QF
+"6(AK5#'1m1-JMYP-ZDTaIR#YiQ!,J%"CC3&"Ta9A%@Li!!GUHA9l'4YYIbHlS-5
+4@e!#0p'Ya-,%,S#iC5$'e82NCH1lY6&Fm3NQUP$dp+LUT1-&+HDd!"TFqkEM5"d
+jQNQ&#hc2!NdMlf3A&G+bqCZ1h+*#bPJ#-6-0lQ4MTXkqYUCE`&$d$VP[(3"j29"
+8P#F#VXrCDf4,(B#M@MB%lq@ZK-1S,2DL'BP2UfBJSUU+0T*j#,rGSh0S,YZf%EM
+e4&e+mSl,GeL3!&@q-qD4(CSk)XbMmDCr@AH(46H"V4AEm#2lRkL$`*hF[E!%"*'
+[k2V"51mJTNX)K'K#d5iRRHRYNBjAiG+QfJqRQbjF&4ZKCQ6$EF*VMh)(00AK6C[
+m-ArqPFM3p,kFV3i`1pY*(#'jVi`*QYTA"[8Be"FLTFaBT,)i@q#UjmU+iZ+kK1E
+j3aNSb2)AU8SLK#C3"+'aZ!'99ij3hFX9d3%aHjZr"!0PB"pSb#dUbK&&j14CClK
+JHmQqRU,#jRRF841LUjqhp458K)%r343iU2lfX@UVFdEdLePaK4Rl*8FPU`5)4%h
+[aMQC),P&cF$XNLH*U'4D9!LRJE5!j*B)-NmJ6iJV"(M[mcCpJd"mS&9#6SRmCBb
+l)jEX#cC9Y'CENf!X-ZF@f[#cUENTZSM!-9@*[4eQmCUU+-q2a5998BikQZXHa%3
+&&ML5kq11L&i!4Sl)N!$KLZQZR1T)Ri6+FbkSl)!*&6Nf1V#NcMU`T-UFYPC0fk!
+U(f3m&cCpNk(U'HefmZ$PEM!YAR+9Q'j!-dbBhN"$626K`#JBeI6#e#3b!&`1,,P
+U(9JmM'Qr`m8V,[q"J$&MM@[*eA*H4qh#hF'Q2&b-,[!5`)j6('##Fk46*T!!&Dp
+G$[%Q'NbIZTBm5S$)#6eL(SFE4-M,TlVT1)c8CFllGc34NkJBM4NA&rple4T-,,N
+bi#Vd'TJ)A)2B'894j9EY`VY!)5LhN!!UeH@G-pDqASNYl5Qm@,),Ri@0D9'%db8
+,R49SU'TL`R[#U&VM!JU,(kfC+&kV(J+BJ!+ZDkfDLMKclRB["cmY3(%D$F(Ba5[
+D-H(Pdmra+RAaSfSflHE6Y@cDRbED[B4Lp$`!eY0FK3QJGKlS8P3BL4'$df#f(!J
+3!`*bd`("Ab#Uk89d3(LAP'Lk8`H"fX#5NMFY"-`3H@+SY2$[MGlU(J4LEq%QU,+
+1M"""-qN3QQjl#kDZ5P1&a66Pp(i1!45`*dFMmVka8)#D$-5#CJ+Z`J8pKCY5iXX
+YdP804c6G18PM[!E6L%T#GC1dY@+0TPXK52#Q4f6SiFB$2&Y!e2E!FCj8dS*$T*`
+pq$Q+J`dF2"UfFc,bNNG4a0qd"UqA($$R)M##Q4#C+#hF4-!DSZbSRP43k-G29#)
+9G1f0jTRkQSXJDXSjc%NP82[AG**3!)dLC$'U'Q"1@@C#XcI01%N1fkhC01`mQ$G
+)`hBUe04b4+HqCP&KG,+U,GIP,B5,)+V%bAf%#-b()UpG*hE(pLUMc3&6ccQ(+Ue
+flU+L&qE5F8YEVK#&d@Z3!-e4X!c6cee,bp-)'#ke!+$[!KP[LJP)bqmQ!k8,i-V
+@8h#&JSp,f*1FL-PI++r+rFVa,+U3!%A2SCK+A5TlDl"Skk(VV%)#k-T+p9&MHJY
+NU8ZN%Lm+ZQH'$5S*j$Tkl6&5-B,e(K3R4`RmjX%kD8q%[CLaXj1QPB%SB10&d&&
+LdNFTJYU*m+!@5*+DH!&3E!8J@V`&PmLpTB@M*kkJQ5A%HijHTmmdm2BV-@iB!&8
+3hB6NfkpSZM(`*+#q1k!q9(5"e43iSN56U@JZ98+a&@e-&lkaVqd2hjM6cma3Bqd
+TD,$f&-dXjiSjC,"@,fd+SQe`!+H'9BXqLR5#4a*DLhc,a+6,afD+0aX+*j!!mBT
+XF5TN81biZ!#*`2GDji`Y(i,!*`cZJ0aCPS18aN"l4m"Arkc6(qd3UZ!KZm2Sae$
+Yk3MP4EfS[*ILilC[`ZZb8*CcQp'QCDkbVc4kLAQi)r#pD"$-&ILilI5k,($DMZb
+@Ya--L51G-rj3HU*E8J@2M)6Ne!c`N6GGj6M-+54h@dAe*ClC(1fFkdJ,AEdYB4X
+609m1*XaB!,$mj4bRQV+j!2b[VDlC"r)*$ZH!q!bc6TKM[Z#Vkj!!hJ9$p9EAT-Z
+8$`*diBj24!J*HKEGXeG9"2GPDNU[GCSF!&jbjAX)[!raUfch8-)L$0BPcV9L%"+
+Kf,MT!Mm5!M1U,8al-Hh$)LK#H1Q0GSP3`*UE9(F&V"(AUbj4aS99q,Z%Geh#kAZ
+9K2UMDIY8SDXRTH&DG9GS*E)B[VF$"Ab$r1D2NDNkFFq%5$Uk3KG[ml4d"ECM$pq
+)J[KJ6`,aQemp,mV%,IHNKG5L`T%@h*AAKkXVF(c-j!5CZ9$Z[L%YQ5mm4RpYc0j
+k`hRih3hAPYP(hMJ[6J[E'hYl)rfhLh&M!+pppj`(IE%##MiJpbIJP(hiNrZU1Zm
+LNk"#9FU'SfAeBTi49`%AbbL)YM#94&fX(GPUXfaMpld-9m[Sl2P1Rf1qXb@fDkK
+%b(qFLma&BV0`Y`%eZ3aS2ZLF#rC)V(4rCXSC90ka[11Tjl()122l-rZaU#150KE
+,lFD$F!i3#rkI$*N@QfmlQB&&B14iHYCY@*MbmSJKN!#4FMb2&R9C@0pJ6%F
+6L'+M0hT"(%35X*ESKG"q!,lHL#[Q8hG&IhQ#-Y0M)0Pd"8jMZCXUB)Sb$"b)4'r
+!kZaLNEC*lRi'KHAAhVApX-FFGF8pcZ'SDjr(UFDRbeQ"U5ki6)KB"Dj0'Q%1aL#
+C-N3*+D*cak9'8#YAjC,J@i05KI9#RGf()b,Qiqk$P&%q66)'-C``YhLFSZL1fF+
+qkq+2C6pHcZE'l#[cZ[eVi6,-c@-ic$cmC"i!MFV!AL@CBKk4D,UL2i[L4QF8Rf#
+HGp)P)9J88b*'M61j+q"rS3j*R6j!)"eZqN#1JfhTljD0M'!B4DBK9+2fQ&hU(cL
+X5%KAJBr2kAea,+DZ(SY&TH'b-4`C5`,&1%a&(pc4J*`QGlq"*U"SZB'Da3$ma!K
+q2J8B1@iFUBj&ADTTpP#e)%2Ed53m-,3@jTU5e![!86q5`m!T!T0i13SMI2Qc@%M
+cQIB#[j!!Ek!'Y`H#SQqm,&T0jm8fA0,M#0LpeD&BU$T)SZPeSJR14IFQT#X36&6
+eA%55SqJA`p@r!'X&XCciJ$-dF)B@cU#@YP$YY`rML[(UU,eLD$1FDdS46"D*D28
+Yle#L-8Pm"6mq,9`m2lkfdKA5*U2Bj+hdLJFk++KF&Sq#T@FePJVKiBcEZ&*kU[Z
+NJ*ZJJ%[4k89'V4rNrP)%C56HJ&R%Hp!-3f)cS9E([1V0)S$LYF5NCZbDjXGJ!0j
+%(BTP2mr33l(#!,MRb4@NZCU8DVT9MMX6P)PSmm"phHmFRZdk#8H-b3QR6qfjUck
+f5kf1Z+Tlp%8)%,lE'S4ENeVe1"VDGpG1c4)J*d6K[,q9*`C"4T+0SS`hb"6QG$F
+19DJHI`I-UUdBq&@&A-![9M1F+QX3E-1UH@"V8Eh!$hk&aZb#(p(Khh#RM@SFVM+
+1%0Q!VXAeMr"V2GTVe4XQV$CjAD*35BYhb+PZ(T&"39KiJDZ"Lq-L8',CGG`*84+
+*-X$Z'D#,Q[L'Ak4$r08Y5(cJa58M)**jf$8Y#S5R1-*UIN98p4AIV%qr@DMi"Bl
+LX"C&+4PEe6YdD"irp!+rdS$FfYA9[!VfL3eL0kh'I[Fla,+9)YJBUSeTJhqhhS$
+i*VGbC6h!)i%ENl'-E9*Y)dGe5MK%L45N6@mZGp-2)D%UC3-N3BLV!!Qc4Cr`,ZV
+bLEaC9-6H15JPpfSDN4*HPA`K*IILT%Xhb'IViT3Y-@+,NpNL!G#F[5VP+dUUL!E
+@#l2LpLJ4(fLi26%V$QFNIh4)p4-3PDqFNT,&PC*V**TH0i-jR61AkM-iT+`L93L
+[6K-lA3$@cCJ!)[+kkP0@*)@M#j[I(`2aY[RY@I(S)Y5Q)9@aIBSIJ6L@+'&f9ca
+@SCr%PRCe!4elD"B)L$Im*4Qcq@JV!$$6`S,J3d6ii!NiT%3RkM"PGB3Tke0*@Bm
+ZCmU+5JTTqK3JIEeH2DCh*H88cPFUTm3(e)G8Il+hD"RISUCmi5HN02Z"F'9YEm"
+KHhR++VJ@VpS-bYS1!ACN1M6rE0AUfEi`A$f2AK1Z(JR`0TJV,aBj+DRNG6J#m!b
+-BmBGU@I58i58r*!!#Qdb4mR4,$,a`Udm5Gf),6!j!FFap5rpI#)T6GLh'!-+8V%
+K%GcN8R@NGjBl1L3#@A4JE,p`p1CX5K1YNhpkIr3+-Jf*M&[$QqdmDdPZ&$iXTV"
+!SQBN%P0IB`'jVMG['S(UiiVQ3p4$f648S"m3)e0GlNeH4ep1*,T*p-M#2UKfei3
+LSX@5&QK[ZhCQj&+XeGEAkRpeL8T9*dCZ30k6@ac2M1*ci+62H`15iiR)T8JI+TC
+EGhM0Rmffj-c&pEj*8qiLZYKMdermHEFjlh@3!%!QqdFcNF93MkV%CeVmHNPX%e3
+km(S*A,X3m92hbR&lLc3P%H0q-4HJM9UD`X%518l(H,0paqM[ZH1DPYMZ`#YNCc(
+Q(hVNZ2EJ6$P1%3I(0BQ`9dY*$PPfP4V0UDRpd[&@kBL9CcQ@E)@B&PhFAY'qU'4
+ckk+5Kl!jN!#Rj#L)9#"$PY35)`K266`Lf[3'b9r4L`k@f40Y4q(8ZNK9[$m3FfM
+Cm[jp)@Ic-MDEJUfe-P["ii`YD@"6"`d*'C(5%4XNm0iSSNIhi6pl0(U%,bJ4kXV
+SdG(Hr&'Dc-JjFja2*Ke(l6l(%53L$HLc!8a1kjJp*bY$#PCIHp'4r@Bp*C2hpj!
+!Fm[ZcqS$I3**3lRKAq`I1Q@Hf0dlf0rC0pMGeYFEi5krA-MaV!YRQ*!!f+U%[-5
+%6,6e6daqCk*ciUaH$!8LJ&&HYR#cKBm[cNZ"c#M3U855[DTJVcVCK)DbaSNdM+J
+m,b)`!TZ8(5qL%j[&FM4pfSeZq8CUCYSZ8XA#QMkSH1VkKb+6Sa1485&'2%-TQFI
+6-qA8R&cl"HI"P12Tm(#@MjpC5QJ@@FZ`A9iJq,BKLDYhcl4Bb(5@XZFJ-0U$#SM
+!UGHi`'i0hpT9UU6JPP'5Z'C($9aU5e$C3e@U,b3!iaddDe@0))rPJM@E-MX1@bK
+a1JQ8a&hH$AAeN!0(*M@p3lcB89faPN&X4CMB@Llf%lVZ"'88,1$J9"-AI9N[qR$
+FILm$C@TTm3B+@K	(P9ME[V%b$`6aKR`qPmpfF@0"Mf"')fFX8Y'X&Qfk@Y8c#
+&b%[iZ@+-0Mer1,klhY+MZJ4h`S!cY#I`cPR4dX-ViXF,U4$pk@$h+4K-IeX[4ae
+Cmf8F+03M,dZ&NrT%hG"[4F6i$5Q+10SPHQ8MDc2lcHrhPDR,l$el!h5%6%0LfZH
+6Q)VZ)l9e)+["''Jij,c*FBL1r1JX9ACL)d-)P4hbSbFkpIE,Lh"Z1"@d-ISaC"k
+S%`2C%[!LE38")%,'2p6G1GKr9VZPqmch"kJ3pj1U#Pq(UPCDaiMqEB8E@+DGK&U
+MjLb"KKfT+kB$@4K*ekQDkja41JG4-QabSMSUP0M`iVl1'EYf(Bj$PG'f[kJYK!*
+)5(1[dZdDj1FSd&FY3kBF[ji5Lqi421K4`ZX@%%dd&2J3+G-FVr%A+aep6hq'TY1
+8Sfrh6%I)@G%HII-IhJmH$99QHj-1$L0TUMU*aQYp!00qq!"9%*YT8-rih1#pR0(
+dPXhh@5(FI0,*@E'JSLG1bB8GV`(iqF)dD(+$XEl&,BPbfRLNYKL1B-2,F1b"NEJ
+d5DjY3h$[P@qdAB5JQ@Sh06paB4G38$Yhm'Kr"K&qM#+m4pKP554ca5"KmdELA%`
+Th2SJ4K,"0j!!3&"j#"Q"8,kULG3%TYG42-$`%YH3!1%G#+MGGPm2("B,lX8@e0`
+i@L6"&A8pFDlDebJVieB3Y!E18SF4kQ*Q*!!ljm0)c[CfpNBQfLVE#NAA,KL,4er
+Tla'1E8)MUGiqpXkNDYI!E35dF""S&i#9ph[LpK'j691A3&F*qU,V"d5BFTZf#Cq
+%b!mN405SI#hk!QdK&8!S,IS(2kq%JZ$0""5'0U1hr-*`13lhp3j1R'SET@1G%pr
+"dH'TrYcdc*6Fc(4C!k216-R-6Fdm``@U#3bf6-,P%Mr*Q*Ub3*&S)2S1%Gk5-Dm
+Te`$JApEd4VicfMdi53X&3Q5XF$5F4S8HL$6#82KG'M,h$YhHhcRChbF&0lL!"F@
+i90$l6@6U&CrJq*[e+D(CY2JX2I##lmfC-d1m!"1aEF6#,aKR!4hZXVGNmDMd5bT
+%!KXTbM1Kb"B8&r@'3(pTX$Xbe'Y!30U`8c)-J'39,k+3!+KJ5&IS1dri10,EeMX
+a'AE35NPAr46PZqYjK4KeC)P1*cQ"G6E2-f'!50ASX[8EEqZ'J-&Z6@mRhhLaqIj
+[N!$C*%H!J'3kZqXGlMHTS*C-b+p'9UipY1H[21LK5Z(ZCA!c3l&5JHD$'i&'BiX
+6k2l-Nf0aJ&*[5d()q+F'+#,PaYQ[FA'jDVFf3[faQ)RF9Nk(Ll2bLN,kG-liPHL
+++em$#'JSlrU#1pMeGZAe3$IkGi1Lm`HpU-+h#EHYc1Y5IHMdIFm&9eNTBSiMBY!
+jKAU,AX&8BCYkcrCh5X'UK%F(LZb#"UVbpG9'dC8ICDZf8l@S0kGM10MEfFH2&9&
+5*4iB66e&aGYH4DFG&J+XM5SCf9dk&aIUNDUlSYp#H&92r-ek5YMP!0$"LdJ*26X
+[%"H*+9lF8Q)EC1`8&40`ER)4JF4FEa9bR%KeY6fF'4HqqCRMf0-cF5bk1k`)4Y5
+p#1@JQ8*A)E1JXhQq39PiI3b)3I%4$9h5*1Zb$DrPU&f,%LU9Y`L-r2A'MVM4fh!
+S4hU9J9H(CIIR&QafP+VG4!e(SYla%NFrmFP,@Al1HM)@f[DU2*9[X8T1B$lp&[C
+jQqF$)2C5Kba-56fNS-)RSIaLA1$Y3IBqSQ`F4C+qD*a#aFZ,aP'U`)3q+,1+%de
+!1AjRSUG1paZ6%mkc-Y[Z-,pJLLG3)L5QN!#9DZq*4eqM6GURV&0d%!639JNiP#e
+l"#lfk#Y0A!cb6)hKB[-%A$&B88b!#,pq$bN1bZIJf%iH"FZNLaQSmc88a5MkB9C
+4A(CKT@8m$VD4F15NMQq3!!9fE`qpAXQC1hJbjCd5NXUYJ8AQ,"p9hL)6iqQ*@k0
+aRjU1RQ2Sp("8pR63"D%HYdc4pKU20VL8kPA"&,$4S!!pf+,8!)'b62fNZ&'eZ[i
+6FR#-@!i,+k(M*j!!eQ#f0,aVS9ka9%em205Yq4c8`[l1XpfR4V8UT3!e"IFJYHQ
+X[)l!",[1m4)9+hECFHKT@RLX"($"YHUhJ`PdQ2AdNGRm"6IrXrD)V[I'2c+'pQe
+a8L"3p"P3i9%p$1H4d'i5[c*KTQjZCVpm,`QRkL#k3fhql*-MA+Mhm*MU,-5L1bj
+*&#G'kXJa19bN0$Rh-NcJ'3j))1X&"3JjT$mM05J#02'KB5*%%c--%d'DD$4-H'P
+L(KH1ETk3!'cXQH@ADij`FTAP(4j*(N8NA6V9UCNBZVfhFc6bZ9kChb"PUSNF8ii
+bUm+9HAm*8fC9Q$,lp-UmrkB15CRq5XVdVe+CIP,QM("P$NU#H#0LG9@bb@hLjXY
+@(kN4jM9S-#m$mcXF-2GX-3$QP`FR*NF48TN@p*8pUB&AR5Bb+jIk9G0%bp4X9fk
+DIP!c-3DJIdm!%e-0Cr-L)#bie2I%i-i)pa`"iS83&9Mm&j))qVb!0`jE1-XQibT
+BE2''E+TqN!"XlfaXQ56kDDRD*N#VAKm-V[C2ST(GLfUqZh2h"!2*898(rDbELLJ
+9,ccbfKd,HH5Y4-&2Lf%HH5LL(cK-N6Il@,DK+[G3B@2P$4XL#k"`VC8+$KDmk`f
+QFe8UhVicS6%SVNK[2Vbc$&4[KG3`5+cMKBA(ZJj94b'T,laUBSLf-%56U+B+&H"
+&PQR`J1#)Z9PPHpU4EGr0`6!A-VD'2h%p6Ff#,TVbSb%[IX%V54f4,ZP+HX%#9RX
+,YSbA%K!h1)lM1MFh(`5@QbbaqDb*8H%B$+pSl91X`15Gh8R0m*kiT"DY-8%YI`Z
+e-*hdpdiDi&K%cdidi8Q)'SN-4r9%4@6)l`H`,8Z[8'JA@lA03$H+G*T#mISmVTV
+50QkMN[TaNH%'IpPhMKZ0&h+GG"8c""5a1JX459+0ZHP5!Epe$-UMcBa4X5`"8XB
+hQMTd[h%XY+-#YJK,)+B$!bq-ZA-4XK@E1RV3"4G%64Rp64eN%YX%#CI!Ih@pJT`
+aa-JCHS18'VNN#NdK5C3%*KP%m@V&0m!ER33#-d,'N!#@N!#KVl#MK$MN,%HP[A+
+e5VX(9G'SeFp!X"+JA+(I#*Ul(USH8@&03Cea"I,DLJ9A-Yb9))*M)5@!)J"!CHZ
+*aj*5d#Ne8M9*SJDd6@8'jNPBkaXB&HK!%T&,5kYDhm$(*Rbm8Gj"cIbB"'`SA!I
+rm%"imaq!4$P01Rj"#bl3m3YDV'U3!1RTTd*a89+XC"F0aeC+6FV+E($mf%3-KUE
+NGrZ(9Y#5C0G'FHdi[cCU9@X0*FLZ8XGD*)+B*2jA965T9c2)F1@d$eFTH0d+"#p
+5#JD`X9VENBP0DX8QZC,mR!cLCQ)VQ0KNR)[pQTSQpH!qM)*"qdbB4kY`$dI4!%"
+*JYA#a`52-i9l+V2KNL*L-!#S2b@&-rL8A65&LeVj492m)Z8P8G(+,[(%+J'$dJ9
+IIi4HKJ'LPH'`pEYSC08AlC`HIY%(fSdB`$h@c+jaH[JeIPa$48'5LBl'+[40U'G
+Qdi38N!!1p3raeK)6S0B')l99L5)bmCQJ+4D-&1L9A+8AKL,cirkKX"*c[93`[QS
+92&S4VS+&r*,95[reZfaUeCF9bq'AIFc9EDKr@E)6'lV!S%3a&G6!h#r5a!(K1*Y
+M(hmekK2rFp+2K0e$NDTB"-1j'He`k!J4Q,DfI3S*11a45[Jp@M8kG%!9Xd@Z4+T
+',id1aBJYb0N%CkZ3!"+)lklD6BaqBYapDII3p,0j"(Dfb&8f0c+c&!P'9YV'&%J
+G%2Z&c4hTE4M-%[i&(M4re9i[GpVPLC!!rZHNm+ITNb'"FPF4'!pd",S#Ji(4`-Q
+!-E!RF$N`,p!8Q"ji2h"(B'1J0&!B5SBmSIE3TT!!+D3*h4[+#Kd)eB@q#VdBQKf
+U$pd4fKJU$48'Nm(aB%H`+cJB(!hDJqR"Sm'&`GTJ3h"QF'j`Dh#R0q49Ha2H6Gj
+"lkMAlNhh([A@H"GiArI1m-laAZ[Gl0hPpVY(h$Vh,,IC[GZGi8ja@paAhBqi&lR
+VhAHiRh6[m[Pp`ckGEjD[clIEGpjh`(ICYm$Ai*[TQq[EkYYCjLZE+NZ8fFS1Pl@
+9R5ilAlDrV+TXH9PefHbbqV*TC6HAh9Hfbarb9rK(r1hq(Il$ISGrYrrN9+(i"ra
+8M6iE%f9f0Mc%KrPXq"SI1YM`Th`iaSBAqE#($ErL3jN0(q($&MDmN`qpE&K03pm
+Z0UcP`meXq#)IhX5'Ar,Kh@ciVhci"4ZqaBF0E0M-Kl9Xf-5(#pQ`N3q2XH%52Na
+M`m9mH)i0AqI$%fbiL!mlfI"Y2R5aiFriF!FErT)2@pP`0Km1Xq%,I1KR`qNdG*H
+`iIrQ`iIBF!BI2Xk'rmD(FpR`2rK`*KYq`SF[B,N92aC5kQkD)J838`0R@-L'A-A
+ZBfc)PHT1Bd1Z4[FjKDKD,LUI-8J)k`hJ0h`iaPjb"EPlf*!!4i&ECU+UY+)U'!0
+AK&Z`)BmLlc1-rDIk,AJhXUZ1FBBlf(!q(ll2f1[`Xi#ccfELH(4iAe5)Hj%c,&G
+-r5ZIXV!Mh*Lm+@c))m+ESEMJ+'H2++BZmLQABZS$2N8+q!NTM`Z4&3a,1)0H!G`
+-[AS&m-J1NJ+QkC8AI**YGaNIAXZ'cr(K((E`(rP`"K[bJ"9mR3fjq3BA+&#B4bJ
+%,f2j(Rk@FiBp#UA8FBBXaC&MI1Sd%mN$5l#0$EN4"JmVM'8CCpr''(M!$UjNL(1
+&"09Xq#`IKYM`EfNBfSRP2qX4#ch!KLrai6@+DekLDd,[+DB@mLPP!(L%6p8UTVl
+&TfS88r2je"l&e(rbU5b'eXrjeIFbKZrLj`TRD'--A2QK``a4(M%K'f-r3NE2f8N
+"Ib$ceaYe++UimYpS+P#LQ*V"TcDcBa5C4rM8YBSTESk"paA(lZ46qJ$!83qmU'$
+J84pBVTML35CJ88`em+PFYVfMA%L-$Dr`BB30Mr"K(aYHiX0CE&M(KcSfr*J24pM
+`+Kp'fI!$'SSL0Vc-Ke[BN!"(1dH0KJ[jm(UQJLp*qB5Xd"H!h'6%#f`iM`qAXH%
+hqA!q'riR(k+,'[%q+bMfB[&2V)JaXJ&99aP-Q963jl-A92#dX3'*FV%"AEQ*(5"
+$d,%Ahm*JR!d)%68E8$AURASrmQcNNJ5Fj)P[fcNimb`Pl#@ATE#%dj58+N5*N!#
+mGNU%b!'BQ4b!ZH@Nm,CTNe'2`h0L0(JqZ-"VN[i&Cr2&L,F("cY%J"qYjNIMk"6
+['Zh4k@+"-!Z0Q)BH1kH*h5*GR"HA4D0i%F16BLD5)4c!FTV)&FI%#6&(I),"FY(
+!*kH*qF0MiNj5,"De@"c&iX[B!AaHM+AMXbb@Ldp6l$`qcE'6q#b*RF$RpGKZI(i
+@dq$c3Xb"crq1pH(c(l($q(`5km+R2VB$RmpLfr#C'@[(jrXa'CmjX4&m2Sa0i9-
+BUm#R11E(jl%B[+c95%,T0LXf,B&lqdk+N!"1#qiY#m`&@2FkYP`(YqfD`-eLIZ$
+$`,@"RB'YJFf"dY"+84hb"8T##&LL+E3b8!2!,aTU%3fKP4KD4,ei$UUi4X`9'`2
+ca@C4,,B!K23(21Kc5!lS`'3,Z!"-QJ2j!8hJZ8"ei(`J"U!bM3[i!XM#!6``$iX
+M&$La1)S&+C'##5Qa#JY5ib%X8V!iKX8j,&l$JY4BKm9T,(j+J41,+eL3!"S[B@(
+#!Pd-"TCLm6%@T-DV@(4Jm3%@#5aU+("LF4',&Lb@Bj(%iL8X3PJX4'5@B2'h@$b
+$a9GBh)I&GbP`BM%ILjZ`3*HEiJiXjQ(a)4EIT-#*a50Bc-$L@eM-aQ)"&SeBr!D
+,@LcH`S)8X!J,8X$Ec)LqB%EdMpb)rSNEdGhFL2k&'p'eh)LZi8Ed"$HL"lJ4hFq
+0D$-hSYpb)lU2'p'[Z4%pa)hSB@j%TGb)rX#0k&IFL*lK4[3eEN3lp8B8p#,Kb-r
+JeZj6MiQ[5blVS5d+`eVZV+!1"[MJ&5HDpcJqMB[k#4GeSej8D!C%,@HLhQHLPLP
+%(A-Q)-V-"lIb35Yqf[(6JamNY(,+-4Y%lZ,Eq$EIaU0m'b9m'p[j0JVij8AmFTA
+fmX1i[*PGrZrXmJj-@YMN[l(*BIj"JNeNDD1i#AQ(@j!!I'BV%MK9SkYUS2VB*Bj
+b#)QmJS5Uj58Nd1UBT)H2G(a1ReQ6KXrS+ITi*JdI-df*'Mk`d8GFTQ0LkmX@cYc
+cXS@rp%XIVS`2UGXh@JCA1M2iBL-jUI'$,dS(4"@1TqN(H0AfXZ9l&QF+&r"rRI[
+j`Z2X`DZPB$T-%lFm!@Bbm(USUTSCkVmb3feNKVUB'@S$-p6Cc&"rb3ae1M28Rh0
+$IBiEkJaZU2r!$I@IZD'qa`heapa3jh*$[BXEkKhF82r)$I9kEUKriSEkhcb+Eq*
+4I$12i[r,ShJMMq+Y2)Vr&irL*eN8Rd!drF'ZU4a*d@H&H2fSFaYI(('ZT-@ArqK
+-dU+f'TRH(JMC`XAqPBYpR)[p#a2ViadK#8AA*8K-car")T%+3#B3+hNh&P&lP,N
+h8I)%'h9h)KdT1%E1Rkh-%B3bHJE1`39prM[Ri)lq#"*demU1fV*CP1&lEI5FU3m
+GYIQ-dkJB3GFpIHLiai6N-4hLX-l#&chY&NVUMXl0(d&LH$KH&ab$!pJbkQJk*&5
+02&(kE"Tk"AFb2eBGJ[#dD+jj69()RR,GKh&06j'hVFF[#ZECFJYU%rl4)qPVRfM
+Q5G1e)TeH*0&[4`,'BqCkUPM-DjcHrG0L,DrN&L`50YfLJZRYL`TQNaUT1YHlU&*
+@T%HQa`P9)bF!b4QI48,0HEN*U2&DC!+3!(-SUEF)"*!!(c@Kql&BK4cmed3V%T!
+!bF%lXC!!(IU%D3`dN!"FaTV`+SN%b'V6ZjbiJfj[H')U2#DM9G&C3p6[3E3K%pc
+[[$I"ZQf)H9[HT`l[d&P--,&fTX@q"3kZKekYbKI'H2dKqdkmfS%Z*,ebk,'k+SX
+F-VY-,LckGIdhrV-ZqX[h-kENQH(rIRChjN-J80X-"L12j5Lkkd*d*+Q,-(SJMEk
+M,@h(6jZPlLU3!$LeG3+G[lhUDUh$`-m(4e[Vd(e60!FGVP$RL0qZbqq@(HM@"4e
+PmBRcqGfa)QR$hmV1cNM2cRjjachSi1Z'HdiHcmM16%[00**riq"qUI0@l9@H$48
+rAbRqlm)N#dQBP1#%NTp`pY49XUGe([c2"mmI,iGTL,Jidil1J`Z86*8fa6R&kJT
+XkIcG&"Lq4EVVH&C@6LUl4N+UTBpB`e(AXJj*DYChH!)N9Nimr*2@eMTNa5$KkhB
+0SA+L1mG23`N9C8G+G)J6)SRC,"hPRC(id6&%Gf9@5Ibd"9VaYJd3Vj11AUIidGp
+Cr1KeLrqAKr6L#m4kL-HV`Q,T'1qS"4dTj+p)p(iQHNC"G,e%cbJi,"d,&dS&"K,
+lI53DRCl%4f+C(+KT&VA26iKDZ4p1K5ZI0iX&Ub(3!9'LYBiqB'V&JpQQT'f@A,0
+LC1"iV#G",bkC5iHPC*jk-66%G9155bm81m+c9TY%,9XXSm@Yj*VA5%Y#MaeD`!p
+4eh%@L4fCY,LQm$b5ha44`FXQDr&`U`9iI09)*cSdJlYUNB,Cb+Xjmr0JNkjLD0q
+REkJj1U#NT+04e0Up*Jcia"5kJe`3D43,IU44U5BEH40T2TK'l0a35MEQ8a,a'L-
+p6'@RqC`@V8*pKe[i88%)8*T&+"8b*U0ML*ccNFcN4ZHJj%iVPZAMmA&)[1N`DhL
+'lq)5**AIAXHFlKq#@9SdB%'QF!6+jae@5Sb2&U25@%N2DQ&GJ,&U(dlL'A*Q5NT
+1LR`K9qj05aqmN!#9fCpV2*JqQBkAH8ZA%S[Z)b(H3#Q`G+QfA(VMM9l$ZVpE-G*
+Qe$$e)8Q1fUE[XUqGh"q3!"#JA&AZS+lIfcY%lA5`C2'1i%QjLGZT8N(@2Mjh3G'
+dZ#JTHKPAG!ZkQ&[(PEfCG6@a(0dG),%[G6!JMT)JKH*,p"d2@YFTe&kb!V8r4*Q
+e61epA1fl&'VIaGfI$@V29kKpPelYX[3302m'+$cer2'8MQhbQ3X(-V262pSJjDX
+++9Q3!*4"*P0hb$9`j4l(`qjQ5JNEYTIQ5mK59b&'RR!+L+efaDNcQ5P+b5a,5-d
+69fNcNpCKmkjf$L3k4eT[id8$3"d1V%5Y3CiS#KRXFP#[!!P3BQ,SH&Hl-+UQ8aF
+V(6mD8UQBN!#9*)3#"R8jT4Fc61El,*P[Q%#!)@'C@`D8d,N$)F&8iGHVSZ3j548
+P6c*9Y1K9)623GRh8`5lfKfeL"cT`iLL[GQNIZp6i0lR8%!88N!#BXUBqlqE1q3U
+9YmGKqQU1S"4*-EV+S$3)5L1R3%PPmTX*6H)#XJ%[+V[,Sm*E2m%l[Z9*KJcGjQQ
+VJRCd,1JPTbKdM4XeRq-GF)p6*8#AVU"+UR5"SBS5J`k4hffA"X2jh5K3ND3H`%c
+SiTc`lKKjN8+2A[A+P"JqJ%FlqT9Gr['XiLEK*cIPmUV2Re6VUdmaFYh9*`lei0$
+*eMT5KZaJ(Bfh5L+qI[Nk0U`A-X*958@9Ile"M4QL48+h%T!!)@A2Ca&D8MA+A!2
+p$,QNS4"Q+TmK6NGJTPEUc,D'$*&9aBU-BG&",bSIecIrC,rk4MXHdUKm)@Z83b2
+Fia`HHiPbdUU'`%e--"VrqJB"KP1a+!G5&dXJU[kBi3&l*##r,Rc6US8V8&5&DAQ
+iNK69d'D&DQ"Bj9r-,QJ2QeMmlIQ'aeF+E9*(rM#Tq@5Z6RpN#44aHf`3lV0TP%`
+'R6`qd'SQJaMSTSS'"N[UYr(UD59RiP1&#bR!8XFbhcBbK0+S)6JZ`KU#84b"%J2
+(U$')kLR+#ccDFY+`AIk!6fhAZ+d[@9m&`eId`,2q8TiSjcB#*TN+1U8!Ji++"9i
+@F0X"b%AP&KkFef#6(GaX$["Z9R9KL%P"f,)LNbAhLYDD&88(SMKB[iJRqr2[2V,
+F)JF86&%bjjBD*AM+NdPMdbPb`j&-Efe2$&e%1T1*Y5hA6&VX*BN*Z6r-*-p,P4S
+[T0GT8B-+9FG))@G,q3X+,N`KUX2P+d3ec"9#fapAGSj)#'N(%26E1KkSp+CGSVq
+@NSDU@JbA%ZL"4&%E+6$S,bqD@IlP4I2SFR2H6li[48249M*[UA2jpZ`rIc%FMVC
+SU)bfQ+j%@m4@B%+E'0V[-q0T+3pYI66[U&'UFDj&UFBrUe&a*YrE5+,i%0!XfER
+0-2Mk[BE"eeC@,[,RUX1+I)"d8T(rKhRAU9ab[TY')U6L@9%!QDqVU'D&XD',fM5
+95Z'ZYVK%T`@Qd,5"mp494A(H&4BBG&j[dS)0KK@TdX9PkXV&G1%AUdfp[YV822f
+8e)Qc%[3U-CGAeFj0eeHek#CY[DZp4mHPSkY(1"jBS$B8b4)"XTfk+@fCAT84D[H
+L`kSCfapT&hL-ZRIkSIcZM!J9`qhRb196$KU-GAZASVKE*aRXpU[DJ,41B[ZfjT8
+Ki586MQRdKA4XF2UK9*0Z0C%P$bK%XZ*cqjK@*!ZBZiVd)T8*h282Q99@0P*h@3d
+!JM*p!),3M'49$#r1YKpY9e3b8L@arD61,%G45E6`LJ-A8N96XSXB#CKbd'2'"kP
+c4`Vm*6BC(3+LmF+,$5Vb`AbjI6Q[U'4qe6VTXUrI9dj9GEZb5T!!*@3"FSdU3#j
+PmBdQA,r5c)%%J3BY"**)"U6D'#B1REj80VqLDa@ZB,`l-A*2KaYB)%diMZ@-@j-
+-R29dAU31c*bK+mpHqfbNkVPMH8r+F#AcTPAZYS"AG'Y`B%DJ4#Gd!+TEfcUQfYd
+cUM6G*p&ek,A,TeHP&ZZ#mjGc9R4a,,',p[EN9kMiRhb@QTm')&S13RfHm+i,T-H
+JpJ"Fl5KVki&,Eh5E@pH"VUDKp[R(5$N05(L988&Jr9G)b04@CJ2ap+Y$FXXTG*r
+if1*YlZR(6UkmpPP%NjGG&HfmQ2$L-6hS8)k-2(8VM#U+4jZV$3mc03$+h)M819%
+*p!$b#8hhrX"lMB,qH)(SeMS8j@3HDMQX)h0pKff8H!2'9a9qIEX!dF-[0AcXJe*
+LeLdqeP3qcj[+KBUQ-LGe+*V+'BUQFU'fU4b8b"-6$pmiLQiSE1Jh#@TkV2PCS+S
+"JXrK"eh5THP*j4HSj5cEdBD@-h-ccXJ(Fc26M*QTkCNC@ErI8*)&+l+J%1Vb%-T
+dmD'kl4b'ILZ[SLDTLJS$ZhM9j8Id460mY%6(TceDm-0!XKhQK(XG&ArjBF9I1#"
+U%,Y2DY)45D)kV)KB*&8GIr-VT+-mbk#&AkF21[l1LbFU&lPrYQX9'hYZa9G3pfS
+dV+p40Yr+Qjaiq(UASB)0UqBI,YQS''a@$+k4M[jT,2bSSH)ZILKFe(DK'2J9!ip
+#E$%*L'ZVld"22RpXIQ!@,F+VG#6Ii#Vm"C&iGi#)e@VR#IG4B1r!NEi6hAKUqMh
+iS@%&Ef3N%'M1)@JPH0"#iJY4cB*5Kjk8)+Rj3XkCl*2(cf6+pZ-AXN"`)N*6DPE
+QmC69!`5Id"pBZT5G#!m3(!bk[M5miIZVE9+&rX$#p3'$(TK$)XTVT2l+AVQCL53
+i1l346SQ8m4!i*1$h(l@S!q@pQ+Pi`36FS`Aqq4BS5Z)`8p8L20Da%!mD$b0q-c,
+bMR#8$D!ADe#dVJEB1%!m$2'QE3SR@@cE0bB,l@3Rl`Te"MTiFe(Q(FLE5)U%!M5
+%)V!DA@hQVNKPP%A*(hc(0fF,fa`5T@QlT@(G2&"$i9Sb-'+)Nr*Q&+($&8-3d3G
+@8`[)V!'HT4!LJ%',kM2F[$6DL6YNIhih*fT,%c0j`jfMVChm3QVf6RdLU&ZCqB5
+)rQ9K)AA++UV#*MGMdULF+QU4!NI4$UimRMaCqr+F4#SS1Ra#HfA"9Vj*2FZ8G,a
+J*dHN`J#DN!!T'KV5P3SaG&)C4Kb#ZYj8&#AUmJTZ,F&QHp2US1Z+#MN1V#!21*a
+N4Jp*eT)SHAFKQR,*%%T5a4qb9N5U-*!!5"3N[(%$#FmS9LpbYiF9ZC%QhNQ0IcA
+6RN,41-)b&-Xe8MSfLH0fkY6'6k5j969HU%*mSNj2%,fVAX'X*0V@Vc))DJ(MbN3
+R42fl,0((BPADUK$C%16#,f&NSB`9NldF0ACrC2(2MmVdSej0TCi0)M31'jMc9m5
+XIiJ%-Lf3!094B@hK'5#5Dd!dM%"3LG5U*8`V!I52K"GUZ"#Q!UkDm!Bj2k`Z2k+
+)R2I3i*0e+b#Xk6GA8EjC86@k[CLUd8+rBU"@$)55F*!!U#RAG$GFdBX,G#Y@Y,j
+j,@CTQpH'$4G*64J`,#l`Dl60l`*Aj5TY4@LUdPH98EUH9kZ[qfUH#(4+bL,N$Dl
+G'ZU8[jLjqY"4)NbUf84d"B'Q-N'i[)KJMb2!jQl@%LAeei$BUqNfA++UV8b3!+K
+mHAPJS3%Ke3(&&KAAU"D&AA2hDNFA&mLV,",d@h[jPh-9e@JK5m4F5*8l1p5L80R
+5X!$eFS)+erj9&QND6GhUL"5p@2kf`T9AC+p8e6#e&heBcRDl9U$!UA+feX&HGLQ
+f0PbT'(5Y,UbJG!@4F@mBfUlV3NqTI'A9[&Tf%BM[#BA6QIcb'fh#UlZBZ24Z[r#
+fCqX-i&581T6(G@%&@9KNM2e2*H+BV&ke-C3Ab9*#DriJ,dNPZY8$fBUL2c`59ad
+!bJpii8&)pIi+#+JH1YjDm`TB+5YJ4@68$51ldKpmScbJQNeGr,e#RG98ZX5kVPf
+IM66jaJ@1"$lb5mT($T@*(UQ"J%iS@hN(eKf"QijZ2E60r89$PXMd*Yba8+YE$Y8
+F!H(r56NJGBPQL*C@1Rj"S+YY'r`*(k0+68H%"*diUL!)Fa9+V,TE&iPA296GU6F
+5qqiE,#0K*#diRC4AU'l@9m%Sd2G222br2L4AQ0pZ3iAFq[-j)(TZ&KSXKQN5JfS
+-Q'Y@`@B8p%RR$K`b%A%6VmGPhJ4RcDYaBY[H"*!!ZC,leZS1A[U+h[,r+RfklS'
+VeTN,UGP%&MPjd*lpS0k[E"0j&@5RTabrN!"q"Y2C"XHbX-eXIAqp0e1Xhmc@rd1
+E55eh-kRDc4K!)b#fHq,KadT"N!$edN*6PeqAL#6UfL2dq+',rr5Z@5`P02"!E%`
+!E3rBVY+IPi3reFE"(B*SLh01G'mSXMPRZ#I(G5Sq$0R6Z(irA8q,F'6cPHJQT#N
+&`P''F24h4IM#li)`P,YaTU6FM62A4lNEcrmjPEY"KJ$PEY4)bYfS@9rPFS6rE-T
+G$i6ek#ESFTCK`UpPB'+PDrQPpi4Gq[IXdT`c'hMKBeIrTKHZ4b'M[p$djbNZ1%*
+rTd4Sd`d53T,1ekHi#%IVce%JV`pDUeD@fNVG%(BHI#3M*r["#aQCZAT*ADRT[cG
+QJR&S-&ASRB%mA@`$IFL-#V@2$Um41cc"&2HF)`k[ACkeKTceLD3Z#qV#QC'KZ$N
+A2CGIMMRVZq@e('DEZ'H$LVCCCc*cde0q(qD'V5IhM8XAEFHI8P&CP4``NC3hjXa
+-Kirala#T3rpIAV[#,I0VShLD'@A4)I,3853qDq(5M3M-23j([`I,LF%(+3VT)@q
+cV1LbD5J!d!C*$Y6m$d2!3l"+X`ihq)AYKrK6YZ+5U25FV*`(-e2+Nl9+89[+%AA
+3D&bK+&idH2QMELXii%TrU)"a@#+j4Y1%*cM(S[B5-(`#)RAFFFeLJp`,CmS4+CR
+2$6CTLSM-Qr+1RlRY`8T&N!!mmI!6ipbChDFJ2C86Y,kV$&RDLbJ+b"dI3AHTV(l
+CFYIE)"M!LIh!U(,kFqf,rbUArEmDbQIIHk)bX[FAVJqbPRH9f1ki*rYXCQjQ#U`
+U05FM-h9r1M"(f9P1J8aAY2jCVNJ0[i,!D[bK(A$L!J!m61Dr3RFD)K63&DqXb)T
+6%EfDS96mRkT*CFA@+SbHq&06bd0NDVd3HAi&TD%"$id8T)")P2im"'41@T!!!%9
+&38%GR(Mi[LaU"Z$b`+U$9#SVAPFXkYIPL#S[51P&SB[bJaBGq2+1Tf9RCHBkdmp
+R'dU6X+M5&f(&",`-d%-iLRY,9E`$6LK-6Bmhj3ijH$`!$jK0XTSD@!`!kF%Peh9
+"C1L#T+p6@3be06Kf21["ilmrNjfEJkl#pkm51qP31`kKhpbF$232YNTqBa$X!f!
+rQ([Qr!9lqLS`Zk""(%Ci0#)J6XP[`d$`CdpJiH&LGP!KNlY+#AaR%@i-6&DjSZk
+"U*b$k4XS5e41r($r94j)eHXEA"H%*9[D9%iJA5p6HG#JhTHlHpi'X))r"Z)L(KH
+)2bI#+rq`S5l,1r(I-Hr%(c#%H9b(B6aBVQ')p61-"cI--"lF%-0iX"c$U"`&Qmp
+TSk$`Ea!&LS)B!!!`!d&%3e)$!&D`$e8,,#N!+Qec[jGh@9G%A&BL)U)9%G(8M((
+-'%IIppepbI2,b%c06%(1,4J"`S*QTXqlZ`)LRXh8'M1RF4c(DFbDaM'RS(%FTm`
+m[aV(2$HH1b8cN!-MT19qRJ9F2(I6I2r[ZVl[ZmlcAGF&'ab""%%3"%'3!%L+C%3
+VeYA9r@Ep8rTj4l$i&@M"-f#1`jb'k3V$B8*K,X0dJZPlX-ec+UE*63K"8H6*hDG
+bXi0(@j,U0%2kK5(Mmp@lkQ3M%$f1re)YTPmRYG-mdLbM0RSCIdmp3"mRcG'+T$c
+k)1P6EE6d@f0-Y*R29'FB*G'2m6qSMp"h5BZdE#QGPL3Yd"kAPKU24QIaa@ST68p
+k3hYDqV2a9(3CIdfGBRLM$r+TDJ&05jUYQD6"aZRS&qVi2HUrkHkNJ9UPG)D'*0f
+[h5NpB2`cqL`IT"kPQU5l003$id6d-@j93icbk$raSHTYG%G5X(CFDU#8T)He2G*
+$a[24qrK`GB4a+[SjIUpkNKj-'URYPqBD1G&lq6IUEKU@0%UVPh*TIY*#lC!!0-m
+i('hKN@SR)c`kUSirSbE6[j)kDcZNCZU6p(GYXr4()bJkJGqZCP#rT,pUldKr-r+
+M-rP2DRpMBr6Vr(GU%rdPUDr@+1fLRNNrehk8AMAHMVl!HkZI'cHMEr![e@rT0dR
+GYB[5*iBl1TEr9pe#rdKkAdZ6)UK(dSGDM25$X5QkPIG58qPbdUelY-qN!FCAd5[
+j1E@EX5*k&Ap#rCkH61UL,CGH0VC&Im6rSqkNCj-kD0ZPVG3qk4AY6DQMm9EdDYj
+9$6@14'rJep@eG#8T6&XMVD1V5CHd,k4VaYI4khQEkL*RdRP0Pa+0qk,MH,aU0j4
+S"lGC9-QQ*A(0)YR3p$#8rJE*0)i1d10dJQj3R9%ReifV1e$hH0f*1M*lDJ[c!NA
+'Q1*PmZKa"e4lmBc4ZVEDV'X56,3jML2Z'UGVc`GdVE4BefTKXQ!HJ4N0T!NG#cV
+(`93#-f1-bcjk4Uh,E[!mPch!4l[XXV!(1*!!ii6eF#`KF)AX9$!I%(DFX'2BhKQ
+eZZD"C+03Ya6UfMKCef52VTQ,*52k$Vl-mXI%P8%a34&T33Q@2dVfVpbaPZEi$@j
+,3r+H&bbhfHmmLH!mEP%cSL`*jjSb,9rp'1-1HLGQ[f9$C[+TrCC'LeYV,EFmGhL
+,l958B'TVbScj-HB8XVcRQ,#`$HlRPZ9Pdl,l-S)XQI%@06E'hC5Tr+p!RGV*qBd
+E0bd'pqMF8#f'a@-a*,Z(d&0%G'JHXKM-@MbUc51ZqJSHc@2Sh+0D22%'#Da(e3`
+2j!Y1b-%3M+Laj-%!aXQiG#"aRGM$$8I&FJVhX"eL-B8E,VB8dd#a3CUKBKAZFGJ
+p6#"R#U*RKl5UC6MMUMlQH$'Y9NXrchSH&k3QHMKbF8jFi9aeSNmQeh8,0j&!@VJ
+U"P`BX0KK9@jb*6)'-R%e[S,4`EQV3J!h+6D"9VR&TCQiNPLahH63J!TP,'+hHTk
+YB&,Y1&GXJN89+cK#fC)3Ee'iKH&F6LB%DkYFU%69kL@b!CKGGVq'Z,BIaV6hbe"
+iSF9X+A6CcB9N-8YFZ"V@86@"8I&[0e-KmP*,S3dp)(QK3qc5a8EX9bf&NQBZ9*d
+3B5Dfh9iSHLS1a4kc)PJj*)&$%C)Nj-aLT0S+Ui4,BTQiUR8Va)!&qhLeHPAm6!U
+L*YCK&L*9SCTr498Sb!X9aQ8afrbDJ95Lm#fD-%SE)a!q8@N`!JmS!MNe4P)`F-d
+9,mijJc!8&NJVk'H`8RCJJhVH,d#FqrZL609i*KFLVQK8)B('5cf#&C6VIRDffbQ
+1aq[Pp'rQ@X@UGU(GGBY4TDh39,9C+JUc3KZrI*5fJG3,SpS983P!CS-N44-Bb5`
+`kV9#k)-"JB-8Xf)c#aB3#cQG+R+l@a)lmCY#0X"Z-PaF8Ca-[-)9KqBA*pC4l!c
+TAkG0UC!!cpC401b1&lZ!mc-+P"fb9E'bSTaRbl"m9SAFke9EQIS-(FVf#`HLf[(
++i)!b&SXNqUJpV%Z5DVI!9Ja!MH[Si)d"&P9--VRLr828$X%QfF4!#B8-BXCPNCJ
+Xa5kKCNJ5Yc#V#,'1mibR#Lq@J!iQS3d@FrSAB4JQ3f1Xm*!!5S93PdhX9e!cE@!
+9H-ldU0,*8E'D)l3#Ji3QHLa8k#&cS6l!6+)$i#rd@$#`L)(`S+,%#Mf+6E#+UJF
+fp3SlCP[K@1hBSYUa4@L*J30e)C6*%I)Ff1k`#CN!CE-JfL@a%M1-(f9ehLp11(6
+')U3*'4AU++L9(K5[Kid9b,R2b8BZ*d-jl%)2Qa#+#U['3jL*6"*c8Kji3Sp*BTl
+3"$J")H$U*C0($4-(j!(H!hIRB4X%a6dUSb%1&#IM8+qc(F+B&$3,lR1bNCm*'BI
+J8[`4KH84CH"`XKe#e(Qa2-(PBJX6lprZJ'T-*dHSAa'UBNJ%QYK4I)@+b+$Bb[$
+aINj&V)2-46jmUN#l(qmNprG9IM)1IimQQViV1DM9M@m)KqQ`cd$IjBjVbJMDN!$
+C'Z[qbKd4&2@1HX9R4!ADV+X1Qq"4dHrXZ$3"Zq"SVr"5a,i1BeB[G+*pF-DXk8"
+I3(ma6,#ZIIp*J9E6!)1AU*VMUVBU"CdM-+Q#`FY(UYU10KJh$$+V&IeMh!Q@mY#
+J+T@KaRY((GGD*!P+[,IHBEbh(*dG-*PBjk`kB19m*5VjpFd4qE'C#HZEd2$-$)T
+3%kZli'c[Z+3Q0lTM-cGASB@Xfb'V(cVGaF"iEbE'mHM2KTQVDmXAUApjDl8VbKd
+&8VL$)Rb*-5P+d-*Kc2%@D(0ba-#BFaVbDM$'Lq5FpC!!Ge(9hJT@%prUN4U4[cN
+Lb"*cDq*Lf0BjMGKQKqQ'VHQUYM9DI@,VNI(DI"(VpLR)&N2XqX"aDb*m1*N"dC(
+S$")$if2#Z%H"pV%C*N[A[ST@Y6HKjjYR#ja$)eQ"a'INEfj+hKPNLG$b'5P"riq
+2JRmGc&CGfpC(G@l2C,b*'8'CQpf0JYQHc`Lmh[Ki+rJM`1Z%k3Vq#&AERURD$V-
+YcKe4#6ZM,"Rfr16$qN53!+Tp8U$iH*(MZLp!I$`F5`a%"l5H$6HqSk[U6%kEU2+
+#GlDP`$QlNTfhjFHkGqBhlib)bY`Fa%3CXiq"*3k59X0Nk&VbBM9aHfC9J3h3di)
+bh8GM-f1D0QIL25JM2h2c-3LHl64QGcC#,)k*TH'U'K%6P0Q8A29eca)6#ZSi+JD
+hmL1B9&G66'Z81lQ4!HEX5'0f#$5C9D"0+i3T-N+J8-JZQ(#B4L1NG@*,D3VHSei
+*LJK+m!@TPZ!eECYMSQ!hVG&K6'Y&abi'aV5V'+1b6ZX'dpm)`EH2N!$,"HG$ZSj
+Yh8YLhCF%bQNMaJ+8dfSFaK42J6DP4!b-+6PB'ppITZb(NBb3!,jBZbG-G-%c)Ed
+Hl'Qc61LA@UCNLV[DL8d*0DC`jTkQ)$e6%Y""HUBJ260mA41%qlLQ+IfCDpS)30f
+i&DDji&C)T*!!q&+Tie0G9DY1,61Q&V&9TfCKe4(S`"p-2@k%",GFY8BUd)D@q&H
+GHYbrkNbBAM$GB@l(1HVP8&2"Xd-RiQpD*RYUHf0U(iFa&38ep5HBhXC3V$2dH-'
+!SG+,F"K6KaY6Jl(rY3*Y1X40Vc@'3UfKJ,UKi3AAKNDfA'hkIQ2kF@0SSc'dpHU
+',mCAaNNVkr6`PT9eHU[$Q!iiRQiA!f-kbQ8kI2PdP-[drXE3d1UUQpL8(l0c4e4
+-%'TaFe464Qb%)#lErbikLf"'kGVV(94RIJREF6iM2cN+A`l+RFe4b8&Z`@deh[$
+Uer+[6T!!f$IUM6I1'N0R'd-""N-M&6j#i5X8(Uc`AbMm2`Tr9Z%r+Abr`[qUm2F
+8RX1`II$kTr!5KIpFiFmSh+l`@)8rc,Lr9hLc`MFU2&lKQa5q@1&1*V%E#mq`m5k
+&rd2KPBa29[K#d3EQ"8`SfLXZKGY8mEVTB'GC#Kr-a)(lGB8IB(Y1-Y46#RmEE3Z
+&$m(l)C0lJDda6q(h+Vb0(53UI+h#rkl`q3VIS[!3KIGN,I`4E"c0dV0(%DpcZjR
+'AS9(XT@Q+IbL`[-8IPhKhc*"lCL+53Tr3H&r8rKaTNUM`Kp4H*V#Ie6i#B9rTr"
+I-Y3CTKa@6DjDVjB0VM"&XIN*KEqLm$mVr*,#PbTmS-,raA4UBk5rMHRd)91S31&
+&,,8+5bF+Sjh#cbRm,BA2C%Y+6)-%KAr##L"Ei4d8EPAi6S8(&(j8i5UMb(5&peG
+i9jCJP1AMM1jp@GUQ+,b6`JH`ihZCVU$qJi`klbVm)CD'KpNDKeLDda@q9q'V&,j
+%i@MbI+c`'`Vr4Z'pf@,$fImCTNS$)`d5Xje"c$T'eUX+Ame+#i[GBRTJl9HV3'3
+$Sq#2,*&h-pB[&,j5i5mceLf-q[XBiF!k@q%G&Iie9'I&%`jC$(TL@6R0B8`@*RS
+9+im(&&k[m1F9(UE`,eN#)-+Qm,-+(k68289FLVCd#SmdA8kGIETAkf"ck*'C$Ad
+E8dUkVTja[1HZB)r6e5lRpS5jT9f@6crlLAY3EG[k@I[lCBc-HRREiU2G,pB8fT9
+hFc[[Q1mpYh*+CBq)JAPKDclBehrMm1cf@aH9pli3%SL2QecIThP8@EF9Vjej2fe
+)dG9eFdlpP$NL[F2f*FFq[ePR063ekI!c8I-+ERdflB8I0Ydcj[U'hqlj5p2$Mh9
+mk`qhrIc(1iV2klrHqmHJEjjqm[Xhr[RIf!H@AI[k[C0rIHI"4rrcdG,IrqEEZf5
+EiaH(rT@mm1#!VkEqqm1BZdGI@I[TmlplrD&(ARRcZcqpq[E3FBRhrA,hhcF2HqU
+*9AqqmapElMp`kBZ2RrYErVf22lYc`BN[EjLZ+8hZPfJ8,dUBH)kj#-jS%AcCSM!
+a-"Ce`aLqE&%(Q"l'd-'UYRN(A,IN@1RiGk@[$k)*(0+Lb,&NM)Y'31D3!),%lr+
+B%#ckAEUaD!4H"C!!,haA9Y&"GVPS$MV),VmlBRb(E'aSX+T&e--8`@3,*iGF"YY
+Vc!ARDd`9qG4h&ih[l%D0CG*-#6RKjCV859SYAI-M3+Q[ma1#-QKV8%6q&a%*34&
+X,-4pi*LdR41I2jjKNF2iEMik0@*J,$CMM(aUX3NQakM"eC8D0,TV4,iFU@V00pA
+,cFI',[$D*!SXEMB@TcQ-aH[4[`N6CY4FRN6SqHCM%fQq6%4D1f2aG+0QCV@%Dj!
+!i(pjB'de`62)@&TSe!aqBX+A#TphMUAeaP)dj*H@S3rD,R8CGp&DhjH5T3R'dNc
+MVY5*YHA1953r,LV'r5Zd(*IfQdK"q"[M5bG$'8$+d[PLB#`&G#hYJ[k3!!*Y5Cj
+a9d8$mbl@`%5R%DfpeTI3l+Z-r#frJQC,YSe9Xb8SZ58SY5ARa-"BdJ&M&rTpB(S
+EGqfUd)aAD"CDF#QNpHZSC*q@am4H%jB-E0Rd@&$S-"EN&9aE81VEC"%(aJ),cP!
+,&TbY'"X,MN!*%'S"@N%,-SblaVp5K&Be6-4HTl(JR((A6)Grr@l!ifd$"5`Um0(
+NaUL)r4CfG%N-GVSMSTVF-Hc!FUa+CepjLbXNRDZ3!*3Iml1NB"GHD4EJl5I5)JE
+)b0"(IPPV,1L2,P)8H86A,Qi6(5mZ9QMfFi*$GhjEkkYdrSY6fVq'fEq'fBKdSiY
+LLZbYDfrh%Kd[$eDGpSY-3XH@p0ML&eJKrTb[q)UcDUSm1Ci!,fUER`ccm1Bp,kk
+D$20@#M*%SU8iEbX-2K5m6D,M*d1#i!!C@ZLDrk[S@Nd-XC,CQ0FHh5N`D*CH@#i
+kIQ+XBd+kqPI`,l!MY[PR8hTq`*KIVQ[IMLc3V2$T9N#L&5l0'UTUq5K1+qUV&9A
+#L[TU4E@`iYA0ZJX[lEembl8C[[l&,9IZ-1DM$Xj(-Fl[VQXriMh#'Pfa,TbJ&Fl
+35MlV$SE"5j-edVqZG3D6rXU%kAaaT13,*@-K8RX6E`9@N!$8LQc"#P@XH2@ciJh
+*#Z#fiJZA&CA8LTc+#RGUlBTP*GrLUdVYLbbqK8Mc3U4jiIX`lq*b+li"@B2&kPj
+ZpL)I['Y`eG*HhZ$P&LmAZR6eGM"9[jY8[*PBF,8c15-S+S)16q#),)IYBhZGX4a
+@*ZEiR`AeQM)h@j,cm8dP)MECR4p4EXQd(,1m%l9VCdc6KD#U6bH6VY,LDdIedZ1
+rb6"d44fEp(9TEXm+ph-VfIeMDe!9XBljhqV#',E+9Fe0-HB'-qLI1mYKc*eHS(d
+$p$HPZUCC98hVjZ9iRj@mr!K'kldm&E(3beHVfSd5,`r(9BpCAYjiRfdI1@LhFDM
+`0#k(R63hR0jVcZP8bA2-1H'98UkC'cGZf#HbqUJ%apJ5-HUL`hF,!h"4f+2F60Y
+4Pah'+!$1+2qAaNilla-j-@L@M*`r1FeG89(mS5R6AH@3!0SU'+T9''%-Sr%L*aG
+S`c!BKZpRYYShrAZkMNdQ&I"K$[pHBaJq%!a$NfAB4TKiAB[(Uhpm!NbfUTfI#r-
+qM"fQ4(8k8jMJfbG4ZKVH*lS)9J#!$d-p(6C)eqcp+r4Vra,E99m9"cQ-&(bq5)&
+M6GQKDk'9AYl9bcZT@Q)0c"bBpM!+$0c[U-q01UjUcJjH$MrPA1lPPe8YmkUUfBE
+!c&(2fc,rCm"l2Le)e!K,HCIUqL'%q2NXIVlla,YF+AY[GcQd22kCdAZrZ!4ES2A
+Hri94Pq,PJq'DMBF[1M3[6PqY1(feaHNX"bk9IQCdVcMYlRXk21Y'DTe4+(Z+!q2
+-Br*'ebiV1Q!Um"iXIEVXUC,(XKr*HM6pFF[Kh%-jHqYh0qcCprcqNkHH1re#jEr
+2r[2-RFG[+rr6dGmI1b&&l8K1#'VHh0LdmI@-Gc,c@cG&a,KMdlEXq[(#QpXqfVi
+cI1`-EermpZD0X&PYekjfDrpXBZMeX#[SAlTmkpb!,NpfHk*VarD[[2bI$XpfHUE
+c[flrBjqrpre,rpreqq[RArEkSFH(RrchrArdr(R[9l[rj[-[Sj2Hr8@lAdrqjFc
+IIK"kj4A,aiQcTdfC1[f0erjXQ9'hk,[&5jFXL*`hIq(FkjF6EedkeqA*!8pd(0c
+ej3lrH@$)rF&hK!bYZFYD4rp6'UL+`kA(hAGN`jUeklpHpdAUCbZr@[lpLP@VhlT
+lUjm)BqABbSM!0E[0H6jqf+IIm&RS2c`UCIL$$iedMVMRh[2[$4adGha,'[cdYjB
+dq1P[2M6iG0ClPMRMDI!(AaTm-fTBbX2$(aVji)Kl"pmcm1j",@J`bDq`qQHmL*q
+iGME4Re6RljfHb+mPEbHI(hq42em"i6irbHGA*p(BIe@lM3NN5lrbVf9UI"%J`B6
++QLIKPmCb0&kM56IaX3LBN!"-RDZS06'k9IaFGD,-CC4N-38`hFY-BbL24P-Y,D-
+L62ib83(ZpML)ZmQHTM*kLNVS-FUQ4bL,(U9d6!fcd'(+T8183hZTRRC6!qfKII3
+mlDH6Z,[L146h#jLAqfrF4r42h*Yf*afRfkLFrS5ja,qRBjKBKS++SKf86!N84-f
+dQ4UTL6E5kj4"le!QjH0'Zdd836(NTPK+SbfdLhkN#r3QED12D$[Y4+Rr[`KiQbl
+5Yh36mpV#U+k0VY&9kNEYk9P+T&#k$Z`9mU-[d@@k4HGS!(@K*m(d"(@PMQ"pK9k
+Qre!(E1P%ce"RqKIG6RqN2[4hkNYrSIld1qT(IkA2k8[U46p3$rU3!$kKrp,lp!r
+U56qRh[3UGDII-)CSc,kLGqNAe)jq6C2TPc56INXI3)mV@19Mr'E60*T#8fNk[8'
+[dCpT"Rk,k$YD6%YT#5fJ5*T(mfNKcBAQPj'#@p$k(00h!26Y5)1Kmm[3p6rd!!f
+KqbQBlU!3'NSeG"GCU8lj[`m#+QCA1-K&1XA4IA5%0Y!D@N[Vk@YD4ep3+Re'+qN
+V@NlId`TD4D[T,GVD!J6qA`5-"`(FG+@4R@cNT2-86m2S8rS'f&RN4cp-SbL&KY1
+$p"#0"0-)ZSIZ"HYl0*!!"Y(Gf2*5)2!6rHdP38!`4&2Ga%$J8qM`(Xh"Ed)3q!0
+q%`H"Ek$Y-1Ml-$3@qMi)IHm�`$EHq'[K-&!6,@m6Y8flMJG3MQ'K(bPV2!44L
+G`m)()Y4QX0"1"&-F#aG%1*JY`Q1$4FKfLT!!EN+`T'YX8-N#fj!!(Xr#C"BL@CJ
+V`Z0(@'$(MrGRB4B,)d5`P,+JX,#D"DX)KpH`d)@&%"&b%eL)CQ'*#(Xc4DM[)m,
+Z2"E1L0"J&Z&%*a'NXb+NcKEK+lEjUd%L,%pRB58,&eRSaF)L%Ei[BS&YrVk4K9!
+@2Q'"L9Le@)3hfl2!%[EQjb*XBkTX+fGK1`X4)Rc%52N4)mTf4[VYM(cE@H+hGfD
+KK`MKM#MKp5b`!JYRL3r[c3)MF6K60-V&`Q84GR4PJDQ9c!k5`ePiQB@I@'!N5'C
+-#5B@@#)6f)BJPZ`J4TUJ15``GB-Bk$6[&k&a[JK0TePJfjTB!63aj6BbdQr-BS%
+aE@4-'fqb`)Tcih34-SkcN!$+!P-dJi&A"Q2+B)4qTeQ%r+-X-#$,pk-BD1EhC'%
++#`aS@XYBB)4VCD$3bTC[hFS#+kV@[Lb`cDf-P+d-@$Fa%QpbXm"8fF3)YiQ"a5C
+@Y*Z'La$"LLf#JA8%+lB)"XSa,0Na$&aL'$PL'2RF!4BB@Gd-V0fXXVPC*A5c",[
+lXF")idjKJ9AD@%E3@!X,$&"L@@*L'8M&XNS9biSfPUNBqaS,E(-D+q#d"KBBZG0
+fX,#,KA-XX%U5aXL4aUTPfK!4YM#PYl#NEQ&*hF)+D8Xh&KMKYV"Nla,,m&d@i@N
+XZjKAf#@NDVYkb94E+&0rQ(D&XP&D+"FZKh%Ab[*0Q!r351pE+"F(B#S,j6&(#q8
+m$*DY+C5,qK6+*4d+j82E#ZAG10MG!fC%SGa`$!B#'VS8bR[+BF#`"m+I6i!"m[R
+EBAV#c)5C!C05+1mR,"U3!1A#5&N1R*,PNM4ChKdYbmrhPqApdfAj4*JXUd@bV'6
+)XYjCPZq,Jh(,mK'6,'m!``CXA1Z&k5(,kl0J9X)XPZ@[JIbkQbar!8'THE,mfAi
+B#([VXLb(Mj!!jDKd'!L+kLl,1bl+FR+U,!H9`4b"!5+S6CDE&9RH$%&01'K&Cj0
+9PL1JC%3cc%qb(0-H"XTZk3S$j5jdJ*NXbeRR22,TH)rm*jG(rRfj4ck"cSPq(YQ
+eh52VPchb+S,"!G8@bj4G,-YZQ(E&XUFrc)KL19!+d`rQY@,C["AQ!Nb2BRR-l'+
+jGP5aA03"CNLaA&"B,"qF85`rA9mXPi3AbpPGLZ9(MX0!B&CHXCbZ`-b%'9iX2ei
+#FlPB2R`'jL)-0ZB@`C6$""I,Kl$3S4d`@1a3CjMHaA*1*FaUQ$DB2M!3PJ-&pqE
+#5$$BX"H(HaFAbrA,BAE"32(k16$cLqAG8'Jh&QT)+CEh4"6,*j'`NpK`mRdB,(U
++B"B9bmp"NHFJr(3C$!5IKS)[R),T@5aAGLq@cd,aIiB@bfI#LZ8lSH$a"TK2LZA
+Ec$")f'hlBD"%Z3N''mS(&mY(Qi[P%p(&XZ5#Z3N68L`V5+4b&3E%GZb$@3H$MDi
+!$)MSJR"A2-bjBMQZY9Lq,keB2J,PMX`YPMId,CEAG#Z@eqE!J-"VSF"k&0JA8$B
+9KCJ+iCqP&X[,)Ial,2jpHaJ3B3819m&3@8#Q5N!k`I3-b)'iJ$`Z,5#E!IhQ9TL
+DJ$aQ)mcmJ*bh$bB$TJG-5%!H$FE4R`INfJ$-6CM*!APC,Fa+Q0N"Z3M#$`"a!%*
+-%'BD%C!!#qB'C1pV!IRJQS$m9'T!cZSIN!!IE3[)k9-#XJ9#$Zf!53R)$GN"qIP
+5Q#%"qH64J(`+R4F'"q4+-0eT#XJU&(8FJjNCN!"Gkf%J3#q(k3`c-L$(V3kJ-X*
+J`j()J,`"'cEd#mKVHJINp8K3+K#Ir33c25"[KH*EV3(jc48"1H&-3'l1JpN1dbH
+!*`#J!5ZX&,U`G"d9eG1ir5iq$R0EF2%'Xd"j,6kLU0V+VCLd@AK86-IRim4X6Dd
+edK8DQA@@mR*SA"NB#lcf&'k+ifZmL5Pdf*a$biT8@bQC6bND0r!9"Pqkqr)m6)$
+1+iLr2j6#McH3!-8VAFmV!bGC625S)Q4%-QE9PYQH$VViD9q-1*r*J8l`*Xj%)fi
+E&CGMGV0ICLKN6S#c#Cb&akqRTqV*9+R'Vk1F0A5i6)hI5Xql+Eh--E&dqT25AGM
+T(&qejkl("k9+Re'KepZK1d8YGp&6Q1fC6DZD+6H2(Ld6-h22P0!H%q%k2b6MXZR
+3[K$(0,Eh)d0FaK$TU'AdZfPhmB-1cFMefY[ji,$ZBPm@&`pTL5V`hF#dEHY(GEb
+r9NBPARSk@h9UjC4HJPBTT4p4E9Q8hU`kbbLGprBRE69E0Phd$+&Pfah"H(S4Ek-
+b[21i9#IrJ)T1UFiX+X,N&Fh2C,XM@1cY*26TiJhV4(8P1C4RSR((UJSH*rZmB5P
+dEdNF1dRh19R[E8XK5dNfQB[`aP@06aFESP+cUDb)$TV8@hP8j+8X%ceI5RY0H-&
+U8I#pr&[mRDd#,+UJiDES&(Jl42l2bq6ENC18LF$jP!PMD9%Q&4cM0rL8#3qT,T-
+59LBPV%bb@CQ8SN`kq*C*BA@CA"&PX[eQGC&-CN@5,BV%dE*)1JYeiVeKRImh,*)
+f&)QjN@UcD9`ZlPiG[p[-*P$9JPSAP6Cm0H+G9p$[q5JU,e)((+Ikj94C4)Ij9FT
+ZS)-jG$L9ZD2"STkk4$@YUDLQ%$K%YGh!T(MFrYE9Djmp(PAJ1a5+p45Hk30[@mq
+IU91Yd#R+R2Dc&+rpQ9be)Pi[+CZ!bYPHRM*4I*JS%palA%6M[$k&9IQ5*q%P#C1
+F0)lpj$*1cKkKV'`U-"(ZfcY8kUUZ'!bdl9lE,",qFl6`Ri*XhEcfZD$ST2L`Z65
+XC$APPG#i)Tp9QVhA8kM1QB9,4B&M`S0!q-L#@c@$DAHp3Yib1T!!+cBG3'RkJ[*
+Fi9qAB,CGUMGd,X$ChJe2V2-Amq!AZAfTA@b(AT%0fbP[6AAL)iA#REfKN@6*UUF
+!GeE)9Dp(i$'Y@EQq1#eLK')[mFRQ)NDiVPVU+mPVHUQe&rG3H,R3h&+NAD"!598
+plBLUE-((RcZckA3flFQQA(a)bUC5h$'TX"8`9q@bBZp,i`GY2S0@Rm&bRm&aRd&
+@Y5$G@544F8Q9e`l&iSG,0e*aGP81l%GGR""PDUa'e45F&bJYem)PV5KEYEPS6,D
+r&('K954CG'X+VM-fEbB&XKeD"9+l)eJj[ipUc95X9LN9MPY!+JBiaJedZ'&'%0I
+[,6F0ekqAi*0XV@p0U"AYKbKmXbV1Uml+Eb%V2jbH5mY+bCY&HFGT@4CcZr1&dL(
+LYCK3aNHU-9V'*kKMTJP%PrUV([!QAh`*1VKKU%5+0fIj(Zcheccie63DYm1RKG-
+'3BUphLFP+lI'fE1U%8LiC8+%Uk0apKL9jG+M*F+plLQPJlP89%)(c95QqJX$j#8
+'V[j03e0p!'dm$Y!fE6)Q(EEJr0@PRjj8qQQrp$-YTCpfK9P+d)aV3CX'I`Bb+Il
+R+66-'Gj!P@Bk@8,IiS&XCQV)SLB[0AMTd%ANJR5)pk8lDqR3$NV&U)3DDZPN,9A
+@1TLVQ-98&Ge2a(F8eZdT[U+`lY`#@`daaYN&YU'$'6+k`"CLqC@fG(r4LcLaTGV
+Yr8U-[XHAF&aRFSQfp4JqLiTU'I%(#FAprZdDr0[%b)QDF+KSUdqG&[@Z6N[I4iH
+mkQAiNE0dS*C+&AUXK%Tj9dC#kbLrB(6RLkp5j+qG9A9h[ZTXR1r6CRj113+``@e
+pd%"Y1dfjkI4d,TP+k'PcPCTq2lHi'T!!aN-1i'8fjY*D[EJPqe,p"ASXTpT*iR'
++eBc%h+3IS1iUF9AYkqD,PJU2mS(5qG&m#CQVmba`IScCp8Bl848M5ij5hQUI()d
+GBiDeS01`%S@+Mi01&GJ)88I2)fXfMIG'm%#iSlkUaZ,PTF4&HGi**-+4Va(,c5Z
+4+'rjT+HK,(20UK5jTmpT()qVpLi6FcV`FRQqq$cQ3dj9Cc5LG4-hJ8paa8H9mT6
+Uh'5)hqZ@m9l9Z'#4+Y`rPqEMDd*Q5)ADe[h5afi6jCYSiaP+A8%rPP&U%IhG4+R
+VDDfAi[*)VD@M*VV65j8PG,)Hp8p8bU1eiL#ZPYE@8ZSqHZ-B"9A5aPV+Vb@h(fV
+E!EVkLREcB[(9@26k!a8XHQN!qA$4Z`"8U1LG%eq64Dq$q*4-)1'XlAKr1L8FVKK
+PBP614VT@'#pk!N6I&9q6@EGrPFK-mIQC`@qI!QG0,jqkp[pAD1hr4k%f##eiNFc
+a0EdUjK0TqFQ+jYf1QlT1UpTAh960LeYD[-d`p[[X,@BHJ4@c)F)F%dkM91#[6dq
+3!-@G%BU%@l)NTfLYPIM"GUlr&F%jGfcc1hb@XKc',I$+pC+L#9UYAMpiPdk!,r&
+H5a'lafZP(8c9YFr3[[SUS'S(-9rQ)'B@(6aANDLf&YaUU1r'FcVU!ZV$I'aS2fP
+bRI0)0#QZF5r,UeXQI*mrRjU8(VIJ6mjQ8lD*LXj333Q0,N(,c5%iCM%fmHdKXfS
+NURHkejNb0N+e9"qdUTMY0H'"DV+9jV+UkX@XR#kU9SVj3Z0#GHh8,PA,bX!8Ida
+$R2keYVVXDfe9Ae9lp#KQLkISfQC-hFR0!4#ZIS[4m1"XPG(Ni#ISI1+(&@pl!5m
+k+LAZ%mD9("'@Tl1`NS@,,24LBC%)haHaF*D&4J6Yqe!GB-UkQ'jT@U&U+rUViZj
+9EG9L(6H#BV"2GEkeQZ1Z@GYE2AL8`rP@-)mU9*aEMh!$Gp*ZM4E4pZCCR0RI[)M
+R#EcCAYMqh)9,3*!!E(mc"2eYH@+4EH8kV[q)jEIeB@'i#"pPLm12MQ'a8PAl+%2
+9$PK9qdF3SAhdVQlrD$B%IM3AcdRBVQJ(!"2EXhAlpNT)aAdEf,NGmje`Sk*fB,*
+Uhhi1c0XlBq[f(N#&UlDG1@"blNcPN@L)lZb1E6YRL@dl"q[fm(T`KLrARH%*20b
+MD1'pJCb-TbD%,q,K!38AP-3$'U)X3%9G&LJY+N5hlkL&P"d@)@@(5mH9*YCGM2A
++9AYb'64)hSFYb5iZlQY2$YIYb@N#'bEXbm,q*'`da#3[&J4)-!N4#@Ge,F%&-EQ
+U&P5NDd(T+ZiSdS,Qk2BJT0iH9!0YQl0dHr0qE'dqaTpcf*T[BJUBV6Q&Rh$B0Zr
+JKad-F*E03#2JUK$D1&RA'N'bCGe9He-@"$5GeV8QV&+l!ffDQi+RU3p3[B'+!mm
+Jm'`dkrD0A86[G[5Q)bNEDlLP9V'phN&XH"hb4MHJY@h5R4RK()rFd$+FZMe$E-Q
+iA8HcA,#p8kVEhcN+h$[`Bk04rc-hkPSQ!$C[Z'V2R)'66%"e(ZDPjD-KNSI#bMq
+Ufr2MF*+r$EeQdEZJfr*C1[*l!MG&i%DKC`8e@N&RVE9HYlHka(#VX*N#C`HZVqM
+ee(%Y5j!!Ga-$qNhP20aKhj5!XdeZhElTCG(VKGlRSJG&mZ,%*5faA%54MJYDBPG
+%QJ#HL-kL**d4Rl-#MCL2ia(L)#D,(F3FC`Fafh4R6#-QRbMf'!'!-3#Q')#Z-fD
+ZU$afG`"BGlTZG`0dRHieIQ`'`0TY%8GGG+HlRm"UlZRJ5K()B0dHD`ClV)@aili
+KPce@*$Bf3U$Mr@J"6V'I#maVIN``0UHCG(YDJqJG4fm(H0*fLD&6GkE0%QTUD80
+dqaDKe4CSYH8)J'T,Z%MrPM!G9lCBYlIZh$+CijCqEFX)-I%@VJ[3q52Q$)l$%c8
+Z,!G0E@m6#le%Z,K0K'pV"I'q&Gi(RmC8,6"II,9%jedaVe3AAfF@1V3EZ0A$Jb-
+1Re-B,+DDkMDY'jFG0NaFaPEl1YeQlbp%fB4!Zdf8V`fe`6B%25GUlIN5(JlGcYY
+e@la`FTMDU0Y#+d8hY-[AcXI1m$U3!$2lFphfL"RH5FYDSpZb1[-kKrCS$ee,amh
+6T4Y9Cqi-2JpmKlE"Z8,ER"*GbeQ13Ar9ZGI$&cBSfZkMZQdhUbblHk!l3Y5c"RL
+VJf@U[F%0E4VJelei!@fBM-llURe21HLpCjZ`0iAY"+BplGCac"BeCDJff3db1H9
+f2!V2#I"dd'fHrX"S(Y`[G1"f95X'43i)HTAUYN!r!@Q"erK#m*T6GDIj!XI$9Cc
+Q([a3VD+03Dj3"-p6LlRXbp"m+EUUfSTB05h#4-iLj#8&H($+-U6Vi!add,4i'RF
+EeGj8YC*`2)i+b0(`&GPG"*QcTr"$$YXMamAJ%6II$B,Pi9&@d'6d4NaH%+k@TeX
+iZ1cT-`%YkFah2ei#M2Bi2N2J`5V*+!j,AedlI!DlPQ1QJS!"jq%Ch#K8l,P&)%-
+Z*SrRSVD22SCC#m&#dd0EGIXK!Cq(,JJVUXkKhVSY4j5M,@He+2UF0KcPp-'L16-
+C@P3rqpjFS2G+31rG)G"lfrKQKlChX@kVAbi3pEZ%r2TqZV0q$UZKpB#f[$6-LZJ
+LA-&ZiB4f)c21JbYXb16c(,D'&!#QE8m%#YLfCcK3fMj8kRe1ATHPD2X(klD6E8,
+bbIFj@Q%RJhAE+3DITd6@UMd(PreF215G9Qh2#6hYTq'ME+I4KR*STbrUfZP"UL9
+2YEe`5QakJ@Rh3Np9'i0XYa)eD`amd&R-`Kd$Ara2e,!aI96Y6"Jkje6YcJ[SS05
+10qLfimbr(TqKfiq24"*Z-qZffjJHYiQm4#XhkEEb8)%Slmi3JhAY6ihBM`TlY&Q
+JMZ*6URQNDMXfA!$bL@cGGZ+8+-36AA@E*$)m6@T%9`#m6HSXMU5"ZUDL5@VZVGU
+8VB*&ZDVE(#c[FJ9BU"GS&pSRCN#`#ilEG8k8[@X+FiJZNAATH!5''91-pFr4fD8
+kieTjH+RL[#q0Kq24(8H+4051S%6-+e6RKVim('@fBC!!EPXM()bf"ZfFY5)VYke
+Gai*E,,N@V5%c@NRVd@Baiakk,blUYLpB1bL9Y5P5SG)i9*!!cc#aI4aUjr*fD1d
+FCDfICKED#iIerAbKl)TXIJJUV-THab["hNF4hjc(+DV051'4$Ll(fH5HF#1f3*c
+B1NjN$6CcS3!@FbXEe!L#MYQ)QSZb'c0IGqD&L)D50MS06i9$&KJ)%h92GbjEbD2
+JFCE0aUHl-Mi-EDJ$YA`K8!GUG+GT"%-9c'8SlfZkGK![``&-a5q&K`QJCT9KUR-
+!RjUI3U++RDU@MH@+YkV14clJ#e%"Xd!,$qEf2iVRGAMJFG1RS0-C6`F#!(QJh5'
+dPJkK@HI*!GaR#lrBJ'DRh+SkpjeP%Tj('db'H4iZT"!ZiL6F5#%JpC4!B0,i#`#
+TbT[Ll8Leh@N5%ZlXJ0IeH09jfck@)GlQpXI*V0U9)hmhFJ&plk*qfRkI)Ic[-EJ
+!!q9eSNB4hqh81!!BEJRq#FmR`-h"BDV0F8a84FG-%9cV4AEKQU,Ep*'L'lGDYae
+Kl[K)*)##Y@[Aj`V%HV3a[XB0Y)fUE9ffJ*TeZ)9k*F$L&'le9EA81!HZH"BfZr[
+@p-2[mS`CdXS+Xhc'M"XGDfTU"PP$V0D"6ZG8Uh@)X1Lr)IV"mf$[(ALM&8`e9QX
+`3`krF6l8DMd(4(b`04M)N!$je[&r)6@I6R$mMIqNKTe'KJJKLd*B$,''Y'1pTG@
+)EaEAe$a3`e3B!K3dZhqZdaRLG!kXi"JiTH8B'qkZ%D,[UDQjafkh$kPC+)*!,I$
+h'11pLqhXEh$0r8jVc4$r%S1'3X*`Ch!&dphIER4#`0de)l"pF%d&q[k4cZ#DJ8k
+VN`Ppf#PS&9)c,HbFe6NA%Thf%B`XGl`@HRQi'&FK8[alr'SZB2[mbh`RYJd88U$
+m``*p$a3%i[l[a1JKG"qShVP3p,kT'-kYk!ak@$"&9LeA3Dc"GbbaAPKqde&9&#M
+ep"lRHi8pfI'16P,M!1Q#X1HNeekqjiG,mCFZa8Ykr+AZGl#rpm2#`JB-[4b@q%I
+TR5Zhhp2aqX""Rl-JZ6[1NAD1l(M2b'($T+dX**r[fL8XV223i-X$VPdIf1&@fp9
+ZYhTh[A,pNl!`UAR+$e1Q5-N`S3p23IJGJR3Kc1Um+Ze%H$)86iVGpRE%AIp(rlf
+p9i"c66!$pprqZB,FRpl`eJMXM98hZLIpGXKVm4m-LVr4+IipK+XhRl"qE,eae@Q
+pmF1hTdCDjpjB"H#imD(6H[-pqbclC2Xm+iSib@TGB,A1XIlDrZRPP(01P&pHHHa
+$9b6P!FR9mm-KG`qj@rV`0a@G[bFqmdV`S2k*9r&629HZ5j0l$T*5T4U8ceT45(m
+G)MdV"8PEZjbAVSNbq&CBQehDBRr@6[krfb5Z&UNjK0QmmD'KciD'GR[Lh-[SGPh
+je`'*eb@(X1Y#TG43IrJ`Y&GScm6VV`,p9ZJRLCmN5Npm+Dhi33e)dk3Nb"XRCGV
+#L066E9IDK(`!!"`4384$8J-!,[%293eP44%!-@AZ3lpYEjBjAm,,$2Q'N!#6[)3
+jadbbiC%d4b8Z@4,R-T+a4!RFI-R8C"2*NMA'019kF$%aK'JKKKBXPd-$TDIaq3`
+X8+XHJ3'@`a8[0r*mV29i15)8T)MPYPb[f04prRl[Zf3*PR,[kAhq!4ZQ*q9"%!4
+!%!#L!4IRm4'G$LmqA-KF8)PNK!'qrQI6#bh1aZi@2YRY$6j1PIakU[aLI1'41jh
+[rIf,p4#*3eUE'RPf1QaCD(,k902TFL3G1!DH1-f%9(bZ(jeRSipam@1B@&8)ca,
+l@K4#KqjM"FhS[%2lm&%YIL6%$lq[$HiadFdM1B##IR)i1IK19aFh(#8A*#XScD"
++5+5F10cV-!jCIK@ZH*QhAMX5qZq#8!%jU8C[qH#CpDP@ERNR%&Ul0d5Z3pehHhX
+G'GH2l`fdq9BkPBelDLhcZErlar5hm8,hMmr[jp[lR(pfD)06rH5H+b($6`24R%"
+6fC39Ie99C-IPPpbp(M6hSfECJHp"9V$K`0h9cJVVU0'UF$Q,AT1KX&pTNN("C"P
+HVI&U['*&IV`q1a$+jEhEii)Tk$QM")IDp)RY9STGB@d6`m1-M$)#4rd11'bKN[8
+l`ME9AlpML+ZQihYmX8"-hG#NK0YpCP0qh0[iN4cK#8p#&[KR(U%T%Y@`LPKC1Im
+-4D(XhDC)lel2DR@$NUBQ'V++&4MAaR4SlZB4)5@9#DhmXj'`48dJD@A9"T'mLkN
+Q`eBbP`3MNjTJ)"91(56-r0SESjcIEAS$)J@QmVT9'CmhqXcK(RMVJmN+DMJ'Tla
+FUj[PJ$)R)'keH$9aHIQAIE&*DIMrH1'8RRA&NediCr@9qklNPUdZJ*YFU!r[k"q
+E&9,(fq,YKZ31ZYGbYI0C(cV#mRJU+I3jrk6e@U4P2IfHD8cI#ZIh!Qce1E80DD`
+H*,%kker`QG80kK@6hC2`pSE0fX6Tc9a!d8X*51Y@(K[4A(C-bfSl%RdDDphP[G9
++P)TIpXP)h,@VHe-4II$"CF5F-`5+2$4*2)+[)ZT&XLmXAKUZ"$krq0*)F9TpU6i
+jP0m'*kJ+CX,%@c*6`Dbfqkc)DPU2PCqa8USbUD61PU%a3("NT%HG2I*0$KaA5)d
+KYGVVL)p&2DD#!dX$S68&[AYArAUi3Ndp,iFF40!jKdG3+k)@0A9e5G@N-&)4&F)
+9eZhI&K4GLJB`f&Fmq0b+ja8fU1cFLUZ98S[AD(AQreA@kPe[3[pkm6&X6mA'RhV
+EI&C[Tqr`I4G88rh$Xr+4SUP)4V54PT&N"4))'9a'-G3bJP6!&kQf&f%f'U%%p3'
+&0U,NiQJ#9Y$&FcQZVG#e!pq%+`!mB53e(&1$J6C[+I4P+3*6rA12I!Jb%S3N[VC
+#14"ji0G$&DVI6)PU$R%PdF!5+K$*%q5QNe*JDQAcAP*%eApICR1D!6P6ECjUVe8
+effp(hM[be,$2T#k)YiCl`hX[Yh1N8pAeeB)%9+[M-LP8CfP%QQD*!5RC3-J$SYl
+fYNRT#%2&80ZX,%q-Z6"ie%mI!JqJ)j35$SCd``5AZlLB8U"da)Up4Q%Fb35@3"#
+)88"Lr$X$BerEmR`bb%JQ&"V!4*d*J5Q2GpFKQHH%N4J`mClqH*1k[pImR"B*T[*
+RR51C*T[((`C`mS*YGYiN'[`F,T4QB[SDkIe'5NeD#L2hpY@C-'3Rfdah[a,4lbE
+%33N-5F5E6!"+h*!!4N'+"F2rfPIRlLmHSL[Id3pa"BNpRX"209e+06SEBI4Y-!T
+)*-EKISCaf8E9Ai%Fh[d5*Z"GfNRDA!chFL3lHE$la`$'9QaNkijq@N`(M'6MPMS
+FV3@VXZ)M9+e*YB(e9'T`bfp@',F@)UddZ+9ZKA(,aC8ZA+I(e[K"'Jlfi@$bZ21
+$0$TSF'kTD8#([G#fj49em)1ddkM3"SX44*Q3!""Nq"a5JcYp-pkEH5KX"VTVYLh
+K&L5N!V`['JYEB6L189US0UD2m#`0D1lI3+$D@"p'%UYqNK61CjeBb)A&[5F@F[q
+MB*NDE,PNFHdIE,R4mXR6MT4JF6hY-"qCliFkq,@*-ika`CBpP[pB2pM5E(QRlSf
+a#XYre,da(&cl"2dGHq,1JP9[M'HPr-eGU[8VK'2JY3&-+jXl@)@IN6'lakaD!3E
+0a[V"'CEH,Umh8ES)U5hRRa3)2S0EHq0HVjA5ZYK816RSfY8fa"2RKpJf9e-#%B*
+KqGC1G5EUp@R%K4&DU0U4'8Z!IDQP'rp9RI&Cb'b89MZ6dGND9e1$cPCX@fDmXGZ
+jXIN8+MGH2hV,a[IUrcpl9BZ!A%[*Za05S!0$YD4`[U,2HGYmNieeCl8PPF[rZ-6
+%QC'1B8%Qd,F(L+b*Qr1#Tq`EebcXfRMX9!FQ1DCEZp#bXCQQdFjj+JT9#LL$'mr
+N+Ui###e`fiVXDUZ`me[Yd@hkU6rGfj3NB%"m'ilSlYDf)pa8%5Hh'&ANeI+"IJa
+ZU)U@91b'STJ'Ypb'3*Uj9U!aQ$4E#ZFS'1#3!)dmZ,A3hCpZ5H%S'F2K*pJNFK3
+2kciTR&jX'a05P8LGF`dFE9mLiIN[A4KZI2mCBY2Rh1HQ)BB#,U&dRk8L6BcdH"G
+)k8EciNPf39QkB*3(pd[,)#kF-2'TIT!!&X"e&*0IZP,h@6J"0ddC,J-@`@CQQQT
+T!kRke(cHAAS6Sp0d5'S1J+`iC5Yph00[)&35%Lf&1Kd*LN)RPVmAYL36,5F4'&"
+!fi#Vc%+5AdC&rNIS+,EF&Xf"%GQ[dj'cJaLd4*(Z*%Fm'Lmc$Xq0AL6@9F&LXlL
+`a5PUGT82Mh-b9"+`HBM5`ApmKS'K1Pj0V!N8Tqc1eQJ63dTlPH[!Y3q3!'J!%R*
+c[Xd-qI*GEdrekb9K,P+A5ilb4R5j"X2KR9(hHp)c*Q'q,iVQ'i&%VUpe&`hK(8d
+m-!66dS(1-pX%da*IfKC*,Q"N`X5!q)[kf`9d0*Q%q"K!J12NrXQLNcHcl6Z)Ree
+Dh[)#$+T+,%$S,VKM$i,&Ye9B5'DVMTNY%D82CT(*krjD9cGkl'!@K,h&$q)UZUH
+lXh923A'bRUT%-ia)(N2S`DILp@*kCM%-XqMh0$8'G(q%-"b,qr'bH+3%UQ(+-rU
+'%NB@D+rI6"#qJ*UmA+T4!9"DY,)S0(2rbS3EG$@IHNfqMS%Vbhie'9Bd&NGMQ5A
+r)GY%a059A8D#C`S!AS'3!)Y*2bdU1[2kKCpI1K#JT8f(,@Q,EH-35)fYTLk2NPS
+S,He&9cREPHfRT8Xh,IY`-ZBVmclZbimqq[0,(Q'J*YVMdi44SAB1C)jd22kT1QH
+9BfdQr5h+E(lYESIDHIc55'a9`GVAk'r4DpGNhPh`T50$`EC3UQXXh$P3iqk29LF
+V,$HMkekZ'`SXJ,1ZirJPVI!,ee+Z5qN,@bN5,R(GATXaeVfiHh'[,D2%T*lI(q2
+*3HGk-0R8Yha1MKk)+"$J6UKRk"HhE$lSSFf(5N#i4TA9k83(VbMMA$*&I"F*,[1
+3!(J9YpN2)3G#d`NHX[0+K%CpFRkr3K1G!00XFG*a&*Cf'jhKEUFcB1TL+0DReE`
+cemG(Eh&HR8c&3&j`9"SfTe@UR"#S%N5FX-bhJF3j)6UB5%h)1)bG&b6'X89J0ad
+G-(A%`m9-r-YTi!Kql2ID1)PM0[l8-"U9UYkLKdT2i-mL`V5*C[YjN@KrcP6r3S$
+6U3+P%RT'rAEUZ'NS0EkK![Zm+14a'18QCcM$PX*9Q@2f,8&+EUQl@K`!b8+E-q$
+'))Q"d48BG!DS#IfjcNX*I`%Tdh9bD-`[Eq"bGLfU+LE@b6c9VQ)KN!#RRKMm1aK
+%Ak@UA&QU%SaFGSCTqESF'@,pICPKSh2i1PGd#'B&dmC*-"%3+"0!eXeeAbD)'cl
+Y3Y-56&BjL%8[%@A9kH)h6QMNVL#I(&BMeR`Xp(f6&Z0b2YVi1U-Q'B(K(AM%k93
+(qSdmp&iH*h$!'I9R#@9#QlhCZReJ-$DC1#(i1h34+',pp`TBa0JcE3"C4-G!N!!
+S!8%#B"R')TY(PJJGk)rb8+YK`#&T`1FP!cjhK[dGI24l4Gi36C6&YT)#,33-'hq
+H6kINd)-EG!G,0Y3rNF+'EY$Id0r4KPkpdJheBb2(eqGL8qImjcB9SNKA[("-k0d
+!FXU2"0GAhTAp[ETkDS-hCVrPrDG5Ap9`LiZ)Zf)M-ZD9A#rPYi,K-&q4RkkSP3h
+j&KFPGh@kaBjS3MVd4KBl8K8@e`JlU(--"@F9C!MEXSaMUQ!PdG`h!S3FX4aH%H0
+0"S485L(N-03bM4f%#RP[KqH6+#pr&8$cAIHZ$kprc%eeE-SXqbmFlF+469m%238
+4i[hkpB2[emZMP8,'G'T8M4&!ZlA9!Rj#Ajh6kDUjGC51MD[dh868h08bBjbN$UN
+DkFeAMr"#RXGITJ#SDZR3Ci0K0jp*QpBSPE0G&16eT52HfPKTbCq)b&dkR8FS4,"
+CbUj9'c),JrGX0YR6@p'93b4*qQ'3!-)$r@![ih-@'Dk"'JTM3C2bJR&c+5H5(`i
+mG)SjRmmY',hPI9FCiZYQ[ch[0HhRVJ)&KRHfDbKdlbYR(2T9!Iqp[ej6ULTFF@r
+0pD8AK6lq)LA99,*!$3AD$#ifh5k!+f8)G%+U5qC+GZ$P)!*`P,Z-HCbkQZB,ARi
+r`NjNIXIAr"YcD&1(E&Hi%5jDIU1kJ*VARqYm(%liAGi&8*A0fYZEiDCmd-B#E5,
+bHYiQKq+e616EjE2GFBiUaV'T9Z2lpIIRRq24K(3i[PkQMh)N--V4YAQJ8'PaAmS
+HL+%E'4llkK8K$S%kUU6%`B3+AcQZ&XCjG#KP(f,,([c*+b(G340H8%3)9&@ACiI
+'qDSVaG0i(Q8(Z0iia"ejRhkcX*!!!deVmaLU3"9X2K[%lc5SP`,eh#qUCrN29-p
+bK!ij5e36Jiec53dP`!ec,&pr!XB(A8cU51LUA3UKP%""L'db[5U3!)LFPcS9m[I
+p%hi1"0(b9X3h6I*kDaH"qiidQCVcer6U&qHb!T5&&EH*KNT14Daf5K$GN9E,$FY
+,QbNXchbjmK+@pqbPS`IBdBZ-V0i1E&+C2K1TdV1SC'V6bqGTF'jL63%0Am5'rlq
+21ea@+U`Faj%l(,@F%K90kmhFNQDeda)S'6qBPmGp*UmFMAhIcN-$&m5M0100bF4
+j8RdQL2lc'$9-5LNNQX0jl-VhCAEFmRlcGDlc%39'fq+!f+'4",6b"p`e9VYXjjG
+*YB[Ze(I#L!'Ce9k'(Q%cL#249ViIC*4pPq)`"(EQ@NSc,Q,*)J-TNb)T,,`b+A[
+6i9"0)LN&TjbDcZ84XkNJlYHXlLh`l&,0F-RYcTUC1C!!V[dYpMdTM'!jNM(AUL%
+@NZU)Tl3ferCiUrEmA!G3l9T[k*iVQH`c,0a6NqD)#SDMNG!pVfehK)-dLETGRHe
+Ykp[p5%IKq%6Rc)DLR(k2jf44cXa-ZrZ!HdF'5db@'d`S"&QjZ`'*%VK,bGRHF4[
+RC6P3!p9RK312"mZ@I9L%4dc8cY2[,[Yd+3m+TUeF4YSbTTU2IqL0q3*FIZ##qPN
+cA-Fqfa%HL1cBUdCf1)V@qIbEpUkk-"a4+qr,R29GM"HeUYJ1-(*j,E0DH'a5m*Q
+MbP$%QK89!R$2RpYlB-mM(f*5[fN,&c`#820*eAVk"L4'j"I``-ELap@&&$a,X)&
+ERN6p6+MLCmeB6YG3(@6JI,dp&kJ)pjF!jrFbcT[f)%BIhB+EZ9JJm)Z9j)*cpmF
+Eeq"MHGV5DS6CYGl6#A#fCYQLeb0peXK5E!l'h(hD*4)#00!UelP`FF($$jiaS*d
+M*F'lrERXbBl#!dAD('5#V8J,jdj+N!$rk[l(AL`jQChY55FdaBE&`[1jr#d56Kj
+*d0G3)$'&9$Zm%N[llYcFSZbFd3-dNTMC[eSRP@ER&18Hc8R2034q+j+CAd+"[(&
+jr,$N'(9`*!+AF-9()%P)3,Pfh!3RSLH'4ePd!26eY1#bQbZdZI(h8$@,'AD#p@'
+BSbHEEDP6A$*)Lf'58RK030UhF$FIJ-@C$eecSj,q#M(MBTk&a!+B4E1eeHc$)eC
+FVG@`MjhL4jqiS&fX'0-fXSpaFF#`Z-!RINa2dDX*j+&Tq,I-A,QjJ"hif985Z)L
+F8JL%-2@XBHX)5f$X+bV8Jq&93BLY%&**(R195aIpXf,KIE[aFY"V0L[-CJ86+jK
+BSC-91P(iJc62BqPj46hTlHj#YZXR$9XMTBX)3C%BQXmRe0ja"FQKTm2Q2pc++C`
+eJMBa`"eC'rG1),!qcqrEX1&@hK4J!UeVEpcrHXeC+eGI[p"VAf@'d3TP2+"YFfA
+&`hP+B59EA-X@4l"BH,h'9iHPADXki3L2C-a6@5*`2im(*[DV2+qbK+hbCXhV04"
+eQ&,8QUEk4IC#aThUKTGk3+MCR6Qb!@LrAmhJ3JQbIeqkV6YGfjYcp-$0lEP(M88
+-VZYljZHQrmLHRTd$H+m-jaQDqY+"MNNNq)#Jb!G`Q5QeCfFSRa+DfXTYMZb%'[N
+E-aE4DMAbTN-UM-lMDYL#E@UbZ(BiiKVmY-+X4b`1LiYYq1i8R!9U6#US'ZNMI$1
+IZ1lGNQ%+IKV*f9!bb&TeL'1Na(EZ2*UaHb9hbf"ELdG"a&"-+*lX*F@626k$NY8
+qjBAM$-+MU($Nr[1XSH,$cdH['5mELdJ+bR8'4BYX,PDd5$d8V3q[9lJV@"Dm-43
+,[4Uk&0SAI#K5crl')QDm-RdbZGj8q`LZLBF,3TDIa$JHUr(h08JUK1BiMla+bf$
+6lA!kqLAbrZ9,Nj4'DedTJd4I`e5rU(3mdLT0!bB#Ba)b-#%@5DlDUdiCQMH%T#'
+F840rQFG$!8`l#+DkFKqFdrLX4Q2HLm"SK$b3!2K%c)4VrZ)bjDGVIMqATX,M-"e
+p$Ehj8rhCad66`%1r'C)C#Hhk*(KY*C8P9r2aNXU%S6*3A&PG-TLV`NLNH(TFarZ
+@*'KmFRImUQ!!q'`!(J9A*[3fS0S!MZ#D(`E!(cLdRQeGD+9E0r3@a&6VXC3f8la
+%X)qfKQh()KTHDV$Y0-,@["DeAGbbDYhYf,*UI'Td0f(,k!'%QkJj@JTSLC8#66,
+NR0rTNcmHiT!!di#[d%294*8,Mr`J4J-'P*frl"L5[APLm989L(Kk%3p"A)QTA5B
+)(r%4eHje,lX9,Y(BfIP)L8%8%Dp!c')%-YE96$0@3c#B3k8l(%Q48j9L&m[,3ph
+X`[rF9G9-lXMq%B3#CLNrMT&djh'$L+B`%Bfk$55-B4$$RA"#U%b-JGJPQCD($iV
+1C%S5+K"-mkA1FC[$Z+RB[HY)5X6-2MNlZeGEG1!jch-(MKTk3`JRid@&-bIe$b3
+LpY#MXH6UK2"30YJ[UHV$pGLSlFbK[BJU4PDE("#N40Fa9ChG6b6"D3kjYUa(Ej'
+YiaM#jePhBref&+,QB9Xidf[#ePIM@R[Si)8T&!r5d$G[5XU-aA!a8`S5Cm8[T3d
+`2)ClC@CQGhC4)Dk3!&-dbDAZR-4TmcbqMm[QHBJaprDG0KKfFhTfh,6EU&h*IZ5
+9#&2-X2[%%(XNi5)5dNdIB4h+)KMp,Gabq@EHa3@mc$b'Kd(,S(j!(h8)63dSRc3
+Nh!65bdUfiM'*#-[4l-Q-SKdP9(mXh2KK'l@D'L`Nr$Ap'bCd('D"6'%(`(8'U')
+6Zk#[G@FJp)QS#e'[#ijQT"GdC`b25Y)I+KDj-pfC-!0Eq33pHNS$@YmE4`T06bL
+XIG&Qp-8E"4Y2'+G4N!$M6EffH"JrS@MeiENd[GM9+3BQ(m@)5A3j%TllI$hr3-F
+!`!Qmkh)[Yd"jc*FlZ6XUi00GPDM"*A`##[($L-N!!APa$b-Q'i@TH!+%61,(bY4
+P08h*c%D!GqNVMFFD(C-Z2*!!kE-N&F-##9dp)mR$$)3-BF-p0+6+j649,XGe5mJ
+0Qj5,"diIJ8!qmBp&21(EbLeRPa$#i!@%JE$D*5Xm`%KT96X*l'I4`-#"K4iSd+h
+'Bmd8I)-+'1E9G#K0M`[G$56c@l4!-SQm*RHrSGPT%(NC-NPiPRY9p1,mQA,HBrN
+lRP6KPVrVk"(",`$15EirQFjlZ!f[!Gk&ea5hi"APjZ6R009PiBfCQ4cL*+P+-N'
+)aibR"U3bdbNeT"mAfbp(F`l-*r6YBS)f"N!aJAimASCAM0*p6+@I(qM(jR1%)C8
+K2IrLX+f['@TGP!h91%!mZ'(#C)3HY[H%mJ3i)CG"J2`8VYIB3,qRe85J1!)h$6k
+mRk!jm&ZUk'Z)EP*0KZEpDc-cf6m#2-5'm$`@Q#%ehiPCXfL-jK8E)h(BC!C"863
+3dJ#3!(f-MQZ)k9'4+f0V@1!G@cR$'Q*i914)3qkQ9*3*kU[CamaNZEkCe25&-hd
+'-hPhD62CQj)-V@C6XCN-cdLKJ,mAYfTQkG(*QD-C'HN(CQEqlf61C,Yi$AEP@E6
+dq'61I!1UP&j#L#iYfEh5*DTaMl@[J5e"BmViA2E4R++V,0NT,DREV@I[$'XiFeS
+i@l3[!6'iJ*I!B`XY,9SbiRfl&mr-j"E&RcX*lM2aM25P4c0QdTFZ!4-ZT4h4N!#
+SKCY&$54j@1hSEN"iQd`TACD`faffbfAFl9P[[5!IjRC2L(hX&$rb2%fU[8P"d+!
+Ek9&%%K82""XmVN@0"1DBHbQ1IhL"d$&b5V6mFN%m*UCUGbZD&4pjeXQYr#A2lAN
+mfU4'FK15F+4TY44BhVR'S@fqaZ%,iZQbPcbVe!iehc!&'l4,HTNdRK+@2V2e3V6
+&@L15R-"3)K`9M468D#pHbUk53191D3'@lL`qCX[G,1eVp64Z1acI(&9-NH)V5La
+am&I$N!!r'0#&kGX-"E3Ic5d5%4lSUGe*SE))kd)J"S8bKZB1p#0`GX`3rQ9!1cC
+Jd$N'ThQ,IT!!T9LjYFULEkY8I&UPiT+KJX3,28C[P`5a1*eM,2K%`Bq-8-'548(
+UHMA4NN-@NPM-BKFGkkHhmE"Ia&@3!$[RVK,#Y4'ipH@F1AG[I0["PK38ZaM*m&Q
+@8,ViZK0h8-"FU"Z0dB(qdJ'rhp"4X&5`UjF(UiDlXJBN"!f%eT6"Y46'[fj4I4e
+!CEqh`iZ+@IN(3Yi)rU8&`Lk55!$cpeUT#e2L!X31&B%pNIfFKBLdHq5(d[iapl+
+GKp'KUUL-S9)`j@HI5rQV"'k@L*HB9J1MfQLL%-P`f0ca9a5XfH8Q+pca'S4$QUF
+bl6GS$kYrHI0601,-8aHfEH(K!i*[)3mRLD`&,%85D1@Q0%D@aP6K58$X9NHk+"6
+`,2j9KYVjC+Q!482)!"'!X!'PN!!hDN`"(S`["FS'ie-SK1+Y30P'J$@8T+N@iM'
+1j6F-h'(M%AFr&N3mK0iK6`V"YiN!MJG[jQ&HKQDRQUa!U%+C*3FGT#aYdJe2SMX
+0&`D*3%8S&6UCN!##)FPPL)A(J'B)#MJBkPl#'pQRKVfk94-*FY,f`LKmBplDiAZ
+LEM6cR80elj52&MkalhHfdCUkTh%@Fhp`b221k,lMhGZ2fcj%cF4M(efdeB`QE#e
+CSlFqAc[kj*rZrA$9RrpfejQ,&bmHH[r1dEZA2AVXZdh22*krr2FfZfhMSESpYUX
+2,EFe(+UcG66822hG,cHh2(@miBfIAYN+!!"(DN&%3e)$!(VJ%&80C&B"%$%elNA
+r[fh1-9FC-ZaLV2ibPQ84RhHKLEA%i*JLbl"UTU@'FQ#PX&QLXN-mAJmIElU"2'q
+!jP$#5HQjZId5QT1U9#A2HbKI5h)-d)45$YHN0!&+%mSK+D@%FJNPKSTlrrjq[cf
+[K[6fHcr2rrIc!"ZYTbJRJL!)J%!dcjH+4h8k[-6P,8i'd"qrJ-a9XX3A%@"*9Mi
+G6"K')#U9T-H5N[qrSrK8*6e3YQRQpCN2TE65rT*pdNPT[mcX84KCHP-9P$&ec,!
+jZ&eApN%NBIKkqY&j)8R6&E0+@UKSp"Qq3"`r)5Jc6$-[J!8QJm0L9JDdi!)3b[@
+Fq8X89QD2G%LHM*2)H)kDKJ+4R$UKaU,-SPH[2RP#K%aRSE6TPBT&A,)(r*&L)!R
+9#0!*0RqR51iBQmV$T%`M)V`kjNrX0bCq2ceJ0IN$$JaSPkk)d2aL%ESH5Z`20Yp
+4T$dCl&MJ+pb#aM%6KJhBRdNhA"Aal-TRjdPG,LaK@DmXkl&F4-Yk&bk'5-JeK+C
+k93AcXPk%-'&$l3RGiQI5(4d[&c&*Rpf4kJ*6eH2kXH[(5R0T8-GCBR4NGUGmf+$
+8&8MbF@$CR,)emB(cdG5jpU[a4G!KYIZ3!&#YFiAkNmNN-kGY,$5TAQKU+ehD`NU
+Ab3a4jNeQ`',`UC%ZI(lb"&M*PBH`U9i%TLeA$*AC8K*J-H4-@N044,JU+l10p5-
+G6(!Pd6TG3cE51+rS6TUGk0*VU)m$55ceBG"H'V6CFP#CP5RDQXCc3b)jq"p5ea2
+QbJaD(*U`U$AP"S#5`)EcJj9J!Bj0RJaXDKMLL3Q4DVq,YeKEH3LLbeN6,K$30p9
+@mVCk5Y,j3PM-$KbB!(UprrI"`@+l16JS'aRp68bSNR4-chIK)XcJG3B"m"U*cDR
+'`HBd#h'UU%GBES@C[`KHHP`3a4`cLqh-IQdrS0@m&)TRI`eXE"2q1d5,5##I-LT
+FTVSIQ'+2MJLM"Y(pX6T%8iJ1a#4%@a(pBU`0d5&%Xf0f4*1)TXG#)d#3!*BAFi1
++!dJ#$)kY)*3T8$GL649@QK,l`B$V!fUc5N2cAldH5TN1EI-XN!!ABeZC*CrkAi3
+QNZk"@PPY5)JIUVpQ'R3f$ATMa!VbQj3KSrpMQr$(($PA4A0-2kpB*'2qP-PSYcM
+J!DNK%(FIdMU"SFeCIERa%3J4`SrAN!")IJmCIl#@pQIZcG`,SDG0-bkf5qZIQkS
+Vdk`2Aa&Y30hqXA'Kqp$-8Dd[XIml4BHfBD*m+EfV46PmN5AU#fkGI$55b@iU9[@
+"YUBk9Gpd4AdrZr,jF%TNTJIm6rDTHM3f8f2cLaUEd6K%M8-[DKb5kQ33F3Jl!8U
+X*9@RRJTBQcc1b4&jFSpkbRe&A4SQ%$0+k)&5dK"T4P%0&H6Uh$D"!R)S&MHK)C!
+!41'GCLJbaU9aR5lrHDF#!N$)a6ZcZV%j3i()iNKr4*L4H$0XNrbXmJ8,cQj-5Lp
+V2h)j-NkE6N2Bp%4Ac[(&YNC#Zh)PIdBZ!PDcp(,*4kkEmQGXHG!cc5H&-*fDZ+[
+m'9XHFDT!dLa*#m"a'1SpRa,$lDcpLZJ5SFad-0HrBa5HLi`#15!qPJG1H#Hr""3
+H$L$mak$U2rK,%HVEaJL@Pl5q'Bh*+k*G*!**83b1LP$MED[Y(L%&((Jp"99[IVl
+(M[8$RCKJYNei+K$(kq%BG`0-UI%JL`LV8bUffT,dL2DBPCDZ#*8@ila)KdJmL![
+NjU3!BT8-pk(!b!QICH,2[dp%@@#4"rC0R$V-,,6`H@ALX(ZL'4-e9d5#96+VG)`
+D9Tk9Qb3d19CI-N0&fFB,`NF,4Lc%JfC[X4T2VXE&iX%NIi!NUM`j+0N@j-N1QXb
+N8[(TjmmRla-A96eHBfScAMI8)E`'e$Dm-Y8@1&E%eABJfhr%`P(e&&iPDMCH4PA
+lf(f3!'[1iG@MMZ-98irLG9deif95ac#T9ah&+k8fiP@RAX4J(5UVcRXSfDjH#S2
+TA+bkk2-qJpPPYRe@JqhXr#Ld44YrCr"H93hddF44Sa#PG$%qb%8(pDSAj3XSaie
+"4%JCc)DLamad`BKUaP+GXZ6#8ShDXjZhdJ[LDk"(e1dfUiFa9&E)D#S1'30QI"`
+2AHI0K3SFUd0#YfUh1940"l3(@SMd53a4'#SdaRIRL9#S%*m&SIZ#`IcF*mfKBCP
+S3!MC!B10G$(e&#H-2*ak6KQZ98NF([!qp5rbJ1TIm2NVp4NH-,miG2e*XhVmb4l
+2*3`cl"R"+qUTCe@J$9%-+Q,j8*k!X[T2VLVGp-CD,UVP`&D'E+KSF6PH38$8hAY
+`K@lcc2!B)jbiaQ-8b9E6QCK9,YErA0c)4ASmZ"!0ISM#CESF"&[pKLV4$,(k(HU
+mCNc%4(X9a1TY!20GmV#eKh8VQ,NC&lVPVl!DH`Q,iEM+aJM%EmN2iAhjr*1hp*,
+RCLl%Tq9j+Jrf53L(V0$0JE2$LXMqPlH+U,6ri(B4V8[qilj8adB8RIKTaK$,Cjm
+mM!kCqc,hMDdH,M2ei3Sek$C(fQqrqGri&iL2!)fdKdeA4%FJ16DH$lHBGMf"MKq
+LUa8r$[cBmF20caY&I#Z+jVD!#`Lb$F&8`m(81SmrJ6bUG)ZD")+i"U,m&4'rP*r
+[E4*"$6*SH[`d3h&!L0Lk#m%jqXTpb-V2Fpe(5%'b$9E0Rrm6Jme'Xi3-l$`HP+l
+jCebc9qi'0XULi6Jj#2c*1N[i!5)G3*EhLD3DabX1P)QA#!(Jp"5BQp8@[)BSU,G
+48'p"8"r@[81!e#RmcN**&P[!mTdD'+m&F1PH#qVQca,4Q0k**)eKG(b0N!""LT!
+!34f"G+0k,[2)m52"jSfqf6lM964%U6P&c5MJGR0J+m'V9ReQ0hA!UdRpbpqZUL@
+ke`0K1E'$cIPl*A2I0Y@)j'V8[6kMN5DmLFmkYH45FljhI4%e[CR[6CPaf$i6J$b
+@-X9M83dF[Ja&mh-,`jbK*[!--AKf3,d*N!##bP%$Y`GffPQH$`E0G"1#4NPkS*Q
+ATD3d!!E1p"Q0r*NbV*qkFCmbH"5$G`Epmh`(*JhXRqFF'!(B3iKb6e#0fZG!G0j
+pA*8S'bcYIMqTiM0+Re(q0$UNJD`MMf9LLKb*PKal*PIUZ!N!32"1Q+kUd3"BeCS
+k9FS[9K0BM,b#4Gem@ScL3p*9)C1*#AIk8JFhHY(3U*Z2T8CGeCfqpHr1hSG*RET
+"kY#*)&BFlEK@TAXRGI"0hbd'TN8SC*ImIS@ZZ0U!,#1"(UEiD+$"QdaDE(rp&k5
+'"c%3N8%#'9T0ZF16L1"jc8N%"T!!)J!)6d"3AqiBHVN)!D`YJaf[CY0V'lp#0i`
+LY(HL%133X53ki9UKB@H4adPUc`A4,KjSQA5SfANS5'Qr@D9Em50d"[*BT&ZZ*)"
+G'ZMEUY0*rKQ0'8G5!bDV%`eir0M1e&J,&BY3f3BFFZ&bk5+jcb`haS-*MM#DQ8I
+"$+KVN6%qXKkAQcS+F30"1m6&2GJ6LcKS1kl0`bFAj-jJ'TTCV`E6C-%"BN0Bf5b
++p)$L&!+a+&3[G[HS0FL%lifDqRkU0V,$$[qRJ'#PaD214EUd8,@fD`Ze&i%V%6,
+L&D(LU5C8`-%UG*@$9HJq,Y4#eAJp(#S-ei@ZSSX9BY2&[QfK5b`@cfK%4M[d3XN
+JYM2j#HKEQIK"2a2&R36U1j`%4Mde,1*'%(bEjfb3!!B@a5mim%dD@,)0,%dD1+B
+-,%dD@-,!fKF0'kGKEp#JcEC"QbF01U3-f[cL33RTKi%)&J9BX'kM4,9Rjc5rSl$
+'5Kq%Ha54Iic%J5M3!mMQZC5rP`Yh+YCETEV3X,0S0MCE6P'2-cU*X)-U3$T@!%f
+V'V-#PI@5i`f+(rjiZBL"!NMhmaD"BQ`k&pQ'UfSF)Z2dIL#eTJC%2iHJhmDCDJD
+k&DGi+&bb,@E0DG4p(QMHM5PU,aIY$SM1((#%lPDF&*`k-)LR3eaZjq#`Z`ICAKb
+!M(1MEMU'XX0Y$4RR@,+T26[RrV55G,N)9iVYB9f1%[4k0"i,eYpQCMT`0RDL'!&
+Q!aAa)0C`i"`,"*,Ti2E3*D$E&Bc#3i@"CJ8T$(dG'39M'k1+S)")G49*a!iMbrP
+$2Yj*@!6ajFaNX5AUH4$qH+$%HB"UG"kJrZ@&$P",h!HS*Fi$e10!X0V*"d`J3Bm
+P!CbX#Cf,K5``ZXJaJef1S*!!YMBfL[#)$ZbDZUD1IRp62$YRfCD83@T!3L%6+@G
+BqqlNl'Td!fGA,d**$PDPm+"!%md[&kA-Z$K[32m04TFKS*)jF%BQB5Bd$kcb5`G
+PaF[PB"!AITZZH&EUb$q$cleS2#H$I1K)82ep85b2!3NrFqb0%%PZ"X+)D""a)2)
+8)NP%(YEGK)!Ac$r'))KK0[-(XeEaXa8,ldQpm`I&UGYq$23H#2kQJAmi`c1XZ`C
+RL!mYXcD)3%AEF"SE$MGe01RPKHA*-8(C(+XLjYUEp-aqATSc*SkR[bK3#h@c#aP
+VS+Ihr[L&Ekl$)-mJD#E!3'PRXN)Xl4`6#*,2%2Jc3k89"Hmf@a'm!m@RK-L'VkI
+hqp%p+lYbHCUQ5bj1XD8M!2`Mc"a0'CK40GD9P4ic)dJFZA@$Zi!eTH*5LI`cc2"
+EAMc@&BXU3aeT@SfP(@0GcSNBLSF["VZf,aDM)YS91%q&U-[bU-K21LUbeU1X,hJ
+8YSlYqC!!)*Ri'F#2!6mpB+0ST2h-f+h0d'@#5GQ!$R2"S$5!DGJQ$9"6PQi!6AD
+PUBF)fmJ4h3"q$2M*C$)hkEZBZ8!J[1*H!Z!)LY6p-qZB!BR"kSMX9P,rlm1("2%
+0#LcT#!VN"TTk3CPk!D54%#4DJ9am("L!D29bm#"%&QE'K59UN9PPV&6!pDc-D'f
+U%pHGV!Yi3QB"*CST)h1C!%Z+fEQ*PeEdC+CE-Vk)iF"S#U`aCRB!4GM%IJ3aU$2
+8b%J3VqL)KJIBHY3NQ)9*D$dTLjahq5)!8FP[#D3"!bqSF21-M4&+RiM'GAaYlLl
+Lr3+XaABN+G`lp6X-4AIjH-2'T0aX-AJ5`X'3!#cHbB*GLIG1heeH4BKLT(!82pR
+i-4S[6EV1J@$L,Kp[i*G[d`Dd9&30%-+pbL,cA6lMd8QG'NY1'ZXQ,EB%*8be6PV
+f"j[[mNNH5lBXXiJZMUYMdXZ*Ki4$SfBF*,CD@)l'&Pe`#FG%KK,)EcIkY4pTpeV
+A"**K4m$rQMq`c1%`q)C#"ZmeXdD0Z0P8(Hj13+X1Z@2'XB!pM-j@G*iA#QbPcQZ
+FRHZF,+BCl'3lS[YkHZFmrIP`&cc&i3J1e$L$+LA!cBL3!2Y'4"r!mTaJFSEaKJJ
+NqcXH[NG[00EeX`#!!Ja*0Q2`L5lrQR[dja%),CB4025$,@0GFL1$VY-&9eINc(J
+6iT@chY1i1pKY`lTTM)L1XQ)!bdE4-Fr@9)5QdU0Je(GmBPRdN!"JALbid#VMc,3
+IQ@P@ANNHbMjAkBU3!)&Ze"AG2-R&'Lki2$[RlP,1f%3-FYBQCTHCm8HlF+!"KIP
+dh3UjN!!lbYQL-I[#M*HcRN+"F6-eF&QeIqA5`#rq8qM4e'V,@MBc%qj*bNa#b25
+c%N#Y`dmMILi#a)B8CC!!`pJ5E%29J#5pl%Bl1MQFRb4Q$5PCDcm(r)lcA#5`LN1
+IQ6S"4qq&iehXc-m**QH!daiG%h,bfIYd1Q66K,T6lL#GH1X,XG"P11YecfB(pic
+Ej3'ZFN%$9@KBiI%T%)d3-jeS-0*eUec+H+`!`Da9bRJb%a8H#V#CF&!r$pNK,"8
+)[HJ-1ZEjUQmJ%pQU-1EM"fTXM2N%rMIMIaXbbmeJ4iC%Uj%M(BM%j3AAMi'DJ1L
+f$i&&fASmh4KfA3@MjDVJ5"YqV2KTK@+K%dlXhhhKCN5L8%)akNKNjfbVEKVri[l
+ErbC[N6H)BU31'd`jYbGeiF#SP!%4,m%S4%4R02)4SSjjMkkV+PFD'AGGqRqq-B&
+-#3`L#DiiTEU('J#JiCm9c,%)$i,Z+I`NL0#r+ZqE-!5Mmai-)9N1JDi*lXTG2L[
+rYqS*AGUi!*J`1F@664d"2j,c(r[MhE-KkR`j08$XRqX!&iHKm&dlJmcAlM@C[`(
+@4&KFGZ6j'Ab-VCS1lD'f(`S"*UkQN!"CZGqkTEL`6a93%5Dj8JJ3dJCm)-q'SCJ
+PBm9J"5CcCMS!rp'a+q)!-R3()PI%H63H`*(AqEM31r`CI&pQed#!AJ''qA8Xj)*
+CFjfB03LD6QC0D1Y4,SUL%&jf,N$(32)SC369,ED!T%9@,)1#8KB&TH1#@DmP##,
+A1BKmHm#`hHK-%%j@*5KHj1#)M'('*8H4&f`m)bUef,(Cmaamq!I%hSaU&''jS5K
+YBN2!(US6Ia8U-fq-RG*!jK&h!*(C%`Jd!b@mh"PXIV"Bf1N`#CR3FB9pN9!L+96
+MXjIiN!$YDD5L,!(KZK'I&qNc439EJJZf[cZ(B6CeSp)p!KF*L%-$ik-%JPNRll!
+m,(N("X224@+4CJ5B$Gc+J!qP9hchqjU%YNm'IUl+m+D[F1X0I'J2MA9SqU6NK'X
+hD`kPNV`S$`LPP2ekr#Lc4"+SeL3MUaC'9L4mq&RG)LHcbUkbECDCTahj*HNb'PH
+%Y'Q+N!!'GJT8YP#"Dmk!9I8RYhK6GXSThSaX)L%J#mLc&cqZEl"#I4c$)8JDKXY
+1FA%"NE!1Pi!J4!+3!#`)fG&mcP)3H[U5,!K092NCIQYRaaZUH0&hrl[9l$!lDT8
+k-Sj"3F2-4hm#1K9(1"Tkba[b8L@3!)GEK1&G+E6$*eF+H4fZlh+(@2jSlX!p$Se
+&3DFj+PIkDiBkTq8ITZF*8fk-eGe#ABj0X-Mc(QrK4KH8,k`JI`p0-d#BS8"b(NM
+mFk(QTP#"C["rrEJA49D4C[b$bZrf`UfTL*80d[LYcb3*PCLQIe!Ch8X+lE0"4a'
+62NmD(bQFd(JdU&,6Q$4qk4H&PNd*Ce9!&*26Epk-qh3k!AaP2iEUPH*@21GNG5M
+9dH54(5@iS,c4*HQcS(Jc(3U%GTk8p0L5ZX"A[FQdKjQLVA#PL*P5IQFAGU`)k*h
+UlSPG%*AF8q8T'&STN!"[S%!@#dha3$0PNUB"I$S(rjAF+4iL*[TKG`CFk&(mDm(
+!d-"pD2QmNpIpb*)Ul)dE8"df066*iXN+&*V*f8"B'')*)dM6SCJIb6*e`N'5FY#
+&IjKZG+!c!rJ3-Q1EUFSMXUPVR`iQ-$+!b&3MF49JIdm'GNd(9!p1YX"'Td-3XXE
+XmZAijVSrIZ'Sji($$r4G9V0clXN#m+(S0[80Yb,Vbq!J3LJiXh1qDSE)0a6G@j+
+1!N$r0khZ!FH3!-)LdBFEG3q%r1*RaTE*MJ0K-,*iNY@RD6F8!F`fj[ZiJNFMR0(
+[rPG0(lXVSR!CSUTSC9h)2(leA!X(&VfT!mT5IibVG6C`"N+h1$YRdpb8S55G&jb
+*#U"p@l,(p-`DfI6P#$IE*c3E-9!E"LpYDN"P!$J@2-e94j&jTFUJ%0EBKDNTcUL
+%,V%,cXSF1,E,RH"%-"-C-DJHG&[Kd)),L5heF2l3HH%HC!!ClVNX)#lZS-il))B
+Z)9E328"'GQB&X3["2-T5a+6,DMd)HbX-"m`G8Up$BaEcKjMBfMhDRRPpKAc)$N*
+F1l#C-*Jq(B&B[8MX4q@p*HLS-3h&%KU`caQ"A[0*kX&Y3S9)%CV4D#d64IMaDIZ
+bHL#-Bm!&2F2jP(cR0Af4*$28[q56%a"CJN`+'$h5rUL*'8jJcc&+CA'q$5T&1GP
+6YSk'54he8Ur5%8i-b%3QQ4hhT3*1'(bJD2l5F6KIj(aee`4f&$QLJ4AMH&YmFpf
+BripIS))h$8%"&HBf2F#98#'3!+HCHSCEkjf!PmQ!Yh'U"H!GC@6CiR"d++"R4e5
+)Rh'@cYJj'IKiQDGa*cL-)LRUQ)'b9HUiQbSC)D1H&Q$J@1Ek-5VZ)31im3&d5Q2
+`Bb$6p$!"0KV@!R3,0$d5CAqLqfFdML#46$fhc*`i05,$a`P8TllTUdiKkeN8Nq`
+NjXA#5$"@LDY5r1Da$#M%A5dC2GSq5V#qHAh$43bkFJ@@p9[@!XSZU2f8J,$q09E
+lmB,&K'JE0[(bP-#BIEJG&B)#M36#pRj')'!S2(hp"JHXjPJE#+dMSXc9q9l*imP
+`'L4bJ"&`-YBkZD2*6"e4*FbB583cb9@FQ8"0$4C"TefThL`((R4qGRCG9k!9JrC
+5FMZ2pGU1IAZ8JCZ6q`!kPfERE0Ji#Ga-82UBf2N3!(H8!&92J(U6UR"beiLQ*d@
+JZZ(,NcVE+BP-NSH"&@#&bN@-+$E-CH,+J,YK[KY`0hc#J2ZP'ShI8Kb!baa91VX
+X8)3@UqmVKHJ3#4mSh"m`M4,c$-TC2p$+NY49pAf!5c15[80NACHAGf'TMUH,R6`
+)-RiYF#**2QP3hjH6F,4,'5$RXTUR`LQ&R8`d+@B@&+6UK0&i3#BdL4LHb3,',iG
+'C8C,,`XQQ(#9"R$)9iYTZ!-%e#``B$i'Uk"aU9&@*%,%4JBelChmUU9IZFYRkSR
+&&a5$PEJ383P((9FZ%SB!I0c8!G%e6*[BK-$BM'*),q'JQ4FJhVl24,0EZ,YeMXU
+13C`G6#MC4a409i5VkBVSD@TJmCBckCaeK%"afTCaR-i&HBXYkrKbqX%#"'[IB"F
+08c%+!5$@D1r4Q314$eSL"VFTJ4HB2M$c#@c(LS,6JDVMel#"bZG((c&`)PKQDYc
+1HVU&cL5hc2cHk#,"c`@bp)$j0Lim&YGIJ#*J*YcT2hhPUR$TLS(8jYGH&6fkD4!
+#&JCAcM#kXm@R+)2%fe-UaPYF1R8#B-+&,E%q8I6E'TYULjCdcb*3YD*"6TC)+bF
+J-Z[GPA)f(*QS1'r)b0[kjX4,@9a)2m2Bhm&EYNp`6b5'(LG[[XQ-`-0UX0j8lC6
+U51f8i"AYP1SV8*0-#FUL"4"$MVKS-Km(5&cT3f22P#"-E441UBDbl8B`K+be(Je
+jD2#aii10+EqXbF0$+&-GF[8$&YhAa-$m@!CA69CAP6N(@l@#83RrB%S2@#Z,&`"
+a!+KEkB+G*J6`30Z9`LRP8h,aUTqbp`U'Q9+1`q[GeEV"X1++D+`q(XMmb''G(kC
+Ue2'hrR4lF9#0R(#c0CN)lJZZ#L)V!*)iTNZe8mVIZSCAr9[&3QEhSQ&9*V%eL4b
+16rPD0VEQ0KU-K63f,E#Cf6$%D&59T6)j%TU2b$Ej`l--bE10#`Ji9U'+El"M4Q-
+rh-18,PrQ!1iqJ+[#-ZX0`FbU6#PJTh!jqd%,Xj9$"L`119+2bUL(F"#'Dc%k(%2
+cIkJ4R'QIbQ*)(fA*89$12hClPmAK8BIrH,UlbU[XIKG'"JaJi'09[f!A,$m8hDU
+NIY$*JRH!&9e$8C1Xb14Ahh*b[V6,(@Bd'ZVp("LCjCaN&6pFjr5-KTrSBD4eCAp
+P&X6DVJQ1cieFD8b`1bP3@DZ0J3RP@&DJQC+&QTlS2-k1TPN6%aD-J`)q-,'ASd#
+P3pQ9%-5d6q8&$Pd!TjLMIrf[@4p"b%CdGXkQ0'60%(9Fc"S49Pc+iFkkb8",e@D
+5%ipK!Cf(IRi[!fG*qUdNS4b),j,*PRc%KQ53!)3kbMi1FJ6l8eQ4eIFHQFVUrAL
+Gq1hHkhiYR%DNMYrZPE)H[#Qc53,edQ(Y'BeIfa20@Re6K1dp`K`lIPR8#lMD&#@
+b1-ZBiLcMaG%@GYC#SP`FID)mI(IhD4mY2rkl[6i[9qk!5rh&F$MAPcTGXNplU+3
+(KM`FYppK4UH8"6B+-dcXp8![#RYQVi8J0pqCJC!!Y,@CZK9iJ4%""9krT+eah2[
+a1PpYVfiq+Lb0kYkXYQ[L-0XabX+U88mIpIb"bK*F'I!e",-M(*!!dPB!C5l+%`J
+!#j!!)5KP!5bPC9,3GRjSfmi2,EEc3pYfiYM1$hNlB!+95UG,UR5PU+UbU+3AefM
+@,EVp'MDf30,+'e-ICA8BLjfCk4%Y+B,58N*ke*k8Xp6NS&(fZ#pF%KQ5HL60H(,
+(AXZQ'R@0,ra-hC!!G)JEA@D$@@jHibXiecJN(HCPYp%',2m&PdNV`B'iMPqAGRZ
+2"6(KMVmUc!8P""Gl1Hb@4-$UA$hI8')30d,D3iCImfG*5BNB$fAe'YlMci+5!R%
+dG1U`iA2qV#q"le+S"+jb-"Z#KDNP8l&`cNaCV6+B"K+VjbG,`PJm,Lq@@LkHPaF
+AZaFcAABS"JU&EX6eX!6%(9kQA(8ZNMh-ef53!'pdT'!QSLk#6#4-U%LHAPr4fDK
+RcV(6[YVRG&[[r&(FHmI96qSIm%VYpBp[(ibdrrA)AYq'Nj)I%ip&rA01BZ+[3)c
+51lZ&2qlGr[R[6fhb5[&,eTf$dALjR4-iGI#1D9)$1Tb-0Xc*T3j*h64d5-Dp#5R
+iTBeHU50[eGE"QSlb0AGA(I&YfLI&-6dAdmr5G,XZ(p2YFHqlEfaHFCGAmPc@EaZ
+Xmj5hh9fjalF4#YPHAl5Kb"[Y8$SiG*[3`4(hrMP[9F8'Vq3IHIcH`C6rVr[1qZi
+k0Q',-*DPfil*eVMhm*RhkZji9fTiflTLX,%"9krif2I!5DQG0YUZE$5-DNIG)Kc
+h$QTk9p0'9p&'ebJErGbfd628S99AK!kYFHr5hRp3DD0kfQLEa8E2f$BUkGCKZK6
+hrXShH`0[P%MZ)C+ICC,60[h+p)4Z!kBRiYjp2FpAF!)4dGYPSU1#IpPkaC!!!'d
+B%BAi%GdZG)c%[6VGApkL,DqL,DqK,A1RGL*rqaam8*FDh6*dUBPl2cTqacZmE8U
+!Z*)!CcJ"LYJ33iHbEBeZ,MTSiYllEUk*VM8"cYJ5i&(G9%aqDrFq[rPfj-Qd
+&%ANcNB2VTdMfAP5b39,BPD3Be@e"ap'ipp0rkrZBYVq+YZp-LR@F&)f#%b0KRh1
+D1ShVGU$6H0clmQ[*TpD5(!hBYTh*LiT%TA([SXiR$e!b2-(*m%Xj'H+8B,NdDA(
+F@f4qhEcqAFPqk6FihPkqNSq2([cl0!@%9bV$,BYl8qI228IN(L*b0a1j2k*NKD1
+he&k8kr1b%d$Fpp-&RaG[mS(-GL+c95(c5L,F5LBFKY`Hppl9j2Kh)Zm660jIbZ5
+9!GE$5B&TZq,H8)meiqr[5L[TLL[P+a**1`K8lFU!1q,H$4rFkb95$K%TQjA0V1-
+NBbF[D@A45EVNTVM[YhrrfY502T!!d%iNY")*2q*NSZhBLml5e!eahe1rqkpl@D%
+jJB`V#5KA+S6F%[G1q9llAC-*5BM$!K9JDRlFZrJl2cM$'b*#VP3)Z8m1(KD%A"I
+h(6TR[AmYK'a3!TfmmDPaErFrrE6Mri+3!02LhV+rIVH8%j!!VYKJ5fSR)Cd*8a6
+h"Qk&eM-KmiC!(#DN6"b23Tbi3XDjFGrhk`Ef-"RVl5!1Nr%VFP"r!e2ImXV*V&[
+b,4FK[9C'HMrp2MB"emAriB['DFUkZ2I-2brb8K,[TL4Z8)MhDkRK$lkSRkB"!![
+rrep%1I"b-GFB0aaf(5E#Y8FEA[G&1fJD%Q,ThD0f)XC+*NEjEqkH"A+FN6cr![,
+5*!5-6plCeX2"Tlk9Vre6T8$i[5rD6P-faEhl(rMrZSPBZiPB$ECJX4)App!d%'V
+4(rBEQ9"mTCTf3kqVP`J9MkjmhAPa!2!lrc)h5!4B58Mr0dkNEb-5NM$brllp(Pf
+lPDrp8`A4r-&*T+eallB2(PP#B,1E`+E"LGjrlp`m3'[,AcA(R#5+aJd(A3ITfTp
+,+rr&H@d%HIrH[h83mPK*S2mE*ARPDmXNf"$hVYq5rbe#(N`Ncdq26%VBZA([[9r
+kjYd8h(C6F'Y`&j@fa%@Jl*U49mSATf4E15RCC#)"1+GpjG4Y3X`V#G4ri`Cehc(
+P8L$#iSHL285Q&LE6r6C!pje8L)"%kD[6rC'5VSf56Qq*,U,fd`M)Ve1eq,K[eX)
+,2hi!!Hl5'YV!UJRSBL@QfQRUpVL[l0@Chb*Nd8!Nfqe'&VkcES,FrXXc8iKN,8b
+bqff)`THVN!!$5I5[pRAA#%fd%CV3@k+*D!-1pG1KZk"kq1[Lrq2[48M`0C6JUpa
+S`RI'$FV(F[rp35*F!a&ZpeS)K`"fDr$Yp*p)1#48@Xfp1bB6cSNHL"`bi4E(IGp
+9qka-Z,`eK"j@ZG'$M4`!kHcNQJmSN!!e%'VBVD!'5i)JS$fImICT#K`Y($MZPj&
+$R+j[#rK[h&Mq')235"ZZ[a*AQd8Em&YX!#"8GmHGIf"5%-(L#X&1m[9"-)m6V(p
+jpZmrBP*38[U9T$ccTCYI(46qH`C&mSj"BBHJ@6V*35-j)S+V)2)2EII1!HY@fiI
+-3G&6AVp`Y&aD9H4pb[HSd2ECqb#XEUJAPe&r"1+ebJjXc)5pY1UDldl[h4mGZRr
++ZZqmDp3c`jFqLU69ZrCH@[@Shc!R&FSmIHld0#m2R0$8L,[hj2S5Th&S`jdRjrK
+Ue+LQ9Hck+1%jIRUD6jRJrGfHBpHLRP1i8U-bS9brjD4lJX(PF['86%b*((31SE8
+B)KMqAI'aI`cfAeT9[K*G[G(92rhSp2`D-FHAm&jDPI"Ni8T43r6KDZ&Xq0e(*kp
+KHM00Khe@C`-M'fj+H(JEdBIAfCT`52I*DeR(N!#ekd%@%H*mfLk,6!Ha8q3-V'L
+4@5YUA'%Ei%2XYA3K8M,XMbYC)&3(NRcZ"DS3G01pJ#T"&TrHfHk2Ek[M'UAMcFP
+AN!$@Z,08ML*TM6[EaCr1$"Sq(RF[IeXGP#-G2MGMSiYC+P$(6PQA@TfR4MhPAEZ
+kjjbYm@`kHm3,&`6rC6AUap+a1[r'BhZmEd2pZRd[JPXV"cITmEGbJre&Z3I[Rck
+3!0,B4E!rkYrad4cI`IZR$TbGhbULIYG"`d&HH%pC+!pM-#a-Si9)4r6aeh0jJ#p
+J`A+!2ddDi(0P3HlqDlPl[+DMc[rlBpV$pX18LBY*(6[h4M[+Z`MT[5[&m4QR$qr
+!28Qh-jpG8VBFH4NZ(ElSKYIAh9jL`4DE0%&DEcP"9im+Um6-B$0e!+*k-%DQeqD
+T&`i&G+@eH4r0qUqr%N12`+ZX%kB65RmcV(Y@U(JY%5'm[LBmH*8*2ej,43GHD5+
+1PdkdMl!$YGiB5Hb(%i(GB@9PceXYVPB+r-PU[mNDf`D'+"Zm5Sf!BB'&,A"Rc&F
+Z%Ld"fkT9BG(S&V%C3kl55&8E&9BIe(hk*Mm8T@G0T"i*k,[B#2*&X2MK`+!C5JQ
+SrC0FC4fUb)Y`R`M*3!-Q4TVG,"UK*US6cEbS#KM!8bESf$922!EPlqKF%F*")6T
+NQ!BI"AX8lV"fGL4,LcP-YE1@J)Nm2`-40!bLi3Nd*&hb!S`$`9X198B4JEYNl*c
+l`%"f8(`36E&ck4*ff@NDccT8NSA0,qPH+X(&3EI%lB+8kV+IP"h18l,$H8EIrE1
+qaUU4*rTQ,@&h8'-0MZM5TGe+f'Z&EYD5kfeDA!%"%kq$pmpDXUD+e@R'1*1YHfS
+6Xd(p"YQeH*'KX$LVqr[dLVLdVLb&L(jANlLS'(-X"j[d90SL`h"Df@!jXr%'2i-
+LLUX*LINiiRUR&P'U0X5-),&QV[K[B@Zq[G2Tj)%"PZ$(iXM"$rM9K'Y"TG#YU5d
+qC5M+m[@MXReaLD(S'iJ1[ST,LX&F0RQ*b"%SqXd2&Q*L2C6k"fL3!"RiH'S35LK
+Flc1kEK`JXa9%C5EZXX&b9(&1T%i`ST39-Ghl1)%-pHa+#V0Bl5"bHF,3K'h"G9S
+Q$60jYl*KJHl[bi[pV'kZIH-k,E*a1E!bhbKJ)RErL!X`*CP$51ClQH5%!,P+NS#
+lQ,ll*&MpADai'ra-RXE+K*H,%LG55Q"-@qaNj,I99[aF*MAm`!XVZETeK"aCh+l
+VTk&1rC!!'dd4pG@!#a1qVLK9aq3Z--%k`P&8GDR[@j'f'#cEiE6&['3S8"GQjra
+fUNbZS*V*UPNY0lQ(LE9#8@0RiS6BGIVbmA4P1T4RS45j-B#B-BGNJMZ)F'l6#$-
+"hlYQU&r*UJ%fE**RmN(*B69jf26!pc,GJkJlPF9a9Zd`b"#c'3$$9BfTHqA6[Fl
+VbX0p68Y1D5Pj@qT#2KVZTBd!a15NU4'B3R*[p4e@LF5QIRZ%ZAFqZDijH'N0!S,
+kDMdEc+JMBUJb-E$3BL0qf),iGLG4M@aIr0XQUGMbNdJkCRD6G'QG*8NI5l-Bj+D
+bZ1f&51S'*6BkmpX@HG1LALC+%jXk9Z8ZE'cjYqF)TEB&1QN`6%CeUBA"1%b9@j,
+'BGZ@DVNYa`3M%aC''k4*4KXm-+U"J"l32#1lZ3iC8iTD*SN"V`%ifmB`aER)KRe
+rqaUaQ#f-rX))dVKpSqD`P2bJ%fBbcV&LX@Nmml2EjDaqkjkCkNS0)#Me*6*(e)c
+$K5"@F"@c@%'b*$Z!ErFCrBk@PiZBU98$pDA$`dU90S&U6j%ARMTEY%ec6M@1f6[
+%UTmdIB2Pp+5Mii6JTBc$e8*AIQ@J-LJ0!+J2i[VP(!fG4V6qT6c48*PhKBe9kbV
+ITSCVD$M08FrI%6h,d3iVSRX`q3H9(r2N"PhP6@T)S'%K4q1h%Ch0dIC2%AdINjX
+VCr,NeEV+'G5`!!fIFM6j2+,&(0@2)PT&PhK6ZF4Ve'"!`cb10Rb%k&b1fUFM@N5
+6TbQ6hl1XFL!jfH5UX9R,&3)GDpi#,!JY9caIFc(%,S@hlV98D%C)b%eZ"i)h`)Q
+UYM+9AEQSe&6Eh5HVkef&9DH-@6#%N6,PhKT)qEQ!e#N&T%jha939Zp*AG49ANUS
+Z[94B1EhU[+Zb5JXe9@ePh&"Be3ZecM)HLJ2$bKk6J00[r$Y6CTmFIUfrYZS8&M@
+m''"c+0-R'%b"Xfa8-DDF8&4iNNYb4+h)S+pjbj[bXK(QD)e!eM6kN!"!YZb4Je!
+&V8QXrJpI!L,S@kHMB*c$THjd3,pcMcM0f-%BfVN(,[hqe)R)LFQQ*"4K[h'YbUT
+Q9P1Y68R&4'`2mb@KT(*F&Z@#"H1XI6b-Dp!IadrSNSMZMhSP9HZl!)-2NTV&ND5
+NRZ+)A9*,11+3!04c(,&+kR'1K#8B$%@NYHqR3XVdfVf-U!VRjI&JDj!!Q)q@L(c
+[&PrS0)XTdGGVa#2H'U%pPR1'(FT,2Y+HYCqP,RI+cL3#CRE#1pbAAX@%*9$KLbG
+Ur+&)M6m1"pDpaNEYDARB1Q6(0K`,83@m'Xf!H1SBIXl@3*M22mY'0$RVp[VM8R[
+''6K@6Rr)j3mpe112`lebQI-JJ%+4'`84+Lm3jmJ!rcNiiU'C2V*0(0AcK#X&`PK
+9a)R49)[11H)'&a0341Z-N45@H$Y0%E@C*b2##RlTLVQU+*-VpqXi+RRF+)YG9&1
+b)A'ldB(*"SL4cm*JK!k)r%1q`KZjJIL#bPPlURGqRBSb0L*#kPbUDR9AjDb2P@P
+F`4rSj8IiJ&+8PE#eP9$XVQXKYam(AG(P(N4@IV0T%NabjCr-6#Fc9Rj8hj)(Y$E
+TPB+"TdJmF'Ek4"-m6M&P4-#9iC6PPYQS#JRN1ES@Q8!`H($GA3%YiM6()V&*PiP
+Gb8M*M,[-9-MRS(SP9eAM!4*`E4lM3Y3XBL&YhiZlST!!f$2CT0'BA'N`b5iHX6T
+6BGA8J!-"HbSIdhMk*A29HmI6X6`03DLfq&ZSQXNLA[[J)kE+#Q[!#QF4N!!5(Gk
+6#LZXf6IKS"A5H2Va`!+&%#4J#X'19-,Hr4ZTbqllV2akM-dpp5X"&pXT4dHr"J[
+S1N6Gp(4"L+@TB6NM3mIhdPA-R'&jcKFEj5`#98&'*31HJ%68`q@q(D*`C2+5+i"
+V6ZYq'qK`'Ll[#,!61JkJ`P,HJ%2H3&"dQGR&)AA#+Fj$pBk,"P)34r9`%1ZNDh!
+P%KL0%AVh`'cDUU,"f3d9B@3(DqXcr'J(pqE2Q@SV'J,MMYUUE9c-'AaM`S8P)Ld
+l6La4K1VP%+LjUNpKeEEZmkLFUEGpRZ#(466C#*LfaG'&5cG54U644RU(E2kHYmM
+GA)pBZ0UhQ@UVTJGS!$41arEYf6H0c8j%+Lr3-%PX4DYN+C-)M(CkN!$$32TK)R#
+5$IYX[bdEq&RfLhl4260aJMI3l8KTB4iL"$G1')NJ4diX3i!D-K3p'N(eQcN,I3Z
+pF2(HbrpAl-dr[G1(c1B-GK0V+'D6A4!3Y1j2lSj("cJ-lk+l&Gfp#hd4VFD+!e#
+%m!'6K`068BXKClk%kS"9dr#+9Nfp![1I&9Dm)K81UMMSi1eMbkJX%hN!!F6[!Q%
+i14$CPTe6Ck4Y3LaPTm[Z%`S*je`j8@&(TXCRX6K9FBlR"lKmdMqqr6D5DbBQPH-
+R$i!L%+PQ!9#dGfpVUUf`@hD@HQ")[PMUJe'qVa"J`E8+9aU!N!$j#DlPSX'8!c"
+3%"01pBm[q`8qkM'N"d0kQMMMG6`ljj(TbK"'$+((%+IB,GIpU!'JGFlD"4!!@mQ
+P2facklF9SfPfQp-*)9aNMTr&Xi&b)#Z,!%bb!%6`!!`#q-Ij0HYCRM+KfQ5p1Q#
+DT`i%HUJb4*`B$(&L-+5`B&@bpLhmZ#@&lGE)Mab4Xph)'$6r4kQD'BJRY"#Fjdj
+%V,)j1MbDSl+LjABGVP@$)28F9qH4'bl9jRZ[Q#YDM-h1TH-qAR!qYU6*Bc&%jqd
+#)+2aVrd,1h3bD3D0E9fa835"'hJXbQ8T%iiI)E"i#N3F!!`h6KK#5DX1Fi9m4-Z
+UQq%H(pGYVd8(hEB4&5)YCkAaS*XI`(e``J8k,4beC!0X-R&K(XcS!MZ(Lp)Ef6N
+2A3BbpXAm$Sqa4Y2AK-!lD`Q+(Me(E*Pb"U4MR*&3b1mjRZiF2Qd(Zb8k$I@Rj)S
+43e34Xf95!FHZ6H3k$aFcVQJDIY'%&RN#3'NZ'@!DNee)Ki)`F9GEN@#"D[PmVZU
+*+VJ`[X*9j$P6Y#D,hCMpD93T*%)6MV)"-XX#L60S6L-86jJV%Xk-BQcL8(SD#ND
+cGjq&fB'0,0M'U0)b3"kX)+ifL#c-,bk9JdJ464HC#IdbLD36"R,-SB'UL4"#T1%
++F*-fe(-QmrQT2#bb[Th1J4%`3dK'L0*24j9"mIJKUXCDrC+jZ2I+eG$eL[0i'5[
+10HPG!@UkVer)KJANL1HN%MQQ0&3MmS8L',TUiU,0`aA)2EZ#CPj#%1d-a+pFpEa
+GFBl"!Jl3$3M1+CMRFU%!jNhEUI)RVV4m)kSke"DEjPm0&34UD(V+kCkXJ-CT621
+"H)Zi+j`Aic+B0(A`CYRjGr8"5R#KYY%!H(5C6"!kDQeND*A*X,4(*S0k6LD$UQ8
+bU0P-"JBCDRa'hV$k&i8!Tj9)VY*`$Sm%)e%(6erjRTXBS3fS@'0*M-X9j`"UmkK
+DXpkC9("RR8#Jhd54PHk`5-5e%!S'lAiLS4bE*a)+alU)&#)d5S'd4EPNjI,CR+9
+Q8T6Gb',f4KN(J8A,6%*fji@CrdpK(+%B&@5QXAZXdc'@6%-dJQ'aN!#c!dj6+L'
+J%YeF)+m,Z2LML$`CD)5cEKe9FANR%%AKme`JQQ`%GT`ED!N0TqQJ$KaqD`I8NIa
+kaaLA&a'd,Z+R%3PehX6QXb4%"b)'*0imr,b'kl1$H`QpQ$PNa6'GLPQb0VVF8H9
+b@Fl,e9j9fh5Em'V4lH!XHShi1L0`cebBSq-(HQAR*0Jic5Dj'NFLM)mGQHQmFDI
+c,4d`&ML+E@3'kRLEXF3V2@NlD[[5GS+9G#mMNUHZSLL-i"1$228q#q)33Tc%rN5
+Z(K0S`e$Y-+M3l!4-E1046CGLCU%HE1%)1HC(')@`ZC1EJh!H&l+!rkH`,1$(-X%
+SMJ4-Q(i85H3L*QN0M[Nb+S-LdkL,N!"CJ[fkSr`"Plm"F[k2+!B+-V'eipKD66!
+b`dM6,mJ)%5bQfR9IP0dbXh2XMb,BlFe#%,XVFk*Ce#i*U(J)9G9DBDLb%kLCX`C
+4b81&hl*!%J*+Z0J-!D5`f1`UV%LjDSX$3A[4bCLG*S%(J1$kk%Z(+dZF#kJfG"L
+,#CPpTViU#j2MJLXJ1Bf+)G'5L'3bJph8Jm)'CJ6!DN&Pr$DZdQaM"hCjd*b8$CK
+!Q#0$+BE-IQBSe9DFGaB+)-B4"KqMDI*J2+8V!VCLJIS2rh1$8F"-iV%R3!%rk*@
+CA&6PZH2!Q+h+-l,Cq0r)2bmGUNJK@2Ib`kf!3&BKfqMi8@A&HFdK+FN4ia"0FAi
+b@k,%iS%`'jd9"YN`-*+JHB5I10,eFcqFNEZiDK-A@CeE+"V[4b@+PL)#S#&8#rN
+3lUFEYIYXdkUdI94!ie%MA%!65h"MIHGXm`frTJ2U@6'%`2%QLVPErVrK`5mdB3H
+!D!HBrSf`S06SA06kH,P[@9,Ji@-dc)a'HjrRYr6BVKTHH,#4(JMS[&30A8U2ajZ
+8%q-H`DG6#L,SZb[!,68i9F`X"M5b5r'N!MKPcZ1-4i)GQ-(J,A#b8Q'+T5ZYJ-e
+ISM),SR)4d3%63'N&-"daJS3U8j!!,3bN4)!S'%dX06L4h0+YPJKZk@)RLS33N!"
+Ne,Cd8FcfF+qP[f5d&d19U+@r("%@8jZ9c$!J24!D8Ir@Yr49L&C$6Q5eG+(c%,j
+@8cZC%)m5)eBId-YS(-@pPP"'1dm#QB*)TXDaVS2B,0a[C84pH#+LCY5qb%K-,Z'
+h(X4Q*L0Y%kiDL01eie5Gp"dX[4VJb3YIK%32@e4&i+(MmY#H(!9j`5c1dM*'AN[
+,eSDmTKeAN!"APJN6!pQZUV3KS0!f4PjT3N&H&b9dCq3PEbaYL"GU-p-N4Q",bf3
+%PTDS2CbQ`43K)c"dZF!XiMqA+eH+!"3H[S(#H6+V)L9)c(q5`B!UUUFCl8j'$$k
+A6@$#h$Z"#92`!NbB!TN*dqKaXf&b&[*'Q8L,GmTA#RfiGQC-cS,m-cqC'C1c8'E
+'6'D!T!M!RKF6*KI3B$Ra6db(L04Xj06-TJAGc*K'*c1Q-H-3YP91CTYc@VK+!a4
+mZL"!M%h!I(`%JBN$&#X$)"TXYTp4M!J9Q2B&f$aXh#RUXY,,"S)!60fd9r+!c#D
+!iG-EC8+S(c1!SKTT+B-6M0K[UKeHDT!!#q@88LJ[X"A+V6IGKA*VVP`SVa@-NGb
+"Z"L')Bqj,`c!,`Cf5h"qHP5qSYL+kMc49hU@IP*lH1QR$)B)S-9"-eGpB)E'dNm
+JTZ9"D9eC%3Q-Fi%2mPP[#&5l2B5+!q(aMZGkiCLI[+A2l&[3@lM%#1E9JN1&5q5
+TMpHld*("Nif$9G3%fR$8!)l+aS3D$$q!53H3!%QqRR&S![K9bq!ReFlk'#EjUMR
+Cj16#ihG+h3NChJj!33@`d2$%"&dqcb*")b3'LU9@#`F62&+L9@([-81+c3Q+c8L
+3!"(mA-+R&K(T"+XJMcb(5Tm!L5*Qfq"aM8m-YQQk4PMe95A"30YEpeIF3%,2`)C
+Z$(lQC'V*5Npqk+*G2k+5X1QcQ&iZ6`ISlU'KVNGB*8qXAME`aTAqlAl4#%@VAcb
+"$Mf+1VZfJS*6plrcJchKlV"#YhMQ5e%I0lJ#hImZSdiD%L`k9!+MUMhG06HkZ%L
+,S0*R$&@IZD(l&6C($k&UXD+UJENVCY,)&a4EQ&N&K4[-pX8Z)X%rV5dFR-lCj-(
+0p*Lb-QA`lGe2ZJVI'-"2YJ'4`5!QDieC33mk`X4jbc!UG1PPCjl"IkD(U*BUjQq
+@G9GVZZ#DS'G6995j'Bd3l3Z8CEZmCDG)rhJCYMA1C*,S-C%C#0"3,Z3')Ucb4T8
+e[RLV6&Bd`15k1`RdHcN*('aib&Be5-NJ*a@QLF2#Y8,*e))PCl8a!p1)f6VZfHj
+NRr9lq-'mJBZ+DYeMS9L[IF-S+mYC'3j'VN@(iqQacCDX%'3qDb[k%6"Z)1Y3@@(
+')kZ4P0eI4k!amfDkVBMHN!#hL1T+5@6Ip95*$Jb[aiFX"ZS!`f2X+B#c@)M(Nbj
+-4-6lVhPMc9'$p*!!Q!QcDl-"hYGHJr%,RZJD&*p`*'Ui8#!@L[IaQLeQ`J$6l0I
+39&KJ'K3,Ecf+LK-,*94JeLf$m0S@$Hh`$Sb(fD$'Vk@1(Ei"FeJe$N9$cX@"3eL
+!US89*H,AYq,4FCU+Baiq++DcmQ8J!XY8#`IbNY3"Mr(qT+jV,4ZBrErM"RJL'1$
+*"`[%cE8XAV2B+#p99KL3!0b'@d!j2%fUV6!m1#K[r8e%U[eiX2PXfZ,r0X3!S"V
+UZLC92'X'@f#Hfh`A+b8jJ2*3Bq0UeiF&iQ-8j0Abp0@Gh'#2`(Kl0BZ[8,dMLZa
+RHS#0fAQiQDHl!NhMTj1k(B2r`C@4i6USiV'q!a#U#YGP$aiClH*L4*l+,M6cBC!
+!i--H)a%V)b+U*cF2hmXGRB[C16[(-m'+Xc!KCVXb*Jc)9aeLak!N$a!(UL,#Q-A
+(NlU`HJp0A'a$D'Z8'IQ61TNXJ38DRYNf96p3-4l'$+DN+5+'Bif%$(B$D*!!0F0
+($bVP%V+$S`eH%1GGcJIZGJR,*LjLN!!%1D&,F*q%QCN3-i&2@D#D3KR41ihF%5U
+5k*%!k)kY'S#-rFFTDkTFHKe%,MiJLJ3q4G%,,bB@e)cV!X035Rq[1!X[II%T[&c
+&*AJp@(`1489@X99fLP*)ZePHF,T(8H#"Le4qJCL13kH#AA9+FB!UI10FXI8PZ%8
+9Rf-e[,2"D(VKibBlAp(5GpGbL$cCpJ!$0KS&JX@GMRP3SGC@$-"N8j,0[pUBd$#
+8FMXQId+a-##6!BH2dR81&TI`85m9L+R&Ti)0I"`I05B@B#R3q(#IQ#SCL'$XPVL
+Nq(&jLr*9E-5-8k29cB,'d(qcf'kYlCL2P@em&pYp#1jVVcU"Gc"hBN)KD'9JB%S
+-pcDG3pZ'8iCr+8ppb$NdN5k#`&Yd5Cr[lHI#p#(E3G@6$m)!+bfZ'VCGe@4a9D[
+&95AR%1`+fEU@kmT$fSC4KX89`jCA()f)Di@2M[Q"CQlHm*J1&8D8l2iLcZiVQc"
+CE-*+$RL,"R-Y$2%YN9d3+"296`MAiBU)!Ia8idGk')+r-0$V'P!aA)N"5MF048#
+*#fPj1L0Sr-c%crX2Xj%h%ldqaUY"6!@l+@%[e1RH')KP!KL08)I9&PpRG4KABNZ
+l3e*Y+M([6Yp,jMHbh5Se6$d2G9TYm3&@TehUhZ)Gb)Z%f0MF&Yp,VMF'D'!Y@,%
+3c0l)I!N[*!-%0B$K0r*"*S"K#3H!Z&PpL%'5!cp%[f)@0`$)286bLr6`G8`RpF8
+MpX*f8Abmd"rXB*@K%(Sm6*p%)$b+[IJ3ZYd`DVlp,YfVZBZ-l14NPP',M&CNe%4
+%MiM"Kr-q(a@EkC92T,f6Ji5-TRi`im9S5N&'HV"6Me-``L#a8B$+$`NB$a0kf-6
+!SrkYq0`cK03)5C!!J%82EF+V1`YA0"XCkF+!4IF*"83(1BYK(dDfTG8jZ&0dFek
+B46JBV$X$`,)2lV&9U5kch#l8dK$T#,LHBp9PaA1-mR'!ScXb%6%lf9kF34SRpY[
+c'r#6$hDM!3kHceiTV"bU$2(V+fPJ-Ni(ff`61`kj#VZcm,2C9GPGMCpl,9P[!5M
+Krm*'e'ZqcLqi%SIH6S(&Cbm8rXS50RXV'd1TmdJG(h4bpAH!arXlMm(SPIKCDI8
+f21kRZ@kF2pK3#c)3[NK(cXPESBM(80Mp$Y5CC*E9Xrc3rGh[C1l*h%0rqN$1,Q(
+5$TIf`e$8VRQ8!69qQ)[(-C83Zc`3D!fLQPY!V`%,&Bpff'Z%Z0p%CUShc-e-ChH
+Qr[BQ-[[S4aEjReiM"kFFIa@cq%`RCC&r#!6jaVXpkX[[`Q!k(Xm08c!`IU%@`AQ
+BcFr-B`HURj8@*ZA,'d0e(Q@B!VTi"bjH@iQVHNBr2#C2jZ%,Na'P!fq`FKdkM+*
+$$ffdYK)!i8PqQ)Y,5DCMh!(#AC&ckpKb@ApYpfBd6e-bhCr3TK1dk8jXqTLbk3l
+DG!HaN!"`L6[HXffl3lR@GP-ZNr+@%F2h@!`2GXJra@MihNQ$[jLJG1%lV[,JPHZ
+)T2)@MR"'Q6*")QfM6"D29YkZa`4`[`c!23I!+i%bEKJJIJU#'9LDKX*RMIL"@F4
+R-r&6!S-kbmCB!)&lfCqAmd36f)f"FB#ISGF-C'1!@l`[9Q1TJ$Ebi`6e%p3lCpd
++8[cT!*A2ld#aEbJf@4J*+f8$$mj(c`1"R4mQeb)94e@N$%Aj@'*Q0-$96L3!H)-
+)K)Kq9XV9c"2lS&!S8pK3-DRfM9`8jkA9afX,hmM9P8ed55)(G4K5$PLKi&d2P3%
+BF,pE(04ajPj-Rq6FP-19IF'i+(h`'KX&iJ0Za@RBdJR$PV)4KZ8l4TfXX#42C`C
+BBKp(q5(`,l!C(("c,dbU)C)5Id5cY2r"+A!SFd6h`T`J'fB['ak#!CVe-%N,TXR
+[@!'UJbD,JF01@AJ%`Zr%)-jK)dpIcmjj(Sq*i)S)EN-@Z#JB&Pp*JkQP`Up!*+`
+F!M$Jd84TCiQaD5HR+cY2deC@mL19('jA959K&2Ae!NSF[UE4l1,AME@5@#m6)hD
+jLIimKH@ER@3&XcVf)ED%am'@Z9Q@Eq31cb-`Y`,-6mEmNXHB*1*im[HQK'Z@X(q
+2(r89KPR1'[c"'p)MI5)"0""5K[$r%5mB4YV)*&Kq!!aHqd3#N!$c'KadlKNJjdb
+2l+aViCcT4h@2+0a4NYd2A1RVhXP1Q0hES!TbG0r&b!6Ahci'SM+Sh$-p+ph#JB$
+%#QI`94kH"@(cRNr`Cf#FX(c%'KX"TZ0YcX+6,R!aCH+(ejJbKX['kS3$TMlajhJ
+J)bdpbCY2`+#X*'SHimHFKBQ"ZPfj%"5JPSpK3f%8MV83H&L*U-f+5`Q%`lr$aDf
+*KfJKKXL3!)diE2jGjBj3$dehGdLEaJA6#,(cQrU%l$K"(EN5[,!M!h`Uk!")DqA
+((GS%kE,EB4PYr*pc'@dS)V8@4YUQGaA1HPCKb#59S-qQQrL26E"c)"jE$C2NT8a
+@ed)jb&@F[f@%@mGjADQaa!PZrD[GJ)DJR1c[%aS%efXb`#dll`Bi01ETeU1jR%&
+dE&#Ba`#QcQ$0bUR[&$fid-BB9e"(iBHF9D@!V9pl`+BJ1339@c-(bkqqeYmM,J+
+&0-X6+XirZ"",'X[++%)!a*UlmepL30Z#$hhh#K6U'`qLH'&fXc-*AccY*3K+,jl
+Bj#'$L8PbS4XIrXrUDM,BaApbaRMbbF'fX5k0aa*8&51M-&P*ACJ&kZGT-6)kT+Y
+L%*pS-06CbA3YPJcb3cApcZbTK8(e0q9!J-5ELjqLi$L!B4UL8cNjMH@Ni*fV')q
+m-IL[8*8Bl5L4HV5k,E&6pUS[(Zc,d'f)$C!!DpmS6Am68lp(8b2bJM,%(p$`#M8
+i)!cm!HE&V`9$-"AQ0qS61"k2)#S5I-%fq9"-(qAT8-rPDFDA$Ni-N!$XAXb%#aE
+miZG`4hK%-pj45q4S5@5!4&CESjiD9CQJPN'Yb30RjL6F%2RaM@&E"blqZ)[J,NE
+PXBX+XI,*&$NEF+6+1JKLSfc)$K%09p*""%Ti9L#N59fb%q)@I,a2D,U0rY3GHHP
+kQ*9c3p)2kZTAqZP22XP(%UEBp#bZmGN`CrfhX(XBrDNX#MM%HVNj0Rcp%Plr'H4
+U39[Ck*,m4jPSaKZX0%f5VlCd(3-%1iM+3-8",KJD[$$'$cD!)@dZQ#"FcQCQmmb
+(H1KI92rU-rjXFY$LNe4"BjIYq"JPbq+Qm9VmNj[L$QSDN!#*X23F(AP8RXL%B'5
+*C(6)c&RAMcAM2rL0R%JbQCC'U)YG*Yl5&[kN`q[iBE"!"[Q-)Y1bT)jh[`rh(Ej
+bR#CFN!!(+0XZGbhE)9qKE)1mqE*mMBI98*Cr5SR6'*4Xq"G+-N,L6pr3f*bNCE1
+r6E*4V'ECqIPTXmB@")0LJRN`UZBB(A!UHC6r0qe@dAA,(iBD2$,K%D)c,eJmD*-
+HB!!`M6-#J"VhBk1,R9[PLRGeRS'mc!jN)([VHf(f!+BcCbCNShp!PHbJh"EX(HK
+!bD*pX+J[Rak#d)Y(A%eJUj1MF(+#!I"HYm,&,Dc95ki-cQ$+4JV&Qf0c#@ca"mJ
+`#adUXm9XDSR*2"L8rc`A2$4kXDk8rc`BrZ0Ji,kh1"r'VH%J@SE(0m2809GdI#D
+pq+(%#@c`2!&$+4P6LR,L$"E$DADFd4F!i`I&0IKX9$jAdDH%aa%AL$BT%fKHiLC
+AJ"YL)9I'JTlUd+L(#99mKBH2c5!MJSUBX(360T*0lY9I$(!5hi5,CFKi(LVH69b
+G#B!%BiG,0c(c5Ef#T'hM6fl1c[Q[I$JIJT9*"RUh)AK[a3r-Uk9YiJIPik18Jcb
+8GTYQRQIJFB(44jp1*)Sr&N0)*K&VBaG)F[CDe[h2$VMl`I&'",BTdeB319B%G8h
+-j[J@)cFH2"MLiPFQ&8r!cr019!QRKHIGaTpD"8bi*A(dBSM1GV&VjR2mm)$35Il
+c@b)HHXJ$2j!!+Lj1XKh6MDKF2b%)S$LJLP%&iRd3f*(94dU8Pl-'qYQTI#BPf4!
+TBcK"m+MNj3[iMqHC@+L3!0&8IrIrJ%"`(GPN+-cjeH3BI)kb%6ph6Kc-4%DD2SA
+&2`!!-BP"4%05!`"B)Jp9$@C'%4!KiqjKrffrPUVdjZqk[VQHj['jVUYkUVCk3I0
+%GP)h"Zc+!VeZ*V1cb*r(e[+3!)lVQlQ&%-)9lHHA(A$+M)K1McJA$K0VN[%mkf3
+HYa"Hcm*kK("k!b1%j9Q(dB#"*YdNlh`c(Z[[hprrph8G),ql*1mP,cm!&AGH*2-
+J-L)5)I%!%5)'AhPG*Q-ar-LqCJ'NQ"c!*L')CV-(JC2-S[20R!1c&,&8JZr0qr1
+q#52iqmk#M2G`pECDKMbLd51Y3amCHVZK48lF$KFUBV(IrB)9$i+jGMADr*`4l'r
+h@haI,j*'%1&V@$'3!$VG3"D&JAKK))8c#+3,I1N**R'qR0U+J,#d[d@@iSMNQ$K
+F4Yka2ZGiShr!2`#`r@&r($qAeDh0F5L,bQK3@RaM-0(+iVm'I"EQ!l&N"+cJFTK
+`k@35*Qc#G2I$E""9ifAHl#RqDeZ%Lf9SP9)$-MJpFG4(,I%a,MkL'[&(2c,M3"S
+Y[YDM,QA4,b@h!L#Z%jG$)#S[5Y8d3Vr[c#R(PeXFh5Q'2B1c&p9G9m3$fZml-mS
+$RIS$fR6*8CIT%CIaF6+LbT-UD*qdb*i0(EjQGF,3E#fb'F&d-d$N%%((G3LakR`
+CBrj4Qm0[*)ZeU58Cp6rXD9CVUILMYU@lYJ%jEKQh`A#VM&"r&`##-#p$%1HMj5%
+5b%2'aX&Z,k$'M)!D@DbS3(m(PYUc23a'$(r+"[qKa90L"&8#+92@`D@PLaQ&*2"
+5K(&fK("@jrR#mUhGNd&1A5$mrLahGlrP#DHa(%U`eCPAHiaN@cY!iqA+)aH94k*
+B'YKlIc6Bhf@%("E!ZZGZKp5GMhkNDJAYqIZ65@@"Ab`iZmY)#PLI$,5'$C6$b%*
+1DM"$ZkfpXGehK8d@#85Y+,,VLqj)JfA"Cq5NfAD#LLNRl@dR#[RK(!F6fFLNa$5
+9Q#E&G(+j#d$#C!#AjV$$bU$*'!cfcqq6UVYPj#X)%Ph-b2#+dp1Ke1PBc*FdU,!
+",Cj!+UX($1R$aXEGV*TU[$PThAQLX14G[Y0L,"'`a[#@YY-#k+6ZSVbX!9+bmX8
+rDe&65br&k[aCP`6jk9l@[9$VeTUk@9K)h@MH1)SSE)KZjX8Q8XjV-J`$#MLkHD'
+CP5J(a36hXrM53F25SiX,ZFVd!K-&a"[%e%V6ZQf`IPD*Na&-cF4d3N`RT9jBkej
+8#UXUKf,k,+Y2*X0G*(Mab-1+i+@m6SANB`(jl+1Kh9r-aU(ZjI!m&m2V&R8E95,
+U8dG$[-%XNKld`+IL!EIjqc9)K*!!`,E0meDDcQfhB01Y,&iBAVH4cjNH,eq'J2'
+EFcNC&U$JP#CPf`RHQ(rH*`Vc)G@Ib8R$Nc45E4dXEM8Ni%)Zq%PF[!q9j1+H00'
+P@A@'HBT8%J6h$!`(B"+JPFd(8%&[QSP@!CBmZY$[FT8b+2+p*a)&A[8R+QCdKXS
+VA-a+SI+(-9'S(VdU&a19GSmZ[p%#SmIPTUkj!P)E,!4[B#U#BYLN#,N5e@r&%DK
+q)DpLF5(r5kZq2+hLP0EibNkPkS[T%,@H''#Bja9@&#J+L*+KjpS-EAIQ6TqINkC
+3[6[R!Z-Il@kRi)HCSAXC*"b8`+I+@%)+512ZiZr`D(iNfX3"@2Lk9f2QbENd&pm
+@j1,bRr2B,dAHHpL6Z46&6m@P)(jFkV@V+*KR0Nk'5+e!A,'[BG2fM&4lMhe9I9T
+jYI,B9j8VP&I'XDqqkPCHK@KVMcVZT$TiLlj`!`+TIj%aVk%09F1N["J+Xh0K#i2
+)jQ6TZ+faBlUdS1fqEd`"k,*Yl5cFbldEUaTl0eETld,eEk8TQ`mJ0*Mb+r1,%1(
+`4KBZ+h-#M(-%(Jq`@[@-U%9A@@MDC)$)%SXcKDVHj@dAT2VD`9k[Hd9jR6rBkkp
+Z8PjlMhN0#(EcJ[)b41c'SmaBT&IH&)Nq4m&9'*9Q9iZdcc`,!U)F6N)SCh)jb)j
+`NSi)R`'f!da-%2U"M`pKNQ9@1@9EBT!!hK1@lG"UH)N*k,d4e&0iJqi5P-jb&9c
+'ZqJ!p`&6S@-B8hhMNq&*1mMeZl,e9-2A(aFE5$K,V!$K0'(5GQ&k@+`94G'GFc$
+CCFBmZY'+l,Z5`hmE+K(QbL#%"R`PV3SK-625h`&J--SGbV#S5+M3Y"drjUr[389
+SEb%p2r@hBDX5r0NTF9h$56ERf8(#Zl3jZTi$qkA0N3maUIV$!55eB!k4-hmii,2
+6X9BkYY9SGdZmm+'6e3"3V6A1piiM`,B[b%K@U$L4CK+Gc'U1GiJ8"5H!(11r2A"
+EQ0Tra5&HmDSi!(-U,GE)`0Ld9T+CMC2*hBAaqG5cJKNkSU3HAQE'Z[,rhNHaXD,
+Sl[8L"$(-(q0cUN9bVV*b)66h8UaD(FF(NcrF$Xe9aYDTLhT4c"Dd&MBBFAKaFQp
+p+,pGcYR!S&C(mm&B+&q1@e8RZQ"PQKKHjb+f'-ZE10cJJVB3X59@+G)UraIr,r)
+rq#pkc(p"j6m0r`A`Rhj3eS)8NL@icl"XK[29`rK$d%+0`SSN@&!BY-D'r!q(&%1
+ZqBG$"cAN(CcDC82q,b`k'ENah+SNkHT51(blR+lJb3pM#p[qi4!HZ$L-BqBLUAB
+Tbq@d`C1rM5eB3jCB,#1,NmrAYl@(X-$*AD'ZGiU04PS!F@NA)kU,Em15EU2U6%U
+B#Gm'`Ci!0&GZ0E@3!'V4T()E8+fTPVq'TFAU&V5,)69j-FTTJYLk@&e&!#a-L!,
+DqmD!k)Cb1j[G)cCf([%iUA1YT-lPSXlPSmjeQ6UAP"G!lKV"f2mEEa1klIreRcI
+18rKG9d1TdIrI,j9d-bZ2['PDm+Ki*0&G[1+44cMerX,GKYJPP,@dlDQYUL4AN!$
+*j6#-C230p&K1V)DjXa0Kif+CS!)aUA$LDV0m!r'B9#Gi%Q(&MdP8&Mk6&["`%YD
+dYmL2fB%MHLmN'B+`JQa`JT*[K[R&8N6L@$im5BG(eDJM,Pl4NNMaah[Aqj*f!QE
+LH1dP"@kH3rV81TMb*6)44M#AZT6kfF0PIrQp*8lU8J@1fISA,XGL-USLmIL&2#B
+KGi3RFqr+k#)+F-1!akZNi`%qI"GK,C,jH-P-cTCcR+,qEPk'`1kC2Jll+SpJbVH
+#J0"fhQFfiia%3"Q-[FpN,m[TS$qmaD$a#K5+hBJ6l,%-,T`J2M&Ei5Dl8RK5R*4
+MYdjm2)$$rq#6d@SiX2`"j-aJmJD5CJH"5[*aUScZ"DRE-4PmrMk!'CYalaQ&4IJ
+R*Z)6Ba+ZR4X"rMmFaa&F&)!mpf`M*RFU%TEfXGJMA+"YjiSLT-6,1-$#NAr!RrH
+cpP3Hi48cY15d`Xi`fi)rQf'"1#aAj6-K*E41$BHL5iY#8-[hVLH(`I98i+08i0I
+)H1$S4ae-bVh8h@5NP6SI!!J!$HkX[IL2'TG!(ReCHfqqZ0Uf"),H0S1$'3+m'(h
+eFm5JhMIZI4IKq,#G`6N!H@&M"Kqd43BbFMKNJJlaCZf1I((%FV"$USBF8MAd%&Q
+LEd5qQ,k4iXL3!%2UKKa5Gm`KDr50b"[T'bQ1$MQNGXJKY8-18BIYJk39,r*`[G,
+i%"D*CfE4`XRQh@Yhh!H-Q5($K0[,H`K&h&(m4&8$KUI"3+a$6DIb1Ged@'3f)E+
+*[HXpeTQPJYc5[[@qmpl65l(UB6Yq+[[cLjE8'"X`3ZVhB$SPF#+p#G-SChG2r0Q
+(2kX"#qlMp"FcNE&pB0m1FCJ%X'81kQSIM'Sl6(NIEVErQ*0NF+p%Z&X2pQ%C`ZE
+9"VTVE-AZ0h[206%FD&16U9ZX`(cj-a*`h`Sea`UNPd192FbXpBf$A*8a#HZGiXl
+HGakIlHi8ZB1@B$-V0Z$SD9QjApRk034r4R(HGXlh'LkqST&IpqVGJ3q(+ep8la$
+8$F#!V84akpe!J4ZLU3'P-b5(JrZ@8(3DG3)%eepYjNk!)Qkp5JR6c3dM$`Bl(,U
+q*4d'%UPiVJ)!Vj1AC@'UllacbZ9AHh'jebG$KG$cpmR8V`pfjiN*lXiC#G$J*T6
+#IbFi$Kd!4IMCli+d!VDeim9*Aj)!V*0[R8DDpM354&h'I'2A`MIi*6VD'"DG3"%
+diFD,`MVKD-mJ13`JE"[IASbmqU8l1$)lR*@[EKSHcX['*@3N#(Thq9I''HChRFr
+1El2-GF2-p`"X1&'BFTh(cB(&#KNE"@bL0KF#cprRMFePXh,$`+bf'"`$40+!bbj
+-k#rplUcdE69#+2"kF8R3e`&fEmTXh,d*K,U%#68"q18-'[-$Z(PaG+0D83KFL4c
+qNNK))%N(pm4#J$l8m3FSjM#$(lM-$Ha!FS+"LXPLb[lZKUi&Qe,!0Gcpi"$&&kL
+K4eTL,dVTk&U'V8l,@(C3C0AEG6L@PIAhmY9P4I+YHp8PSm'ai'8j-eCG4H69,!l
+DB-69YIK6``'@FIk4%XN+IF!lIZ5`0''L,K)3a!f$,QFbd+HEYQl%CAcMBM-[JAS
+IJ1LQ2,-J,SB("KmVAhUTZY*Y'Mrmihe`9iE*FC!!Jr![LFlR%N&FV"bJ!-1UV6R
+T+I!#GN9hrDREp'lRC8B)")%A@i@EC&9Uj!&-FBU&`q4KDj0)ID,DCk[h6!DHNC-
+%SLkrcNB)V'5XHLqE0UTC,N**``A!`'SIUbjMBM)9b@X!K,3YRHMm!iScfrMhcXE
+1ar*JlFIK3JQMpYJ*CSVi1#4-ZH2'Fl`j*!6(P8"DK$81)L!M4$Km4%EF4$`Z%ZQ
+i8Vb4#-S0K*rR2-A&(q1RU$K*(lZ+Pr0(eFe&APd&9[#R8PEAUBmR2N6T`dMLJdB
+ITK)I`[5K)[%K3KpbB`%e!j0ZU5j4ME'!1mSL9jXaMG!dP@-'l(GL'DVYVbjcG*X
+`%Pm48VaP"3H)r10'B%XRM-lekrY5+XTd"aGq`A6RbC3Y&1l1IpJa'@5QVkeM8U*
+T!94`fdQ!T2&6$8r0XTV059qc%HIdYT1C`adrCPHDl8IHJ"VY)MADI&RUc!EFDm+
+m%BpFYiNf*'8Y40(+bY'6T'hr$ETbZ3M4K9!Kl$)@pT6-DflV#iNe6@`$*,Ca%YY
+8'M[G5f,V)l(G*E%9Np!F*,5l*$5940DV1K,#1T83dd"#3#X6SXNQK&+!8,b+8(S
+53M%63JN*S6LTQceUJ`0lTK$SEpp`#ijphCj@JiV)Zh(,Aajr+GClr*ZQE(VM5$f
++BGjTmAIj*P+hf"Pf@Kcc0rJNj9TMSm2#h4i0G,3V8R4PYC5KFe,H&lJ6#3J0US(
+CaE#MBm@Yfbp5S"1T,VNpS8!ZJ#Lq8Z0kJ#1X!2dd*R,#T4X11A"EBjAcI#F$d0M
+L@(A0kA1fFjD@kPUR*@U*eFCLZ+Pc@N"ZmMUji5fT9P)CmB0erk(!0,N3Nd-B+c8
++$Za`JUpM*hM[GQDA&-8A4RGMiBk4F--NeKRe-KcPN9SJKh9b@Z!+[A3UFe@"i%D
+-m`cZ*"j)#8C%GLU3!&h&83m!`T)ha@[P%1[",[,bI[dLR[Khm*Q+c[lVXl%U9"r
+%%+!U&l'G!DfA,Di("!!*J2#h"!HQT9C-)XIFjIa)5AL'[mhL5,Pdq"A-!!N,%02
+N[0J`B#[qD$9k6c89VUV4SSF)CKX%c$L)3P-M0$%T*HM-Y$%mpLA*F@dT"4dAkA@
+4(Lc&4K6BeS!b9Y2K+Ib-b8ba"5a-d565`a[AiY,E6M9mIX6e!!T!DVZJ8Zjb9kB
+IUmFe&P6R#KZhh0FCjS+*p'0f&JNN6ZJ#$"j`YPq-I0,0,LKbQq(bCb*VI0(q#ij
+ED*!!j&c92[dc%IJM`BB2D1lc%-#a46KA26ccYVMiBhd`69l-DQ!%651Zb99'dM1
+""b$!aeDkf%9rBHCYU,`4Q(8a2KESifdm-KTT`BGQqM#,iKRPK*U2652$bkYYh"e
+L)hIfbiHS3Fp$I3riTF'(C@6TUBCAcr,PBb0XkVajcaL1cFLH8`f,0[(+Hdhf'2q
+%"j!!DX*2mYGRC8ifibFV%Icam6rJQq32q!8H3JI62pZP$cpKHGB2SrG0*$DBF2'
+2IH[1rXJDN!"YG[3EF5H*E+qQQ`QkfCIKQqE[L`ILp2&!J@p+(k'25b9b&6kfd32
+&p!#Vra%LqpYj5QaZ16hJS`IfL)@4&X%Li)9AX,ad8k#E'Z@K$a9RSa(h6G&)LQl
+1dJhJrQLBa&SUQ*E'pJ8l'CXT)))q'!K5bNiXX[P0c`!BLYA-"U0ipKRaiRcE15C
+!"S$cf)'f#lLaRfVB[edK4M+bcl!c('[B35EHcc"4H[r(&m!@Ii[%Zjb2`jmf((Q
+0(3d4,Uc&iKjDl)ET,m1&Yq2#cX*mY*h""3D1!!lBH4+9RT3!*J63J)I,+4QdKii
+Z1p9`Z*6"A[6L,P)Ga9ae0*l`XY+k2F[`,iU-(CIf'DiX1`I9C#dJa0IJJ,6$(9G
+8T+Kk+cHU-ZcS0#[J"2&q8mH4*JiJP)SGGHQ508-Z28#'Jc5pCq@9b&@0&aLQY)"
+b544DBU&`JGjFK-A01IQpJGJb1Z#h2Jdh+P)1!"PLbcbpbUBQ5#(B!H+X10,%5FM
+BDLGA+IlM*UT8r%UNT2j`2EE+$mCj%YZ$4qU84kV%4iKE6%a&0CLiP&bhAe`F8ei
+diKp&edSK16$+AH[TY528YC5ZRS*3&lKl2Repj!&ZEJpfpDH[d+GCdG'I[JRfmPQ
+K0TjqEH3"%e485[@%LCcq9Qe@@"@UR,r**mMX6P*S59*%-&GX2m4++-dj+bZDeic
+[ELBhIb5k*SU-CHfc`d`b'lYmSk2ajlSDfUHM0pS,J5hh1Cb#!SL$Q!@Hlq3JllX
+S#0RTq%##('MAdKScQ)UEp!3h@10N!eLR#VI4B*QGbma[lbib9Z$BepZCf&-3NC'
+Gl,6ZXiTQCm3NXFX+8Y6Nk'%4$G(#D3f16+1)NVr1pKrFS`f%del5"U#+8hrr*DN
+pmSBaAf3diT*rr`B1#3qQ0kh@c+#$5*`53"22D%KF+Ha$E*JCGM5XBp8ekcrT'dD
+hUk+%bq-JAbBl-[hd$$p8N!#q`XcmMp!B38E`!f!-2qYN819dSmCGA(+U-eQ3!2j
+fRh9brYK,9A0LG)**S09kM)0!Z'+-NrbFCRAf)Z&N,rMGVBrBcL!je'rK"2eSF1p
+I8F%pKH+Z"32D@3MX[Xp!4$EHH(V"cNR,aY26+AUS&JmpTFiL"!`HrK)9[YPiqRD
+TXI&`24FjhbkB4N!j@MjhDqpIJ4312TlK`fEC$DP'@8+ITLI!20j#8iFD@U,aC5#
+dTh`bGJQ6@XqX%GLY#jA"ZVUSK9YrHC*4"A"@lfC$R#6h"RDR0@"jhH,XK8YR(CN
+%6+jJ-NQ1YY0LN`2iU)82S+BepVF!5IkZ2&C&a9@(#UGLAcHi)BK)jeHP-@i%iqI
+BN4pX(X6[4&&RLJ$RC'"X-SZ1-bCcP%k[B4FICJYC@#!!PA!iDhC($ZA[rQ3J-0i
+prK-81C0ldi%NMA$G)RHb5VeC%%'!V@#6*rlM-U$dfS,SYXQ#RJ3q3CIm'KXAXfL
+LBBI-kHcDUBEGebPY,RdU-lPJ[RZ-HHlBAV2a(*b&Q2bdJZ`!NZkr`"8pFT+f$fJ
+EA6kR'SDpep,BXF!%+YIE)R-)fQYl6kUk-eA5m3D$(!MC9r*@I!A96"aT2Yr*abS
+A6JeHH,DF'$EG@@!2QqXB#K-&QEZ-JX5$'8-8*UIQEk%Spp"RTm%165K1DR$-l(*
+iU85c-jQ&bQpQPCrZ'J43dUXA,c8(+,0+"Vkh+-Pf00kja`iJ0bj3)bf#qQ"Nf$J
+Re!Vjl,b!B1(X&',&0BS'm6iR16(C55#l%,,XZKK9P'NKTiZP)8l03%afRc[U@&3
+K8iK6pECa-f'P%F8H0#GPjALIhA"10@cCUC!!pFHj`abjJ)*!)L'69je82'CEGq1
+Yfd+0rd)GjimrE&+ea4rqTKZEV&)+[C8+c8`)2*836M[%MCH1*[&)BiY-6F[U(8-
+#P$T&M44QlLdb-cbDECm*BM*QYRm2B6*3aV#H4Q!(,Sm$P@hQK!J$C-2#F6E5eXj
+"Uq`Tj%f'm+0`I"1TeGmKL9rPadH2q2!S2T6JS5!%9CHGT`YDp"3)1C@@NXS`f9R
+,hdi0e1&NaZj9&CrkQKI4c&jkMI[qAXmP4A#2U`jf"MZ(VSVL6Tf4T9*e1FrhRPr
+jU4R(CIjGQ!-E`bHhf!3f@(b&a@lPS$ZHR$M)Nc*(CB3UEP'Y-i"PeEL5!,S2)d%
+$EVJIe[YlI38BS8PXKpdGAE633G5!6(4Da8dP1X3jU9iaIQl)Q)%bb9k@C&SVb1"
+c"UN2N!$p9T!!r9D$Qjr"PElB22)A-2Tk)`q'Ni'Y6@U5!XKkr0QNZ!eCS8!DXI8
+H928pE+f((!JdGaCE82(a(e%Sfe$il+VQa-([X`+MlU8djbI&e5-8&aKA(mM2M'k
+`bX!$jH5d-"EEK$reHY)Il-FrSJP,)iH%k(VfUkEL#$ZDJmX%3)ZDf(X!,lI$4A9
+2V"`1ZVYLCHbQ'b["bjGM0@#(NJSM*L09KYeKDE`e1i$MAmDIrILcLiFmq#@A,KP
+bk8@q0#UiR8M,bmhS6YDaf(XE00q%2`Jc1V!"Rc&C2A2(VhQX'c52I6MJZ#1D,S!
+pAIEGCA"@NM#P'Xm`rc4LZ5F$J$X5Uf%h+U!6Ed&"m'4X'jB+*eTD#YJ6S&[ChR&
+ZE+Xb8e[H#p!cDalm3EL)Pm'BYY2&[-V&A[CB$lDK'3'F,Z03KCZ1mL8J[P`KVMG
+"Ll1!&`F$ppMlNmY*#C86%`bJm[GRpG""-RYG"c@cA#JTGB$-cd6$KM,4)"-U`TP
+31#UreLm%CYJFV0UFl6HLL9qCEcmfe!SeC#8bBb48N!!"&@3)&45V!N(K-+S5cAY
+U(#F,pJfhTZ@k$iFSS[@k5jAaK'c0X2-+KcRVL95[SHkbU8KdPhC5MZh$l`UR3Ma
+3,aJP&02laT65A9BFT$XXSqiJJpq!8XNUAD*4PF%2UG&0bf9*,0"U"YlC[%ccLV4
++a@8%3BQZpP#-p8,Pa9B8mR'S0b8"fL-DXK*m8b"SET4!Z9I82MVk%`KdYATh*JM
+9qJRqV&EpZTS-RP*8IKHk!NMCG+RZQK,FGX`V0[(9iN!eS9D$c2*riU%ZiHL#D&T
+qc`ECmTGRBbh#lC!!#dT4[6r"`k["HVA1(!F4Dp'*'%*J-&")A&`hi-!1TMH2elp
+3QJ2XJq1FqBJ0k9X0$4EfE4KBD)9$8+KaB0Sq#YJ'M34U$lA%eR0LS-%bf&JrGXJ
+[ICUrhrFcX-P`beR*a49Tb(Y#lQK$h[FD*hPJI%&+64fJMf#YBJHHjm6Y!CK"LVI
+#D5[aq8J,J3+fV%PU'bR%-p'X)$T,-2%frc83'bRhRG'BlH*Nmj8J8XeKE[c168h
+e)jd-UHiM"dY85EKBEV%mDQ1S&daI(SY#rc%5Dr1&AfQ&@iC0C6Ce'C`!IS*+lH3
+'Kh$A+eHh1DGkTeDf%URjH4UT%8N2*MEK9`*d`$D&R*c)-%6I"MA3"RIp8R89E6q
+!lFGjFfJqe()QLNl2-)60IpaAi+B#(MXqEH*2Ck,%a2ifYNC0dI3K6'8NTDL&M3Q
+P-+1$hP!$M9#F@9),0P),YP-0[qY6h&RA`,%G#T*!l3ZLBh!k8@E9diTkf*LQ(-4
+&Im%APDq6JYJSe!-,"FV"aL'rc)+*c'BY[cQ1#Za5&)5KQh'rjB88KFcmMJmUJEV
+i3"fPT)ASeRZS-`pPr-S`,)G9"fMiD1SFXT*6SQZ'0Tfh@NPeQ+3k8JVBpeQ!I6i
+#qciR3ZHIZKR#"$PUi(5QCi$#i`'#qel*"&9R392J2Yk`$[Jj&DE5#[D[hG("i"j
+#ead("rFL2RD5,BVBfMhK*)(8dMi)c[&3-Eb4Mc%!%!0r5'ip!AECC3Kh4bZT&6r
+"qaG&FPpZBP9ep9hjUH+5Pe)!EcX65Jabi54)#+`q'm!NNTcIc$#Kc("6J*Brbm+
+k[,+`k%qqM"RFIp1`F!`,ArQc,Ia+VE*3F6FP'$S0`-JF(-$3")"KYDB$')$#P+C
+H02M)++Q60Lj##0[1$TVM,mP`E!m)`q@-R`I@Z#`jC-i%qc[8-35mafp2C!,p(D2
+DFef1EJ5[28L'hPF5Sp('il20ZB#MLer[r5[peE+1k8q-`1&1GYI1cMFHAj!!`H[
+Fd4Z26mZJTF!+%iN!0*!!Q'#DKJcGCRG,J5kHJi-X94B@KBY3i+IYbGFcr")B
+4bl!DTN0VP50,P!2VP!2VF1!1p4!89MNU&GH2B[D),N+U-[Ukk,UkHrPZ#e6VGV#
+!&NUID&"pB"MQq+(J(XY+'Ef$0V["k!"DM`@8*N-i9!3pbND6rRk2M+lP$@*,e+"
+-f9)9YV5Ah8FE"aDH`b3*XV(cQ)dT+MbU%&bSjI$3V89fdGD#Y$8E05B#!dc#U`4
+TX8'dCY[e3[kLc!Ah[M0%I+(qMTa@hZhSf[X1a"FkI$m"98"mR&,Reh[Id9me3(b
+&d"@0)3d#55$!b#'#55$!L+h2Em4[KX%qlm#fA)12-LbQ9'Q(8Vaa8BQT#[)B6+%
+U[+L9UK+PUU`H@XJ9`HKT'I2ImE&K*p%(l1SB9hB1eGY`"aZC`8ELMAH`N88K#N%
+qaD!Q@'$ehf+h(eldk2qq+$2q[LR9QQD-TaI#C$LRCm11EL2Hf,f`PhrJ'&$#30c
+0*+GI'#jA,r'(4)9#kHBbT%,#X6##kUa-E28i0pQPVD,)j$ZL1-4@pF@mBEGG321
++5pfMkZ0`NQKc"cCB`#"S-"YZ`,XGkE8iTmV8#KiJ,"YR-'l1JV!RqL-iP'%5a#5
+)53!6$C-`*J&-2[i4Zj!!S5%&*KXC+-43,H*5j80$0(*BYbSTUK5D#fKJDV5FI@a
+qf5h2"&3ch,#-94MkkCE2ZD+E2J(D-cEaB&#qH)%"2aJXYTedacCB"SGZXUE"5@J
+md$$4`)#4NFqih1EhE9IJ'Q!bf&8&jV&Jj0GrKjPPT`X*DRqX8SFri&jh@53C#Rj
+eN4e&j3k#)KQ!21hLBEeDPD3aZ3HrfXQ$E,Mh(,%CB6aFldipBJ0T![RDbSrFi`(
+k8Kd33@"k"4a"Qr@%BI9Q2XaRCa8)dd!)Ka3e!&B-Ge@HIMXp$M&8&4c(Aj8A`0L
+piSl--9KIkad[5[hm)hF@!r)K(2'1pb%KbMG`&X4V)bKH'0dcHF1"C1d&ESL")Ep
+`f2T4)jA@Z++1#fZPD)JeF88D+5j3$2Ph"`eVeTjUq+0G$0l0"AKBU-2R8'8AX`N
+l1`Y,B1q6[XHK*T1qVj(5V()q!B)2+0f)$eKqE(&B`+C9Q3cY-#K6q3bR'b(SbAN
+-3[HHF2r*"XCYKbfd94H(i'fGKIbcH&LQ%2lKZ29qKKNmiZBl5(K11(""Jcp"S5&
+YS3e@463&B+I-*eCLif212!r"KH-GqY'm@Br@MarDYTfU-!(@*L9Jhq6Q[JGT64B
+VGHJDA6J1KSJCE(Bc3DS!JE"%K3!N9km53,+[K`NY[4UMbMEMj9VaNU'jF&T$b-&
+"VKK85MmH0pDEF93`!rH85LjZ`maBe*j*[QLVFM55aGAMbQ8[+TI9Ab+a8Ce6AVi
+f5GY*[%4$K'T6H6Q$6J9"I+m[Fc8"G&CFFKHlZDYYC2F[%iqe8YSja!*#Gi&S-6K
+JRG4q`%RT-!'1#9G9N5"1VdbLL(ap$p)+TDr[35*&I0!LTS9FbE(%3Uk@NEMPLX4
+jqkdh#PH9E@-BYBf(A!m'#aTT+3D0`fJ5bJaK5QdQf-FeNhmk,kdc!(%if)8)2X2
+X5pm$[A'%Z@J)Nq2&JTNd`8cf`M`HChALCcA*5Qf9mQUPfrPhhX+iXGbAqXf$9eC
+%MEQViamKJFkT"5QI02U0CFcf)U%,9U[R58ScKihlQAj12I-J3Md[8Z+i8L6Tf4A
+Qdc8Bd"%-U'm'J8LYm4crrf9f$IRdMj8K(cre'eFRT6i!j+GhqAEQE4a@*3Bpj)9
+[MD2DfNb1@%'`PCY,qM"%SC(d#D$j4EAA5!T9`afNUA2U-LIcT2%GGXh`HkIJBT'
+#'J%,KdpS8L-D%%fLFBZlP5HF,#2h5k4Ef+%"BVRHakNaVZKT*-E!H#14VaRRehq
+H4DG80iHd@j!!#dqi&aLIF6h3%er#')VNXrFL(q,2$EGm0KrjmjPh)fYrL@#h#F&
+5bVZ8a!Y("0`8dH"0p@$[r8K22m3GI-[G[JF(%AXCLje*%EClV1$hR'S)Aq*'h8F
+*rK0Uf2l*hhNcidEUB-+2G"Lp*2be*2)6*(!-`'PpL34H*EVJPeFS`TiecZY$0AU
+h'lhr")&(eT!!`&&XArjD3Z"mkp-&rZ8`#E`'S(Q01rphAQr[jmIK+"!qHN0`%@G
+cl*f"H`'!d&ii%I5`U+TfdZ#LCGcJ@M%-+3pa'1c-Se0Gd98qQUSN6)5A4lk"#X'
+XV!Bj+*4jHqmGMVa(*S0E%+m80T12V$*-RXK$F,@Q&"*prQ$Q@@F[Nefi4+bD6)*
+N9@*jbq6(iXCGr(-EEL#bc@fF5#j)Q"8ZpU0D0L[I+"*[0b-Yk&TJf0)$eIm$Tk4
+[2a$0#J&6lZJ64JL5CNb4%9B*%IbSrZ"'5!T*`',,2A&R2a%cKf&b-j!!MCrcD%8
+2UGP6$D&C%0)8f!!(*mpHl64k"B(KKN3mq1IQ*f&drHXrciNUEJ62"UGIU#rY3X`
+!iD"iSCHGj&%GFD'eG+&A-*KX*AGAA!J9MA`$&h)FFb%E1R3r*E9$aNhCJk'%HrQ
+bQ4Hi,)1TNJCT)AFi5P#!f$qN3Z8%QQ!!JPPEaFcDi!#MVBNKYTL"#Ud@3pRk3X3
+Dl4*$d[)2ZU!9)UdM4SVKacTh6MKaC2VGelj[8iF(3hSmF!mEk-B!!a63-j0QQ)F
+&+e@VX&,A%fa8c9!fkNT%6@&SiQk2b@bGSi--3@hXQ0f[6kIc2+JV-8e0B*VQ&+D
+TC*!!68*('l`T-33$eU%`5dd*CURfB-`5&dB4#N2,-'Z%EX$$h2B)*Bl2'jM&9$j
+Vp(QG#-9MG9#4Q`"l`(c51Y[192HPXprk&`$dh8c+2'%eKHDA+IUC8%0&R2aU`6!
+%mUB9!M3"VJPia8*(2),A69P0BD1U"YNS02j-dU!+8m6XR#B@VISJ,&Uemcbl%)*
+4UrBd8i2&-0a[SCSL%d+jkk`BZTk6f#rH4T)C-,%4JiCD0R,#B3e$CVGlV+PfC)%
+I3NSij8RK11%L0qTkS"!#&)AG58i9+*aB&@kEZ8ZQ&68$5@$KSkYC$38AD$$ET+H
+BLK++IGfX+%L2bZ3kC9'+d+)8SCq+81-Lp!mm86'R+D`JP%YE8b(23I-ac+!e8@"
+T$+(Fc`aKkj!!)3Xi(1+ZM3&T6eCFa4EI36I&YT4!kh6EK8cH0BA"K&2XM1cqS`m
+F+kqkB`"DSC,Ir-ALeA%'[$ZI#EcjZ[l"0d*J&!qeB[*Jd38,GmD-%'mqmGJFP)T
+rF[l0#r`*3iP(hicKd`m+8UKkHLL1*JX3h8qV'&b$fQ-e&&Z@pfM2K0jm[H%d*S%
+hEk3GS!fQM(8A2rmE''3hM+@Mq21R#9E0j)%Hq)&[BcMAf$TFj-A#94!jGZGC"dD
+RqMFBTYBL*bZQVe`k1r-X(VU)2jIGX[lc'0b@h%JSZA!#DDQ,X3m"ZYbBi3%E2`Y
+RqC93'4H3!,UkM!6AFXqFG4i$YTchqJ'&Sd(#qM&q$!b0C@d+L4`dL2[9YFFABZ[
+Ka0SbIICf8@b0Mb&k'KVCJkl1JeQTcX4MCZ+a%$m'T`5k%)BB5KcUf8Q,3@$-#qj
+("90"fpa'$mqabffX&Bp[JcSc8#d3P`K-Bdk1Iq3"Zfb1k1T@$*1VUeZmQK&$#@2
+"#9,Q)5BRV'!63`Ac5hIL*4,EcXmN&[A4Ll!J0%FY@kQrrM8lpfPT#ifdKH'M&ND
+(,%blS#a*@jJkGU%m0'4KbTPS%NH[0`ejEDBGHb(Y@2Y4aeiDXY!qH#`2hEjm[I%
+CIK'P,UKr-M,iN!!BI)6*@3%TD2KmcKGK80aX2*@2`-R"jAHdEqLBVYh3-DXCbI6
+"4hKJD,#'la%cc1""-l'+M3K-mX3#[LZ+QiD#9Z#%m1+9Q$*XX4JqPD$jf'-mJ'a
+Nkfm%d`%@ae3krH,9Cc64aAP!F5B8!"e#9f*i["jNS)5'$m&3m-2,)PP",#Df#a*
+#!r(HP1B)'Mq#'DVbrR(IR`Sh&Zi-LJ+&bT`SJmU%dJPHHhX)#mSAj1f,Lk+,,M,
+VY1iNA%iaLC36ZbGH0EZca!M1mN&*mff['-EYKBk5Z`6lZHj-Rm+)"Um0(LGAZ9e
+%@&eJpe,%("Y[$`Q-MMV`K"K!&1`5+ZcY4m"aHZdBKTA[4e01+#pfKZ@$0,'efKI
+FfT`)JpB4HdrJL-YVFHGT+aS#PHAN`S2U4fXiX)9SEXcNe4`(*Xa%9ql5+b3[L'+
+5Vq'Sf!T@R(LBKbH'SM66JeCKGQi66@%Ub3@fXQ#U2848dJM)jJrk([5h%lPTpqe
+0$f,B#)R4l(GLN!"iU'Sr$`-[0[69%S)Kj#pjq21*Kjp-IjJCP0*&FQR'j90G)YJ
+XZ(MSprqFrYAX-aA5S[ac"!$""%PDHC9GTL*R"IY!JhKc+M8j+L"#r1-'&(C8RIV
+LNmYb9ih3fk@CF5%'AZV4"e`DSr!'KTNbK5(cJ9k6"pR!F"Y64LMGH&1CN3H&%dA
+1lhpNT1jDVP6D1M*jZ)jVlMiH9[ZZaGEKc'F!qlDGH$B[QLM4P2jT%*UD(*E5e%j
+!0%qYQ0TTfSUTPDB'TUddG@*Ud$5$UC1Q18`c0-eLQU2T0Nbc0&h%G"Y0+c"GT'N
+Hd`UD$Q#DTqNiTJ-dRF*dR+BZ6+GSfSZTLkCpQ2E5G!61Cpj-J*S,bAr9-S'"MQF
+(T)NrG[baiNmVrKK'B!Kj6T)BIF@r%Q*dINCKj+qc8H!I+lLJUaYGL9CI5JaTa-e
+%Z,XFQ&bZQdH3!*0-U3,B"$$PqJXB[eDErN)RkkX[69mKXVi@IpB`@HI3dP1-fcE
+HN!!lJZ(K[[M0CYi%[d,hlY)ArmZhE[rUk-@q@Gj506IiDd2hMS,NVSf&b$8J432
+L'QMU8H[qH+h+K0BhKim'%U(E$VE-(6[i-LMc)%,e$U5iLTajiFVrXCX-P#'50Uq
+Mf2Rc[iJc#$kSB'[TXDi4JJUU,Ab*kZYS%[F1-aI968Xd$'Ce&eqZQT2"cIpaY[T
+kE)3ZraUr4KLrJ%2VaD&Va`5Vb-2J`fNp35")`5"TVK-+TGKZR*(1AU8"GGeS(!-
+D,IDamfHPcQ#k,%3mTYBl"d0mN!!M#)Z9&CM,#e$U$+&Uf-a))6"9NHA468j[2HQ
+p*e3X&+,#NNFUa(!r[UMMP[+CeH4,Jjq4hNJD[3k%4(b*3@Cba@P2R#kB5L0b"d5
+K1-jb-99I)ZC+9ZpP9i+K+H+VeM%aC(0F$"Z#4'lciIXCqpD1`Me@PmC!MSF$DdB
+UKCf9-830TE21FZ$Kk1C('VUQbaUkCYNGZFIS9Re',`r`Xkc$YcLUZBhR,*`DG*X
+BXQl+#1T&T@bcNNN'#ZQ1e#J&G9*FY!$QkpRM8[X#,S1'V0bJ*FN!&)8j28BA&i0
+"EXrTDBDVj,6+AI25YGRL0!A,3#%FD'%J(c*CA1mA8&X"$!4F*$UQY3dGYm8$ERT
+J+#12I`CN8KPLA-XTLI,aa"%Q-3Q1V9r#b%([bYR'GMJ!qihJiFlLDfhRp1SU"mA
+"@Yf6XcVB'#SQmkr6e8"SJ6lm1am1JQEA#4T$DM"$&8(jp8bH!hJ+pPbMl*C8LF5
+AbB'R-3m)(L*Lb($QhQ2hC"KrN!#8H3c&"QH3!,!R3fj5E&JQ"RHUi$#0Nc[V0M1
+XNj'2BH"qQ&U(la3YQX#Lj&','0lP4CqN,CV!STiLmj'23%*)$6VU84JEqfmaBa'
+lH98-')N+"eC4Q2R[SVU"aK%Lp@pq,Rhi*$%iU5l)ra`Ub"*GN!$4'``9N!!J5a4
+"KY)&'Ee%$a`Mb1KV*%L!6Y&C)FMS91))Hd+3!*c35ZQ#I,@cf$a@N!$4CK*N5JF
+4Y3q'#P+lN4"NL3,&L*4@68+Bi9H&--fMK'Q('6Bjf35Q#Xrarf4U'3*q8dMFpN!
+ijN`H2h%5P(d1"Z!C(5USrlcdVlpL39@@TJR+$N(K(qULCFem,*E'$l+8c1+VC@P
+,QfQT4NZYbP,l88Y"$QRT"fP,VEa8(U+P2FV5jS-X[8e,h@P,HfKT%beY9CCDMc9
+),"AER8YEfSUPGfPKk3X[r*pdbFh9D3Y,XE!8F(U,q#G'%XBFeSfj@MGQ0U%Rdid
+j@NE'A$,8Q-8!*3@#kiaJBTK(!HeY93eK$S"dHVCE[Yd1Y[6Vf!)(35(ab0$"4ki
+Z-ZMhC#G",D2-'MpjA3Q6@X(X4Mh0!)4i!+U`Z3bDM+"e%0`mIjT"Q2cN+3+l@Yf
+'#&)m,*JJ"4dD(@IYSb"'RL3@[j,r-5eC$hMAlcSr&Vr-iGbm%XkG4c2f@p1ebfl
+jAS-MJVEKPXme'ZcYKS)2&!9helXX3cT-NE2h"e$`2'3L1bQicZFfU['CHh2YAlM
+(lS2-E0+4hG2lm9#RH'J1`CMM!U8I06&i#QeZ$F+BX-IN&006F33'!ra"$d8)d!R
+65k5V-*aF"4-*cbKh,F-&*f0lJQAA2jRTRr!c*9MjTe)S$%f"EDYd))%('F2,%)A
+*!!+C1ANUT!K"bMmR-8Mj)B!XFXb$!9r2`('&#YYbUU%f3d[Y[2#E!j`-%CHV(FA
+a$IqmNekRp-rrA%kI1d436SXXp1Q9Y%mc1+Ch509kKe4VLN&S,Q)DlN`N"j2L(f)
+#9#2KE1pIrpmi4+$K8hR4GbMP&MELBLJcKQ25i)8J`GE@CMc%Jld##"l$[bV"+6S
+FZRjdF%!fIV$iTlCca6h2er1!1G&cl,pbbGcbTJA$)NZ62k"j-9`INCB8,NZT3@#
+Frr%MEVL#MmG!jP&,-#CPXFRrh-R"AV19&2FFr4TG8I)rKmI0rQ)a0T+A[mkK2J1
+K'@8aQLC*VjDf0BKI@SmjKSG*6BQZ#fJ!#6*b-c(45!30J!QZQ)!jYb2Ga)dI5`B
+E!kF2``8!!#-E384$8J-!9q)293eQ4!)3)H,Z91r"58kmfLZjQ#[$k#Fj,aH#(%f
+Yie+UJ-DF*cfZB#RMZ[%8lNk-r2i@N!"5amfF!5eMhDiD0q0f-PNhQdN6'`aLaY"
+EkeVMC"a$l@QXieLEB4cUd&3003FPS[$hrhl[ppeh`1'Cp0PRRhPq!"eQ2L34%#m
+3!"!3!""4,j@*[fKU`KraSeFSN!$5B481A*FXl*'maYH8V$&P0li@53akdN3GL+E
+--E2PNq8[P9Pl!Cbc)d@IcCmB%HfQ69D%%KXA4a*(HX!#39VJCaFkE"jBfEKVS%`
+%Tq`3CDrTE`C@0LfQJGZQaXh)P-kiD1Zq2BBLBUrZ*)9pq,3#dkC$#)GD4FIA)a3
+XkM6PI[BDN!!*)0m!`QikdABZ8[6&*"jS[eejIY+Pkm+2-@i+&Ef6CMDEkX4jG(!
+C6CSpF`b"@a3l3XpQMMehpCddeUP$kD4A1RNLL8JT1[@JNf&JAP[3j2j'%hYkSqc
+TG[ATh(I51Pi4RD3-kqehdL+*I@pc%HM#d(ZB-S-VkMhm6-HbaGS2a``&ADIMjd3
+Nm@#Hp8emBZ+I"HN$2e$LSRCF!U+dF6-'pQ$L88aXia2hi'Gh*0'qJclS%RT@qe%
+h3X(G1F)6@5Tek&c*TbDQ9V-VNqTmqrZEQKJka"CdH4TES*Y@aKBid-PTE)&MHJq
+b"@hL9EDJl9%4p)(iCE"iV,(JC,p`a50mXB38V*Y`UU9MqLJqD0JpTJ[ZKaUX0p4
+Mfb0,6iee!$PH9(NqDDJBImaGD62LE@Qdh6)SZbkdcc`ce)`#MB3@F`,mLCQb*bE
+FBp,41!2PX`@fpIY9l-M%VMpJ#,$dYbrXhqGEJLeiQ4K"NKHP*'Idp8AVdU0*bDL
+,&Lhk9NSdp42R@SM15pPTC`rQC'JCmNT,5dNqQaaG*2Cq!3reAV(f5N&Qh8RV-)k
+eap"L(0HZJ!QpK-43!-cTX`lcaABF-KK#&CKPTi%[YQ51D5($'H-CCbM1-D'%iSM
+pX0NYNB6Bj!DldT5B"qaI&1Xb#RlK[)dZA1P)l`CVVi36jCM*6B&fS'*ZcZ!LSM!
+i!XB9r-U8)rcBF%4dDb'JKK&LXY-"8T*6Fl*e@RT@0Mi2T#GRTICTfGSa,IGXhCQ
+8R"0489-TI1"JPLiRr8`d068V94Q+CZZ5,bTMNUSSk+Z%H@9U'cA#qD"Gd38RRcF
+l5)@aB5YFYD3FpeJ9UQT9,M%X3@@`@&J)m-#0dj&%3EC@+0h#(APer$)#3(Cma)f
+QZ9H&K435pdV2GAbGrLFe+5aUma!)&`F(RN5iI(HPF)"-RJjh"Q8UC8LrS39EFbb
+Y0&)Sb%2(X!i$l3$b*%$@&BL*`cT%S*4Rh34e`i#(2cmU(5aQd-De@P2Z,aBU`kD
+N)`+I@iPKiL0b&UTji2K-J+EFGcl&"+m"DS-3U+S'iU)TGdiT2Jj%LZDXCBSS$Ye
+qKeHMCV$11bG-Z6%62QlLLSM5jBrJF*)kSI-Xh[%"X0N'pP5(6FGCe"'2[Y680-p
+0$j1VH'"jB(&hbiY3R,$JM`-CINPP!B8"JY60d&)cUjdLi9@$dhS#b+6'@rR)8Q,
+lf0YJqd,1pK9!0%YXlqY9f&lUIUfC!T@A9T)l&-k))*Kre-LZNN6)I)S*K6dNN!"
+P%HY68(CC5%#3!$[dippp`GbPKH*#0+0Li8+Z(pFmA-Jpp3ZjYCHZN!!b*"lkKiI
+0R9C,apFjbp3Y)+!j4-q*fHLm1MlDm6iE@)m21YC"BJ%6&r*BUX)Ne&N,+5k,bfG
+6)(D5d2EeR8e+LQCRD%PC+9V@J@3YbkbPRXh@4Id@@F`kNf8q`fFT)T[N8l+,K,H
+EA$*I+lk@dB@P"kB,UN!h08VC598G-U)4!9#($'$*Q*-$()HDZ6&N,JpSNm'!"0#
+8M1AJl&S0F&DJCL`*bUH83HEJ!Q+,AVLjDI"$3`X2qG$L!AlG9QPK&"ZE-mFbZME
+8EQb1cS1LD4J&890Zi,Y1X60aXB-i0R0`ITmH3cLl(T9,3%lM@Kc4Y2%SB#6"6a[
+p2`'3!!QL3((,M($@$h+&JQ'GV0pfKkYSRC2efd+ULRMhDl8%$N'SYBlBL8!"B%S
+dMS`k&(96KPcZP*CF6(DcLIG310rY9M1MEC3rYF1C'@hpeCkk&fLH%NV'3)KQFX6
+,fqM!`KH8!dfM53@@9a4J#G,0JfQVV9hm%N&X6q+QJN`9B()488&RU*Nkk0V""Pi
+``48E!%T%3Dpd`1kK&IHZh59#9,TUf8I8,90)8k3Pchi$@1*ejd8A18XBEbV9qqh
+aTP)L0A6Yh+5LA[%hr"6!iSGmq%TBX(e`,`FEVRD`9kTYGEMQ9R(dI#ILSX,-0a&
+Z#5N&$&Xf6SdQ(6bE(Ud*1Cidk+Mr!EQi2$&#!Z$NC9DPr5CXPEE,cbTYP9p9QJ[
+LZ!EJ$3Bq*lF-,&qfQUUh&dh#5d"`%F,f$T5iC)X,bQ*3L"!Y8,$3f%FRqiL`Mh(
+fB@!IHTMkM$@9Q1SXb,i[AQ02698EQ+"U"Dbd"XbeQ`i1F(Q)LbL-!XVcXIecY*!
+!#JDam`amRL)'C#3dG4`N%SQ62!bB-aE)MHCQTIj%bmR@"P*6SYNjkFkS$SM#[RT
+'DfCT69*CUI)l5)8`221#d$2Jq@Rid,12+IBa34mG1US8Ijp2a!&9I[85#*YKG+C
+@)LG%d[&m9fjANMIIPA8"fp[P9*!!ckJS+$C0TU"e6JAj1Qd9&02`l&BB%'UkmD6
+MfrM&fk5,0mNZY[#,5c"KN!"GA)+I5TRL'f8ASq0R1qMLr-9#ba,LCR8eK!$+Xl,
+6I&rq"KLK`MT%f3je'G42rHM3QRZ-!6E,''!MUbi6RbN-%11&41G"0XN13Kd(*3B
+"!pa!*9G(+XeKCD,Xk)qeb`HcdMr3`T!!rMBCV%b,eZ@N*&-Y+*YEp96r@#iR1bG
+Cl*A*'Zr,R-dHJ0qRLI3h5#%"Mr8jFC)BD[5BH`c'FmF`F!c&arY3d+DM[ZlRK2C
+A5c#SiDF2"9ShLV1GND8M!PRF"a-UNE5rHqdhGk#3!2%0%H%NSpj8ep4%KNf01b&
+-([UJd-5G1kaJ5X1VdE@pB`Bp&NNmPjNjKSTKplBCPm&%M9YN6,5@-Um462I9f9,
+Q0B)j'f-bjPcMc$cHN5U$VG,&YlGb3Y8S,DG+MF)ldL4#Y4M-di,M-l32K2jVcAB
+a@@ZZL"pLh4*'!E*!Y%mF%GiEDVGlGQQLia-JIrC4F(&6dq3Y6#cmbd003TSk1Kf
+(PKifm)G&d`3l'#NcSEejDN`eaI+e$9PZG,eT2pjlaI1PQ9p`I'hiUH!cUardrU(
+pMcVrFZX#E9(hLiDja[Ie$idq0h9la$VaUdGqIZIh*rrXb(rUqfhrYirY(acSf(I
+SN`[[QLk&V[Cm*c,QrZEij,P[jIdSmmr2rlp6rrIC-r'cPp-cSQEGaCc$(ac-cFj
++qZqT+FN(dRjFpj-6Ih(d[lhpakklVpBfhl[jrCBrZIA6krrPKrrMfY,TcmriR`r
+mml6rqS0rrI$[h[[rmrr2TrrlihpmlHZ[[,Ai'fm8,AQRH'("V*IrBH2VqGp0r)G
+Yhp[mRcIpCYG(ZrrqXErCmGIE(klmhDTI"*DYH'(GccEmlGTr@r2,2Epqr*p+rqA
+qAl9qEZHrPhhjkDqXAllbdBU[E[NX9PliaC+AjMA-RY2B*-P"9KTUX!2C@XB"AX#
+f#6IXRDfGjMQM8Q$9%4S9Gm$30cMS5,5rl4j,%q5SpJPH$%TB%`TVNTK[5G8I&SD
+T'k&la,BS[UjYYp3*EqINc38JPaLV)p`d[KL9dDJBlcQ-Qbk%lTiD-hZid`C#-e(
+J(KX"8RZ6Sd1KZfE(lAFjS)Y4Kem0ZXF3)Vf4$`220&mmHl`@aNqZA2-*dBk(Y"Z
+6pf"XNRFD$hDiaicdi*!!l-&pcJFR!L"Tq,AQa@NLG0-XQUDFJ1fVmpN#bKMC,C(
+`5TLkB6j-HiiiLbX0J8ML$`JmVBK,iCD'9ULd$m!MU)3F1E&(4ITfkNiL2NV&0Jm
+##5H4"5FaR!r'AdX,#(NlZRE+*MZ3!&9!d84$PhX-drS`d)GT,f0D*EVEDF!*FVb
+LjQ!l$9TX"e12"qiDBBENX+31&0mPeijj0@9#DJSCe#BGhmJVV)fm`QVi9!CX&K1
+`DDL-**CINi"03b9qhT!!!C[&6Q$$1hSjX%%493hd15*,hehCd2VZ9bafr9984TQ
+b`hNM5bGG2pTd5$`c+1j`%f6Ra'"N+8*AC#SM(mB823@&,,*"E"(2'Q`[$U%`SCY
+"l!h%1)kh+C*iG$Tp%&Z-*0LKDIK$#J'[[NrCbLl!ie#MCUY'Sq#CAK3cmd$!L)l
+809p@V@lMkYS@5Dbrc05e$6mIbkV9(6*eSH0ARZEUiZc`d#Q'S-aqM#f)A9D`"GM
+01j-Y`)S2"LQ-$REP*PrC@FRD@E9+e"5`%Fe!M$)eHMChEm"MhrJq,IeL02f$P!1
+j@Qj15ZlCj25,[b8k2`R9EXECj,0D6SV'+Qmr5$J3bQXBkIh[B8R[-Mp*ljKIT2G
+m!-"+kj!!NBVi2*!!6N6iP3XJ)3Z)&1jZiD6f2Z&Jj,-p91XH-a1*YUS'DB4UmqR
+h6,N0,BcdJh(rPlDb6&aR5rSpED4-"!%@NmJZ4RD$N!$JC&HPl2,G#[RhG)H-r![
+)''52,IRhjHf8Z%!KZh(S)!q[Q&km#%YK$bdN)q%6dG3X,5X9T*MZE(*1@P5lI-"
+XMUCbUSSST3kqMQCFbNCf6R+1N!$(EU[-d%YMmYbY3B69FhGIAcfMTd2fkbR6$#d
+3$-VU&SQi2riT)qjlkb2ZZ6N`*qj486MZYk"+#'jdA4lZ2SbK`e$@d+FMF`q6f[4
+!8DGVc9B"P*d(ca"'CS,Z)%&2DZ)LlY&CrRDa##T"(HFK3aJf$h1$[jZd)2GB8P-
+m1)N&2BF+bq0`5#E5mL0fDLa)ikJ6XNXkC*GN)!&5-&'EBG5'VYfc8MM0`i[i0NI
+8L`F`KBl)3femJkPDmGfSjG14q%a8S,hGaiIA6VV-mlS(X!A22k2lfPTkV('$CXN
+%d@9aQRrR&JY*9)Zr&%j8LfIk*kV&lAk*kSlk40Aqb-$b&DBR)kSlBlDLHMbCLG-
+'@e(GHG4[8Ae-%G@Gdm+)DUQYU1l8j+)U&e&X*(MkSMV')@mpX[Vj%&Ejl8jTP3q
+ITVLZ-&8AekjErSNVa0("KE9CTpFXefUYa1Tf@hD(i$U3!05)Lkmmb-U2`CQRD3Q
+T'%PR,-i+["k4YA0aHa9(8B38$L%5fTS()qE8mi1PDhaD$hI-H'b24N4Er!Lj+(N
+R"'6LSpf(HFEl)C,bM8"iM%`-Iaj@$1ri+BD$ISPK"F5`K"*r'&RJf&KE*`aA1f#
+f(@V@RGFXX$!&4Be!EdQ5$b(H%L*i)%K&X9CHQ1XPJj(l,DqliPh5*cP1Z$J8a4l
+RA5b[5bEJ*IGGcQ[-#53DQbdXQEI'Qch0p%6ZG8kQJHb&fIG9FNTj[(*h`L+Sdf*
+4-j5l%`akLd9V+ff"kE[RdQrdEE1DfjS*h1SRHL`,QaFGXPMd#p3T50DQCfi*FJX
+CTL`@E,&EkmPXFIcKdUEZYS9hfql5G,UbHk*6c()Ca'5cqIj$(A54rSb-h4LiqN)
+a(F0dNBMrf0-3!8CNd#I-(!`-Z($4lp",iEmD$Ud,e0fJ6N,!*SJ#QeI('AAikF`
+a*&d+m8F53dXN`IT#+K1XqPeJMGBK#L8M'jUNJcle)DScRe+GSB,TT33$8Y9N9&8
+8JL$S1[((JD#k$9KqLT[k8()N'D[f-&Epml#XHYj29MAl`kS0QUhbCpk4+EpLB2N
+,JiVbAaMd@rNpe0fJ6P+92j-A,"J3N@G"Ejk8"9qUU#S,K&042#084Dk@-a%&mhN
+BAeS8FPF&lcLm8YC4PK($'f3CN!$+-Z#2`fD!bmm-Z1jA"Y3j9FFG%@$i&hBC@ZC
+bGkd@bKacEPp9m&DTNk3d`C9fDUaqP98$hKiCm'C+U0E&84fmmf1"&GB&phiXkL3
+GbpjFeE%@e(ci54a0FPZ['`c[YZD%)3I#Q1!CjF3KTNdKkEFH!BYlU)"NS4!pL&0
+b9HTkRfNq)XCV0pk,PZU(0)Xck3pRN@Q-4Iia,)ZmjLH,&2M&)MYNQF%FY,(cf(J
+"1A,GiE+LJ'9&8HcFhKL%%lT,&q8)Ll#Jf'r4MZ[DaTFUB!m'+if5S2J84r0pZ(Q
+(*1B!1*`A+5ShmQ5a$H6d+QrR!4H2,LP0J#!XP!DPlC8r-Ji&QbmJ10A"hHq%$$,
+N6(8)C#-5@4D9Yi8%N6QkQ8kh(9f04qpc%kBKR8HC&*YpLKNVm30T@ZM8Q('"6$P
+9Q,U8(r((e%A3NDDFM1AJM'A+I4e"KI+E4Zl!,'F',Z8R0VVFBaPHbBbJ2*N0CaZ
+3!"!Cj2Ba!,#CXU!iIl$m)VVemJQAqB5%k+jj!C&&j%6df'9(19,28I,S#&'Be@K
+$ibkV01KQ,PaDK!`Q-Tk!UeFMpflj)6+5`@''Z5QC)KEFN!"-!UAPa``YQEC',6!
+*SFTI3fEc5r,d!Q)&phlk56+YiFr`,HXd[X8U(KNRFi$YP)9D$bS&")h@M0+5Ah0
+G9Lei@0Ed1*1-%ZY,$'PN!P*qLV[RpH4SP`DkKkC6jR$(GrPlQC*C4%*Xi'6QP(0
+5KQE6TDKm'VP`q`A[2T-1)@FV8VkHJ4F+#F2!"1!a(Z((IQrT`jVp[UZdKIjIha*
+SDA8CLA4EMH0ke%H)000c`mHV5lGARl$d$3+hFU9E19JNa`V%eV'`%X6[YFb@c$p
+C@'NZe#lTce3h!YBc`)IM"3(fK#r'Ye9X&!Ni'#lh8P'i''CE'Fc!`,H(&mpDR3B
+'[Teb!i2baG6daiTl5"`iZ`!+Zj`R+@aTCEfEe4!1X(bZKB)"bcETlGSK8p)TN!#
+C&"6d28DAFM$FUhpq[$Ec1J"Zi5paQ,M`4@jM5P--`@ilQ3E$f9ma0Dce))P$6'q
+rheakRIjIIheY5fYc#+E"jVDM[QdJL$1kpYcFH22b2*MiG2'$I8`0Dc#(IC!!LMr
+DZkDN(Q&p%mAe![8!5'DKhILQ5cqBC%qiX,bT@3+eG1K&chX%#9#JfENmCl2-XeP
+QfLc2fba2f5bIP5hGY4Z[4kr(CmUIjGA25K6I,2Qe'3B05L3bAe)N+C%fdLp-5AB
+BJmmTipA+pd&J$9[Ij"ZIcN2M[$"JZ+Q%hG1Lh*J3EMbB8#EEfJ)m%9-!UiH$!5G
+6GVfSJ5(R14Q59jbE@FAjF0L+Xp,2LR1YAa9R@A95i@Ip9C-+AT98S+)-*R@M+,1
+93&UkGm%MC+iTFjX!B*dDLjE*#e5bcEDbcAiel'Dhq,RC4Vmf@k)Bqb'CVLF9lSM
+3UqRYf2+j3('R''G&X0jI#CpG&,mDh9Q0a*2!CU)mE@$jQJ3)KmAFP01"(hYi%S0
+hjF4HH8C9*)BTGf'[T)k&$iC6ad+[IqTBD2"((E1p-M)5&@P&XN*1QLjD-&"Z'&M
+q5lG8P,%iD1&ZB8Yl[3@D)p4TVYSCRhDTm%,Aa@C,K&EjaUS,,dkLeq*a-Y)#Y4K
+5i9)IPX*h3lE(MZd-eA*!0Xc#*G+dSe+P*&2h"&2hYm1UqjLIkJljTHj-HKLUZH8
+--+)+"d%9LcZh3!'XmQh5SF@jHY9mKbiaY(!L)-5R*0idUdXNM9RKV9V&dP9)m(#
+B6hilFfbr`!+9lCD5L38U`X`3-(IEdMLK9ZH0+a8b!NJkrLdNX49XJ@)NM!r3#!D
++q1,6%954D2S%VRB3Qe[@R9a`ENb(-'IM5PQBmlaL5V!-C2kFDIZ(Q$%"R+%[HVN
+j()8kcpQD%bbMC$eEpimdcT-1fl@G"lr)j,4A)6c5cfD64bS,KUDD1HFJ$feH`!G
+-`$"f'N(-lja0Y`eU3JQ2Rki5S)!YD+U(,kcpqr'Ip!H)p5FAF,@8bY55VkJPm+'
+0@T!!K,ql69A,4PZe",J"%#9NB@S[P061Vhqma[8)'3H1UGHAF)1)a++2eHYIPPf
+2cVrBaC4H+#Rp"T%dL6R&p5Jp(I(Ej'JeY8ZM6d6aiE2dL9p1KJZb6-8',5Gj!$&
+C%3K,(JN%9,VQj!)fT!rYbq3X6FEFURTl&+I!UP*&[6`SLB34fJ99[4&Eam#U$&)
+[Udime49k-#Z&YNYqd'Sl*p36h2KkCH0)aZP!X(48H+lK)%C"cAXFj-Pa36c1cNT
+69$(8`d%$ZFTjN@G,+CM-lGRAp'pF'HYPbR!V6ScIV9193@k-PC(%JMj9'BGX(4Q
+rbb4P8%"h'3j#(iT#N!$2'4)PjY3"$Akq9-#$N!!`QqGKb+153T4YYq99frC15E4
+X0MbZE,LbYIU'YiE#EEMbSRc$h0@JXX#28h-J5Y+HT3hcS5Hfi5eUCC2`ZEP4qJA
+1S28BCeCfbKaE-&CCq5&c2KfcCH#(2qDEN!!D5[,)6I0X1AE[jRR9MmXVkca@@DH
+(VD`cr+bXNrbUV1Z8S)qf4+UDDe6$-m16b"T[2UVi@Kk-5Q3%4`ZUp'&L)PDpVjC
+23,0HEFV!"*RkE1,2Zf3A($APcSk6Qd+kV1PC0cXq"Ui6%LC8Z3[4G&h6)4RU3fN
+D!X'j#emK"j%-q3C$YQ'"aLHD2!S5UTKJUQKaETYI8qHMX(+E3Jb,632,pdbaT",
+"qNPJkX##X)rYK36HaM,kVm0Qp(Br-hU$AaNpcBDmpr*N6caj"SL+!)iqR39c[EC
+*3DTYF,Ub`6HEpl,"qfb$MiEGB)@I'jcYe`CI83p,"UCf-X['"i*mc'RC*KYZJpY
+"!JbG+2DAm54T%XULSSi!Y8U'XUZSFd#p,%-j9&358$rJE#DK0"9e(5LA$$@SSX#
+UM@D*i6M+TD+3!)LdXBH,Q!m0XjBbph`VFl58d3F8-,qHV%*V05UC60IdU8YkENT
+GdV'fUNXk[N0GdMEEe#A8-5HQ,U'f16Yj-)i)Scf-#*qSedQfKEQ%4d@CfB)U[e9
+eqAM*jH-KjeM[CH%c6[bfV5[5J#5i'PScb"5Aa9(aJ#J@P@)R8[1Z6QT#JjDP#!3
+GQNY0-D,49AkPm0hKLF1fN`'[6mq4E5V5bj&,10+6j'0AY+'Dkh3HiTb,%0`!Z!b
+S)l,M19'VJ$VR4,QGU*H"5R+L8Kf"ZbTb'T!!ef9)688H"HS9'@T349d'DVF6e88
++8TkVARNG8bU[[ir,$1GPaXR#E9YjlDE!d&BTFj4U+q8RZCHc$SDam2l1Z3[IbFU
+)(ZcVddAp-24f"Pij%03iBHP"d+U9XPiE3Z+d89%U$jJ5'iI!eXr+Ua"Q&X!c[6A
+0p``e59`'!i&5lX,fQE[Je'q01rLbc@cAKJ)Z%"5Y'lM4cCcVcUjiISI86EHT!d`
+"-i4@@`-M4Ji"BDDUE,%S9CTAY!RVjKEB*B"@m%`iJ&D`fMq!9Y$Y&d$E9#0TVTm
+9-LTbab,ZPMZGUDT"er#N+pAh,fr0(C!!3Mi`B"l@,*20-+VSP*PM)&!4U0hJNP!
+JUeVR`S")VPUCkNDBkRiE9RApIUV1j*IUbRLL),jT9&Pl&#FPrJ5T)9dbEk'%2'M
+Hc[1j&UYJL6F8`k3e0BKF#-iZ%5EK6Ya@`(l6SL6F8F%F919dMpB`%MS2#k@ae)a
+S+K-cfi(6-3cD+Qf@'3C0Skc1V-,&4iempZJ"A"bSA$a`mYQlbE(UQlb,V2CdPk%
+i`KIQQ00K4Z%Fl5(K#E`P(#pLQJCA$DPaS!)"l)H%BpNe3KHr*B,T)ae[JE4(Kqk
+(e'[EYDI3('D,dF8[q9GqKI6)6UG,MBHk2+(DA&i0ERa&@(*9JC3ae6R'9'I$-Y9
+P2jNUfaqQQQ153PUrlR@'Y1Tc2IqkYkU!XZSq6h603qFH)LE$1Fi*cBbl@UXLY6K
+j8e5qMK%0j%ED)6pHZ)A6qDP@kc4j&k[@LmTA9@Rk8N,'&P5SB`IBkDC'R%YBSC'
+'eUMCTCKP&*8hUNd%F%+0KU@3!%*K(f[DQaBMlM'fK2P6SCi+RK++RQ&,3PQi-pL
+V-h'R-`ee)J-G6X(M#5h+'0+aPiXkcIPUiJ4Xrj5D-FTa&4@cBciV1h+QcC((C8q
+9f$`e@12)298FqF*H,V)pmLlCNGH6FeYaAI#N'q6JAFm[UC!!M-E+U4(epB3S[+0
+H(Q1)%QP4f-X1,-4L0Y5YZ4HZ!-!r`4+ac@C6k&LVfG6CkY5JESS0+"-l`hEfQ0I
+aa!G5iqJaFS1f25Bl6)Cd'20@0V#kaN%p5'abAYjNKk+'d20%%V0V&8A%C)USN!!
+TSN+f,GXMHRA8E0TXG3XmdE6T!`U&&KkZfGfmSZ0j`pA-@h0$F,RGUZpJr0QMNf5
+Z*ahK935L+Ta*Zd9QM@6fFFAe+LADCXqR`@`!eGYF0i%AAZ4"+,X`DIaj[L$"TJB
+H0H83"j%@m22Yp+2QC)AUB$EPrMSZ0F"3Q'mk5#jVb3&3@'!-CIldI66dBI`T9DA
+NpLjmJbYqMj3KKDm4Dj2C-*NAm`lcHBHe6,f[)9(,9VEiJH+8,jc"KRl)c%'8c'L
+K"1rQ3*`A"HDXYdRX,4N3Kf6r6%+MNMAB`#PHm+GXbAFfRb"i8%'lbVDcfCR"fP8
+T,'!m8bqiCFBQe-3&6qV2'CSD)+%KPNQPf&UF-Y,UB&Qi@cC"BLZ(MPb5$MBS-H%
+9+4aIH(KbHSd*AR2!pJRj%9(pR@!9kII$9U3YIPDN-rbU5*0B4CUfPiSdcEq+G&I
+E`2,(KbR*-SM9[$$9kDM5#F44RM2jmNGG94P00ke4%K$`*M!XI-U889$LB#3$2UT
+F4XBY@GNRI&mZiN6P$4P*Q8I,$Djk#-Z3!%*B[[j+'-)bdjD`I(e#)5cTRh4!iMZ
+@T#"F)Yd,Ce15Rda#ADNa30Tf'LAAQ1SSlPFq,1c$cMiml-2"2S,X`mXq1YfeRPT
+ZF,`aMCZm`SbLNXM&ElTimqhfiLA8p,)S`!3pA%K)lNT6aiXp3Khbe4KUUc%d9'2
+)8Q2S4SfKVKT$EbT$-,j!mfp4dA3a(Uaj1,MjFI$S6Ja-G&a,me(6`++ND6e-b#D
+SNrEcrYQ"i[lClk2TEldbH+GIB&!mj1UhS($+"lX2DErUY`4)XBF@ZIVYS`VL%b$
+X!9,d*d"iTK6%"5!m!9,m"5!F)`VLA5!F!FU)Gi%)`NaQ!Ui03S&eJ!`'+(-Z!HR
+Pb"+',!(5'k!-)f3RhrEkA$4('pr+1mCBaaJkmLhaMP!!bpBe,&ZRR%V5NjSQB*+
+IechK%5r@G[+"mH)H4@hV-*!!Tj(a%6UF3&0hr!Sh$#ST-@N(%T0f5iP$Bp19"+I
+P+ja*4Q0Na$*-$fShaZrK)F06a8H3!%k"VM91i($0qI4--5@D9j+9FM!hRi'jSV"
+JESQIB#lK&jLlCJZQ[RF+)'LA(f"U9dd`Y6PqZQ"UmmfpJkQ!5`kQ!UkU`G5X0[r
+!9-'Yd`06N`HcI[aN`&4$krmD-0A3qKmhQ'TS26d`e9$fT`&-0C5G(TK#FZJ+8S4
+4BT1*pj2`lm&Bf+HG*eLN6`p2fNHI$Z&JRd'H`*!!2Vh#bcil4HHlAi&i+8pmc"M
+R%FS'DV5"NRVVdB4$3i89B)ih(eD%IhF(!dj35-!LZSShQQEK(3*'N!#$V(0JP!`
+Lf86pN!$a"X#DJmK,mq-dj5JPM)Cja+2CdY-`Dc@aj2J%3LRTr(S#""A6F#8bJ$f
+aR9r,(`#JlKUrL3-EU&N*p8M"+#Y3mZZ0@THcZ3J'5"pMJ25&X)"dRCq!Y03[3*T
+Idb4Y@GI!mRp+0V6mAQUf,U`a'R@53'LJT-S!#L20CFf@V6D1Fb0b0"6('jZ509a
+@Z%GUq'hC5Z'a*DDPDp"F($YS`EB&5T)5H90a5fcGKl`4258*R%Gh3QNk%QDdlDc
+TVeTH21308ZfeH&KRfr#AAY"'b)M8bXf9#r3,*$-bGL6@I"9[RT-+3TE`cGF"3Km
+iQ%aTdMA@'+@XpFNReQK8`AV'9Lq&CDYjrV(9V+kUf5TdHpD$CJFk8PEH*m5X"c2
+(',-&!#)Ih(GSAmiRha[ifF"(!pmDh$6`YAdI$UB0IRr`pAdE"Zm0CJdQG9`Fr,Z
+"dAdIGk4dI$a`8V$r!*!$+aY"4%05!`"TZa"9#f5C!&PYNqr@ET4DPQB-deZ'[)a
+DkTcEN!$&')l!fdfPeV'9EXK#5&UhYGedep1cke-)Ke9h23b[Mmej$"J1-BD)'03
+&G8iLdSJh%I%(`aJ3BN!%3BKkHh*c2$YLl22prqrEkpZQQd$1ZArh04e@0L32%4!
+3!"!3!"!3)HlIe5Y4M`Gr&088FU5%&GQP)Yq%Lpa5T@cDaeaN%2ice%ZZ'4-CTXf
+5B#)f+F5%8G(bk(!3cX'Ep2@(&'GpE2"1-5'Pc6d+"-3dmh3eF-)FFrHTG,GFmRM
+UE5NV2*klTV'EraLQ3Bi@-QEjKr+N1-I#qKV&Pl*#86kM@krTeXPZh4!0K0Ud'-)
+ZcL3T6R3$-$`!rShGATCMYhpeqZVdR,*pT@RTp[`MkGUpf9bmV+qI@aqMSq`#%b8
+b@+0FlCkJf'3ReUf#F[T2chZ(i,!GTe5'mq#feZ&@2"MRDBdH9Xam19F`+TU6iP3
+#3S@YdFb9*q[*a8D(DS03hHT'Tk@*%+RUKI9QpK++26X3aiqjhRV-A6X9d4'ME36
+qmE!E5fRbEU8YVp0BeSNI-hjXq2(LTamr2[`d4Ha"1ahejG+-dJU1'X"CCFHQb9d
+MKRlb0pA01L"*Y!&P*c401MMFP8B*(38-[$*#)Xfl$LK1a8P)&HHUKN,0(-"F)9`
+Vl2BMkDCe'q`KVDBR,6FM4eX@b%Q9[Mrd*lZp1+h`5,(@ATSCYMmNMlrkY$fK0%1
+&led0Y1m0p6aH[#A!e-IU,Hk$8jr9T)3YKi5Tjm+0q(-jH($UZ4"8ZGF&aca(G#4
+kb$heT1KZQ(l0q-(T8lX[,TRD(FeFlSXqTbK(MNR+Ph8h%$D94)dA6*GVh*cTH-j
+d(*L1$ih@@i`B6K$GhZRA2!Q'Nm"`%KK'L1%[9[XaA%i-JlG(#0(r"YpR!d1SYm&
+pF1ecQXTSjYTLQ[EFF$6c-ATmJC4-0bf!65iVQlA286A"P,rb+9qDTMb2abd96[N
+VQe*b+ddT-CZQV-IMfBUQP0`U65RN8il6P-1V'&NPC66PcfmC6#Q8TRc$TcaVQJ+
+b5[396[Q'69Pj0deCf@+D!V*@0P8dCHAGI$2Zi2+'d26P$@iAYR`l,bjCANHJiQS
+ISfR[EX((T`JBeSpR+bmZ@41MirTrA,lCm+-DNcXcPpIG%9AUf-1D'$f)Z&(2aTC
+#G$X*F3YLG898JZikPc4P-`h$-J%#NC9Prf*m(%0!X(im-rlLNV9"1UEracAc$$q
+U-4NN""Jjp,!fb-KC'qb+($jP(Jd$Z!,NE)F6d8b9r%fl[C!!4-[9IU+PEJF%cYj
+X8c8bG3Q,%`"QK%+cS-j2FB%b*3S`b,I,0l0E%[piV"1rl5aAc*fP%+JGdXHRq%H
+RmFFeXD)IPfmfrSK"BqMih`FSe`EPfcAcf+h%*P"dZ69MLV*H'kb!K(R'(`'N+(8
+prYd1Vk)%X,+U!3a#2U*aGQaaE(IA+#1UX`b"0A9Z*5Q1[cL&6QN%iTKh)Bj(h0J
+J90',2)MqL,bJDepKF9UkeL6lrS$e5J[YQY*LEAkZaVjIPS&eKH9(8ZdjU8G+Fp,
+afFkk35B##H'4FL@b"ZiP93XMj%Jq@c$XBCY3dR*r6RmZSh#X9Z[Uk0I,4lplJpr
+4Vhq&4bqXN!#D`XIRk*0GM3FcpE4&K1@Lj8U6RaPJC1c`KD+PQIQjTQ292F4@5Xp
+*e4l*R$b8jHjb1q[X8,h6d*ARZUj0eqE3e,(J'GKIV($c,pIe"f-!e)C*YXcLq[6
+bY2fC4c+H'eXq5"la%+2FM$*YUUBiEIpB-J*#&P)A5SlJqVQSfJ&8E&e+"`+PK6E
+"ii%DjQh(BSjBj)"LM[mT0RAD'bbb5(6GR2X+&TF2%Fir8RK!Fk5dH'`Bl6FaZMB
+YHqaKXIr99XkZkm&B+fIA2!1&aE94VFR@dA"9&@XLBS8fh)SU&Y[bSUdk%R$C(SH
+0&#X%aF,f9,YBGG@U`L'US&KGXbQ9$m'#2,kPIP6aG6b#6C)SY[(-@A!5&1HTPhU
+f1TcUTGMfpDC9)M6Slp`TMSM19$&VYpBjUGV4JSh#@1H,l3X5A*V&RHSE%E,FZ2N
+P6%D)j8hEHlB*E2YrmSML+fZRfa!'"+2H8B$MAFIC&j3cP[V%qTJ%`(dT(8%P%"I
+fP,K8YJ3`#284Qi`[4DFFk,QZ2j`HcXh*'#XekL%pBXIf'4rEKQ1E*hYXFqF)dR#
+k2[CQ(0aX1VB!TQBFfPE@3T0aD$-rX0Gde%SkDK)lDRY`*(6Kl+M4JIAm`$ce`(A
+YiA59GL`2c+X0UKr5+j!!JML09d1B+0S$iE6dXH()A[aC3r0,$3fII@PKE8CQ@TQ
+fk+)(D0%dc9M9r@+$GIj-c-T+8bHcI&H+,CVR$G1rTF1p`l0F9&8V3(H%P"a*F6C
+XAd*!UU$X[DkJmMBTpJH%BKk@%*S(YeZ9fdZhm9bj'dDh[q[S[pPbLjpLEeFqMl2
+eH$aqLVfk0SSpQDklCrpN&,[+acEMf(2*0@!ppShkQb6&0KhlHT0bffJ5$QhHEU$
+Dfk(Dr,"3lIJ,fie9He0Y9(YLaNUY9EYVMSqIDRHpk0LTGLYh#!$"UNlUb!2$5F1
+8H0Xj6)J2R%XkaaaekLAcb[QI!,e'Z'HQ"p2`VcU(Z8(-2h9X3+,[cI5"MX9H`&#
+3!)aNC5Y-m6UB#+hX3mB#HZ$"hF["+2)V49-(f*65F9EKB43IJX&MEZe4pK&,fP`
+`GAlP8U6TCf#A-U"06U$9@Rc8$Q6hAHCrXUdJZbrle35CS[bKaJ"N[,ViJqa2Y3E
+CC#T+VGA5!'5R'-L-!@DJB*XNF$RTS5*`@B(eIk&@DBqA@[f50M4dT!*)6i-`A43
+DeTN([A3E2`aRm3@iMpH,#8%[8Y*dbQP0qF&bTFlc&2pc`SfY1P8l0JbH3P)#*5Y
+`j`9F#`Q9AR%[Ra$M+Ef,()TbeF'pRJRLhR[,PG1H(i548YCHlIR"(YHpDXmE520
+m!``Q%)1M@cq2`r!XE"f0%h[im%R5m%Pmq'8-[icKiib'la%6a!"F4DHVcIF'2&I
+ZcI"Fm6b*G*XR+FRCV@M1LKrMaBr#MCc4MrDi$RlXbI$Z&K-1"V#P'q$,A-#d#jj
+Ri!DIJ`pAHkCK1k6Dm`bI-Qf6#aX4hX&Rk"m2-F,8P3#9"FcpMHfG98UM'!r!4$`
+[m$r$!-m`dZCr#G$q0m"i2`$eJQF0T@CB93)G@4mhY2YJD-GcB2fhBd5-Tm28Q-@
+,)(Zm42CiN!"pdC-+XZ-jJFY"hR*+`8-+GN@Np8U1H5`20pH#52bp4h(-+4+l+AY
+FYkU9dpbaFBDrHTQrH(Q25h66mM!NIqRGM9GAHplL!hl-!I)@(rCM$K!!(SU56bD
+RHXQlHl!C[,86P@RG8RC,'`T*`l5"(Xfm2ir3pI2H%"`9NSZk$EFm2CdH&hYT%([
+%`%e*h#@+fh%!feE2'(+E(RJ,!q"N[&md(E6TB))RQk0aYS6'Pd$N5kQ*qYe)i4R
+&i8Fe05"NpVAP5S2RG@ca[6l%RBMBe'SAMf%VM9*TXNf+1b*[8,RfDBTcdmZlUSF
+6#pDV*(SN3Eh8+RVZ@rV+4FqV,Cl6(NIac0+JXaYY&U84,YLq(8XpV8NAS&5YT&3
+)15YCi3iL2(T!dCR-Xrk8$Kr5*+'5&KbK(f&-Hi*,eB+I[!5Hm)NYXHdA`3M*kc!
+3bcUaY4IaRSQkSRT52lMS6S4Ff1ULVE-@T(pXe9j&4+Mk+$9H-ZaZcXe),br9j)b
+PZmk648T!+#GR4I5SJD-LbqUSX#)aHCi*L6P!HU89DE6TL+1fmmRcV*0K[&EkGc&
+*E)%YeN(SCQia)AQ[Rd1NkSFUiJjK@kZR1!Ta6"ZP*ETrUN48hV#2K)6L#cD5Q0$
+B`Tk)LlB%)DM(ki"8&(jJ"2Y51R3b`8D1Ql"A2`UKeZNq"&GVNlZ[f-H#'-RG'M-
+a2)k85)JqK0k(Q11ec1YfNIK6@3HG$TXjZe2L6YT+Z"-9cA4V0YhD"V&B"+EpVVf
++Na@#!E$X"UCieF&9C80F6KSa!U2A%%M"#S"8Bq(!0VZl99lhD)BaN!$[Ye@MF%L
+raSQA%3l%8ql4iM0q3$5HX)B%Zp+2LK1MRkpG+Y(4H4K&-JihiXAC9$2[BXk)"a#
+)r9%a[cRXD$Nmj,##1"AXKej3kTeLBLFAmmk0pFTN8$*Sa,B+D*&CjDqT9L*2%iZ
+N1*1B,M8)A+U1SV%,@bE*k4pmSr[kJdI4d@r@j-(aVJ`p44fjBY2d5cFNA*a)r,E
+KC6kf$@j4kG$CE#Ca`%331[m&[20I`%@4ac5m$S`V2C33mT&9$6"mSk3)Ni`U5b-
+BE+4%[RXcP1pij[1T'c")MjqVm20hr+b5EZC$$"%4'b5fYT31G*2[iHFQhVRI40f
+"T!JN5-dSI)'M0Ei1dfLqjqqd[8%Tc%A%+!G!ie1-r-EX3EJ0XGbAJhFLlF"#)T`
+'hqcM*0l&MCa(SD6i3qQT)(i"42jG)6)9CT(4%#aAE*dlrpCEq5,50+J,@&5I9cq
+A$J6LCq(Q,Rk3!%5rBrbA$ij9Vj11J1lJ%XL2PilKFa4,JT3R1[aEDpM$MFD2B%M
+H"4)Ej9IIRFE61Di(%BXk2UNf$pjCrkP-rU90r'8R%BMdAeH)A"#r`a!U41BhL"d
+0+H(Eb6A"#dpLJ!k(FP4c%2BA!@"r"34@KbM0EcBChM!RE8L(JQ(kYpi9lfQqp"p
+1B2rF@LAqeG#pA[8k!9mUhf++T#'eU4j13"L(UTMN+((Q`f(!YjCb%mD4m`!Z[ca
+kk4fP"eCB8V5`)Dj,4CbkYD)$9HfiA09SBieAY$DQD*D0*YG01lNNk4'SehRSC3Q
+[D1KSj($%6QP-(r&UpP'5T+U@0M"dHMC,VL8RN!"d!6mhK&X`l)+Q%S$Ic!hACf&
+mE[D8!23Pq2KX1)CL`8Mk6l83kd3R@0r!MH@'A56!h'm[pGb!aiF`GCL+(+1)kE"
+L3q9jfr-HNIRl$-pl(Jq[DZq"M"L[V"-Sm2'VjPG*e6c*50aAHkj#94p!+X#3!,c
+*b)qfJ4pYJhbdS4)XprmpXcMVF@!5PSVj2S#I(1PQPL3'aNR,HRN&HJNr2q2%rDa
+L-6$d'CM2mMc!JDFh!PiIIUlM`1[M`00ci%d#m25Hm3$HH(bF*!([1L2JA@F![1X
+Ni,NNi,Qimir!pS!%YJFJAYEK#-GPp9qmM`[!U`*aaAZYJ!NUT*)!bYQ++RlMbGX
+YIY8q+f%Jh2JPG91aM#qjH&V'+r%bL+D0*Y%dalU!$JX8G,h!k5ERlARq5mKL6EH
+6"0["(ClIF43YNJT"c1&#M4HmmIbZhLBKD*%IJ[lV&!Qi6d&QcGHbB009+0LHjF9
+3fG*6%%$H&BKM"i*3ZX64YmS)IFrMCb0(hr-FIDXiqXB!IDZ3!%*0DFG)cTA3Yp%
+)I4X0d,G43YpK#Af(6HLl5d,IACKf`P"iH8iB#DppZ@-RZE,PP$&QF*2)B"[f8&b
+qlE'5a!8+jARIG66jEei`99%j5DJCE@YG+V+a9P[cr`QC(2@5@B1GEL3TGj%8a`(
+C4!&2VG2aRV#+##bcQ3@C&0EGaK-%*FHHMYrSN!$9613!DA,!DI$"E2#"`LiNT#T
+Q8fKb$`Y0T!&bH(+23AJbhdS@XB6L9abLE2BIq(Z%+FCT2+kHLX,4LF0I#NIrC0q
+lBq5Lm[p%U$NaGm0BK*UZikC3mjeA0G4m[iUKCLf53ViRSHD)FDJTT63pAU(Q5+e
+$c9GKbqGa#$9rCa"UMKL(QK)3M5GX+K*U9MXD%'TZp`XeGA+SkErPpkEVHaTiMVb
+L`229hLkEiKGiMR#$H*2'6#Ne--e1fM)m(S5FCk3EXiJA%$e8$*f&P'%BaZqVUY'
+&E')ICH&%KKJh)UqM3)icG%U6,R%MC6dQVIFc8(XP*CPL%)Ef3V#fA3[9mYc!Tfl
+"S09'BHLA2!4&J9R*`0RL&m$p&6rrj)E#2`d-8#6BXi-fMS-*qSr*"+)53"VhX#-
+d[L#&SJ@'S5JRFh%&SHJ0k")@aeFp&&dmd9$dHKcKZ(58-ii-I`1)#1C'@qrM()c
+@&3P''lS)4Xp@5',Ai@L"`B4DKU166r@5`p(Y4F24'*('`Xf[B9EaMASHN!!fM0+
+$U4*3i`&9$dXR5ip"@$SLKD@5fMNE6)'T0ei+6"YdRS9iGCCA2`K![l"d2Dpikj0
+-LQYCbXhc6E*jAL6Pi3*h'E%`G6X3JSe+)$8,a[SQcaUS6``,C2'L[j6m3%@-&KL
+Cl!Yi@VR9E-IVAQcf[+fAYRZ-JPB8IIV)m`iGiD%-ccZHKGJiH3F%T[#+r35@H-*
+2*-b[-'5G,i@X%Eq3!(8,2rB@kl'(@P'Y2r(FajP2-`TDCdP"+phF*`Q0DAj"d@r
+`Xi),M49&K%Dla(i-AYmAG5&4FKB(lqSZ`GZ(Rh95)%[JAFh"1`AJAHejA3,[&#V
+FD3,[1L2`VLX#hR9qi$8)DaqLB*S!1`Z#DP%&3Hem",A4#S*DAm8LT2(CbB5e"3C
+KV9A-946@GV9%B+`#fm@e$Qc21+Ul%*-I'BHfALp(kf+Mm,D1SrM,,P(m2(9I8V"
+,+2k5SrKPS2K,cjX5LPr'cjXQ&2FDSELh#)Tlr9"X%2S#aBXp#kqP2bF-K@3Y`Yk
+*TX-EKEdM21aPhAL0+I"e0KL%[GX9%T%8pT,SE+K0f$Za8-3Sl(hJHa,f2V"K)Q(
+[b#X*HhQBa-,HGakhX2IpUSHp%pf%03jl&m+S@#JIjGTLcViK&m820%F+Y6Pb%EM
+#R1I#@Z*KYp1(#X-[2eEA2mX+&aLb!P'`9`ZcFa#')kQRDij&@0kbG@)XpdqFT8X
+1EY!dS`eT&mI##dYF+*9p'F,Z(NT#S"3&+YL[A[*K2M8qb"-8PR&heaceN[Yr'ID
+%A'kICM'UqXXKPd'5`Kb@T-"Z+8%"dhK$'MfB+TUp0fU3!!,ai45q!"DXiBA22Nq
+Y6d5kJXZ8VZ#$N!$aXZ*d9&JqL%)i5!bCM53'Pbi"k5)ZeHQ`46rDD6Qqqk4VQeT
+"FfVE"+KSTH,N4Pi"Eqj$CY#f$HV+Nfh3m"i2VDMaU3[ee%62KASH%T9Y4f,-+*U
+dK*!!IRIkr6[h+56%)-aMeHr@ImS+!KQRMN""el'd%BME"ph6Tij6YB6`4ih#IMS
+c'DV@)d5LR2aHASLU")dIC%93,"!(`*r1Je-Rd5(3b"%+i%dG,lU4U-m,`0UAF4-
+$4pY&4kZ4MMD01RI6dISJ5QeL1hrejX(-U423$81SHelRM5iJp)$`IE1V*'Cqa!J
+)@X0-S3S1ZBSG8KF,pTR%F+&aHG3rrF'8bi"5Q9elQk6[Tim8NblQT+9b&p6AaB@
+bM[Ur-a9YCFeZm5EB3N'[cR)l&BC,C%@c&JXP!p4YPh8'3d'%`MGpJ+4V)&G-E1Y
+$J'YKiA8C,k)Z0j[PLN0E"+8[D&qe!jK)4A)BUUPlqXSX65`dIH@H3jNVpkc-#Kj
+FQ58H#`BL1d9,&N3mNZ)Y-iF4Z*XMB6-DUU%QC+e&ML1Xb,&A[H5ICb+m5e![QGN
+8'4D2eAL$&h8A$GRAJ(ePSTLBp92&U6eER4Kk'Xb8qNqPiVjkhK(RX3AIePHEN5M
+eX5k!SX("K#F8TmBTMML'1VB%SlUG+2lEcJS+5k)B4H%qMm1f%4Uk&FpaSSq*!5T
+L&rNA%1ifUF0HZlffSP)'*J4iH4T+HD@Le'i4-"BB(E3!B#bB#"LcLS$4"MF8Gq'
+0G+*j%5X)r9J$K!Arab"m[bJ)UpK&9!a*3e#Z-MV`+S"beGL$FZF0IU$dB`e3V[U
+I$-VpB`R+fKFMRjPN,8DqmZJV,dBqmaI@BZ3VXkY3M$b,'PqQ*K"3Q2SCc9(CJ6h
+ieX8P+kI*VQdb)S0ZhJNB1,#a$%mMc"K$)T5@kF,TEH63jX@aRe&M!91c"BA&4p*
+*YYVp3#dAQQ`P`"ThN[kUPU*(8HqB62Vl363Ge-T5YfIQb`C)%%)qQMNcAjTbKVS
++iq-9)EY6,[$jljP($QMYA9-S0ce+95JS05B(NkNrdP0bS8ah5hXplk,h*SRZMJm
+kcI0HShp,ApXi2'[hpedq*IlFf[@IafNAm#4*YR'a[5`0fGYf3`RC3d8jk(rQe(b
+SJEhKTBScMk3I-#+&0I$3MN1fV0a3'$QXq%!B5,%a8Xj5F'M4plP4l%56"a)qdFl
+L982D1!%"kB9(-LUQSS[P'A&M4i5U+"(r+K14NCC6HbTi%lCIam(*G5DBTTaDqdP
+CF&rlGUIY@+1LG6CB(,cBHbq+ZbmV[Ml,V$4m[ml&5EK"h"NIaaZXcA9eJS5FY0a
+`'"@m!Pb`PDUkd0+*,B6SF(),3Ec"BDG,8lbGD5K8Y,iXj[9&ADIe2eQ[A551k-J
+0G`FBl5mYdfC8U$Q&p2pqa9pGDF1#e"@'8$q3!(9flISbhqf@@ml!qFq%D4e#,2h
+DpB%il@`M"Gf&T6+1T+CD!pSL5PSB+14SZ&f"Nl(*eY1SP2A,`*K6h0"J9QM,J)T
+9`m`dKa'S+@K'[X+"&RRJFIdaaDG81#M2HFNEajRf,@h,$YMZMZk0rUFC@&M9
+ecaEb*Y+V5N@2CMc$3p*(Tca&hih2cXQ3!#5D52qX`J&HSk-e6)D4B$63)C&a5CP
+5a5Q#dF#crJ0j8m`ZD@J-6&eX-'rQ'6G[-QQQHDi#"*+53-QFC&Cf$Yq4TV63`qb
+6r-'XQ0q&)U+`ej1+'3f[,jPC4X(qi$CdecZJ'UH0`fb*Db%93HZL`ZCrA@c3F-4
+T@L`b$0HZ6@@$'idC&bmM))ZTmTLTfe@$#rk0r*K@cjDF1DJiU+3q9&,GfIESD23
+$+F(+3pA8De%[q@-aYMdEN!$'hYM[#P%eA5$Zj!k%b3Q$3Y*jUPe9AHD4L5e6N5M
+`@qE6"LbK`e*e%!U4$VKSrEX9I'l!jdSbQb+0cbZVGjFjRfq-*!DR+Q*NUP+CUVM
+hJ&0hcG"A!f(c'PFK8[hMQcY$SC2Yde$BiR&i#1aqGN!laY&Lr$'dqpNpfUAH2"a
+q(Jjr03kIPQ[#Rk%TeV-h9-T%5iMq3Vk%*"(cU4IJL%"P'h"`%3G[kM6MYK+hZKV
+c[#[dEqQ9'iCR$93R'S#MUA1UST2!-FB%$N8j*bD%QXN4+Ri9hi&Qd"lh4`kJF`k
+[rfF1SMN%)M1"k$5C"4Q6Ka$T5)L,qJ!JYGqiFP%5Ja6LM%%P1iT!d4f)BeARamE
+eeT!!p9lr5QV%D*jkbD1AUm#Sd-U)#[X$@@EapePYaAP8A",TZE`"J1C-R+l8DR+
+AiRm$8@5QKdHT#!`*'jhaDUH[YRqXcG#Q`N+VJ2`+f%5Ub+E3'!M86"eV2JZT"Z4
+iGF*9Xa@AI`L&UA(Zqf'L1[Nfbf'Ti5aANY`%N8-Aa@8ZR-b0%Q60E-ePc@`CZ&&
+Q5d@IV)eVlIF6UkpqieU",Yl*33f#!h)"dPBS'[@Ebp`TBN+%YR(G)K8QaSZZ(%I
+L6YjiQ'6SZlkLRNH9mHUi9+$UK"RZqT5k%2GJQq`FKlRrZ99GikS"A)3V-ae5!aF
+me&bX5-9eI&,M,U+I$KZ#4&D%1E+*Uf20&ATYIEFJPS,`'+kDBh6f)QYJ)PSQlKK
+&b12Z`64rTbJ5T1k4A+*SRQVfDUY,&!hV9HVkYKe$'1bF1@`01lHjBCBl)m8)pP%
+d6Q@10#HG5aM9Y*U-Zhh'$VZVkl+eK36Y3%qf#69@(0"RJNQS"lI@!"ME5GKmN!"
+#X5JHZU22mFEpT$!8J5CYQ[CVmRJJZ!!IET3HEX6$$G,$$AMiKr6`$cc-PalQiq(
+[dX2ImA#9p(!9(Uk4(Ul"`ccTB4iHlT-HlX2$,1PK&KiHN!!H(UKGd2kBcbKSelr
+bS2faZif#p[86#GTcDE13!-#V[84X9pi[IrKUA5!Z*AIJ5(jDDSkL`19b[fDlHhV
+"l,3c#IJM(LbB24-&ieE1&Z'm381-q*Ma)%r`QH#H[Q)CNJ!b9ba,D4[%3hdpFbZ
+(JNPJfDFpA!U1B,PL$M&E-8FmZ')1-5ZB)c0E-5F$MZd9ph!fph!fpcaj6dTZYpd
+Z6CI-)bp5i2[$&YFS(0@fAGLqfYFDG!I1"mk6%+b2K@IhMX)Gbjfam@&k*)GfZ&9
+2'eh2QVH5-++A#4P86*%C6Qm-3L-23'4R3)cN&ZE3BUIf)9J5+qZ9##BrSGJL1HD
+Y36GF9ZD1,6`p,$Hb-l[eRHBDLbkaT,XX%S%M("p1ePJ+F-%BR@AY*aSEUSpTH%Q
+hGVjSDHY1$8$-fC!!VX,*L&q&jNMi!YY!)-L,XI!f2NDG)TYkQC'ART[2laJSEJC
+j2KJZ684%q,YrD4Ch[[e"*"UqkbpYZp$JXN6db$re[cTAkAE281d63hH@NrP0$V(
+EGLUf1d2Nj-DY1A)HblE6XPr(4iC0$`q5bU$CS[0hBK"qE1&@-D4[#bTC6bMQ3ZH
+f(YSFqacJ1mF),#l0B-3TCq3`-l9e8dGiD(G(f,Rl*dLqi83&4fl5rqTmjFlPefQ
+F`5F9fr+rDFb$cB0JLXD$NDTc@bNR%hp`Db0AHK+DjER!&XR0N!#@i@C!24$Ek*U
++5EMJQVME29AaSUNYjqifh2DVE&Lk$BpC2L5Eh,EEYc8Ppf5#"%4MA(2R*CQ!eI@
++lS9@hEXEqX*$qMijQ!XUcc[A0dGfr[1[iB9k1"Yaf5+,r&+R30Abd*6(Tl,#SBN
+,01f",B'RmBUK1-`E,0@TcU,a5aYV0Z-f#0&G"&BhE9acKf,ZC40akH&L5H&EcJ#
+-69"#-Hc8GfMbDlBK*6B4j0%Ph(B!01'8h1#1hf`+IrUAjR!VJA[MRNfZd@B-DGE
+%$VGZk9L`jmkqk&CaEfAJLrIJp)64B3@b$VFL"2PY)h5a'mC1CYYX)LG6QkV5fY'
+NFMC$,N$P"B,lJFlQL),d!RhP$L`i3a0L"$"Lp,Yh-c+FG`,dr0B-j9cZSq3hjfl
+F"10AJL6G6k%#kc4$JbHk4ViK-4RD`cR-*)2!D%A+B1D+eXifmD[EGLM11r!!CF!
+ImE9$1eDd1Q,dTr1e1hD3!)RB*kN20Ei5*(F)QL2Y(&RaL@DSqEf95eDdDT`dA(a
+4CHjXCJ`(JI,"CR&(d%iZNQk6!P)h"8&NbaY9&1rhKdBpRQ@+E43TJ%TC(Llad%J
+AB5,dDeDKiie48JfFc6cC#4Y&A$&#CHcQH+V)hD,Xp@9D!%IFEmqh9[B'+[3$"(p
+RiqJQ9l!a(#KaP3eP"rMamqL`MKKEl[LbT,KJ&-lfZ8a-NA!VJ5'6lc-YfiZQ!qB
+'i$!lj-E%"SJYjeSkqJ+CKC9JaX"i+Yca1`2$l-9[T'iF$[$8Y%al0UbYF&TDF6S
+RQ5T8reIR@CA"K40-3TH*DYe1U-3**"1d-m&-&iq$qM3rkj+Ec+9dEJP!%pL0CL-
+AL&MkT6,YC"Br4BZ,#-iLGb,)K6,8+jA8e6c@p,Bq%Vdc!21P2@P8Cm',ZNiR5b+
+T9'S8+$95AN8NZX!)Fchr(r-(a-3%&bk8XlZ`(),d!pejQ$j1RI[9Z3hd&A4VTcP
+DM&Q(qQM*!TIf%Gej)M[9aT*Re8Y@E(dEKAGJI!8!cUP+!qXB6ZiY29b4122GV)2
+,,&ZjL%-lR%N`3JT1jVH+&Rq'`@M5X#lUEY-FMalqcK4kpHeRaXMr(+j&A',2rD[
+KbUJHbA6LF9`bbqcJADQRp5XAdT,ZkFA'*j+(EGf9AHY*`m"`hKq0e-+1TB6,
+4R66-',lNMcK0k@&YQ49eR($4N!"`G2P0[cTR5,i1j&G'G`%JPHH`S@2@L-&i8Ra
+92c8Z,*&LSdmid*c"%i-c'!Qr0P3H2b*iT6CVmULbi[M(5Pcj0PBaIR81f`j50I[
+f-e3c$1M1j,`NCc%jEZ"LZTi",FL!PZ!2Y+#LXh#f,I85NCm0"SLa4(#5j0,Ydk4
+U+Af#+Jl!8GP`U9'[am(Q4&A5B-FM)-+0kMZ#p1i@PG5Be'F,3HDCS3-,Ed%cb`F
+JKC`J+3CA@)Z+40N)c*Fe2*!!bMf2+)@hH)Nc-(('!@qmP0H[#FZKE!mY"aEcjF+
+%B-,DBZ"-5#"61"laLN-*He#"1pYrEfY8(YENYDp#8Q`-$c'0%`m2KejM3c4AFCF
+EY"HjU$N-(a"p%)(Dp#iCaMM$KcR$KcR$Q$($rl3bc%NcBNF'`feSNP#*i)q)*#5
+GiY02Jj-(#8Rij)1M1[H+RIUjX"d*24TYUT("#G3bB(b14MUbi2DKBRflMK)M1"L
+M2(fZ4QQUT`ES,UA!4!S2P9##(jU$4aLTJeSkJlKaMkVNSNbj5,$3SFN[(bi@De%
+509kC#9mQ"+03B31[82aiT-b)+*r*4BMP)NLRDp+CJ`M'9+&G2BUZ3SC$f0`b*&3
+J3X@j4+B"H6iVHDCM+l*UATD4,P0%*)N%*MSU91eKMFfU41Md2EJB&bBL93+Zf%I
+QSJ)d&U#B6RLI(LNQ$jUTQ4401dqHIjKBb"2#PK*AjRB[66)R+(mdijU+miCUP0X
+9mfjmT0FF"3d!Vq9E&abLTmfr&a[CC$C3SF[`QPP3`)qa,XL6E$4j5-E6D@T`'6Z
+AaQCGfZ&P%rNRQc%a#B4%!"YE`K'iB,hXmcQl(Df,fFR0`!d#!-%F2Bb'k&Ph0GZ
+0T1e-FYY'#*c%"%VFBXa)V[JrAja%lUrF!3di&M+3!%)8HMQLkH)&qRF)R$Y0)(D
+k4kfJ*@A6m+3Ll5N'-)5-3kRl0K'!Ak3#1+UEB6k1UNiKc"Z5`@%UKX%[eqX(0K%
+Z1JRa5A%b#P39)5Q2N!!ibrbe`Jj'bSJdDe(6+5rcmh)#3d@6MB(UlC0CR9A!V-&
+Y8H@&B`@ZUM$L$dMU0b%&EGcj)F9@)9+UMC!!dQmLC+Sb&mcUPEN101@#%*Ch1ID
+4J)3Hm#kd+Mb&JM)CILS[!93@RpJfTJTh,+80eldm5U*jm#5UU4-0cX6a$BSQ@A3
+$V8j8C+QaB-DQ@m2PY&(+24EQK2eL042$&98kpNUZC!N+NF8q-S6DF%eAVFfiSV!
+AAbY-C*R3hX)'bG2jT65NKH#FNaUmb9r$LbF0C5Z63aKM`4K#92NBkYMREJfA+R6
+-4(,ZRXCa0T9LQ4eeMEBK&-V,JlJI3YAGTMb-`1k13m)AP@&2$6VKrQdJ&DJ3YbN
+qqS$J)G,a'"ccfj5kMF1BE0(L-RYRKViH1$NJ0Y+3!'kl*NG,2CBL1bRbSq5N'*!
+![TY%,)`S+eJ"a$`#085AY$`6L$+S0$U$`rZ-$ZmhK3XHA%T3!Pj8Tpc)Za5Ub+S
+b'@RI+USNaYa(P5,2jP3XQVd`#he)Sr'9aA$aLlU#UBU[d-a!kQLJPfep8$8BZNM
+6)l(MDm-3ZYL%-DSGHHa4%KE(B$$Y3aG&65"%NH!!iaN1J'BZ(VaG(`0*cECGk)4
+N4,,2!#k9QP)N8mS'%(YK(0DcLfhNEf#"$J'EMDYRJfabC5[l("deE`U5c#YY*KV
+dj9h-+6)(qTPCHlCHZ6XX`Nb'Uc4XUARaf-!'9f@Lb[EbJ,JMp*Th0'&!X`LGf9R
+4%K8'K8j,MQrQNfJkbh,IX'YhYk['qFJ9$+m6Gb5pKJ6-+[m"fr8[h,kKlhkD(M0
+pA"5fE('KdXDNaIXdLl""HTL,)Z3'&b0NcF34e*3QXq"3&1iakN,K"5e0Xm-'06Q
+fpR'R&P3M-bqF9q*+ik+&JKe+2e)[qD,KE6dCPET!C#6FZ%+['KTX$MHZe@2KQ+D
+&Ua3A2(a+6"1Mc3"bjm%CE%NjbET[HMN!GcK*%c,hB-T-rb++jJND#59ZHUKQh3J
+ZFN20@0RF3R`FE@m$m9&(1ahLZhSFiKjb'Ri4c@iN3a!Q5Q'j9ST"dLMRPiYGMR$
+Y""KP@)#U1&f)J3R%qRDJZjm[SBZi81MN*1q@T3X8mb$BENG$9@9@RPd`jDciCq8
+8Bm@,mjSB[@'hldmYKD9[iN302,mKQlkQckJkcKqGiJCYqR2TGXQU*j0abZdFPI4
+C-XRTF`4"!KF0j9cJ1SPYZ!(HS-6CCPl3T3%r1NHPHdpDbj!!6[P3583J+LU*$Up
+l6l(0p-QV*(B11I*53A#U4fbNDN(C&eE6&i6CHPeGESYJmqRTr9#``["cKT23+!"
+H$p2V6"6d8[Kr&i5Hm9F0#epGqFpcU`H%6fBYq0N#BFZMp*rDIGGG3UVk0RA+XHq
+V$kQcNLmN,aILm62QDI92PmkD)D3+*p91YH@aj+`VDVI`KR"0mM2khLmq&$+%[`X
+jFj,A#MeU44lBV[jdG[,8bqUI#e1%CFN[*hrci6FI#@(KMp*)BGR6`UcNbmN6K"2
+VNVqC*ka-[Lcm,hj@#qA6K0q1&j,(#b@FYSprm1$jTmH0HhT`bjA"Z)%Vh30#3#J
+62RlkeeHq%Akp),P$k&Z``b2J8R(+3qSI6"2HIr44iAmIII6MHfB)Sc1%jfF)Nai
+6PTiBk"EHQ#'X9aIf,%Zq,6PrF,m`@hhdf-(Nlb4r0ILQfYBXR"YmF0Vb[42DK,p
+-+qQa#h(6"0Ud'Lmi!"*lYlU-X4AHIf[4SLr`)r`lAKbj8,$L3X&bGFTJQr"EGCl
+`dK9K3$hcUGI9Dki)*eHG%-je#"d&2e3I6ABN[b8F&[jPk@"LEh*1F[0J@IFh`X[
+5L'pqU-j*rQAbQm*[KG5PJc8I*KFQ$kJhFXVb-Fla`bH&kF)5GD2`3q%DiIM6*eF
+)&iA"RY@[Ulm9[K5Q$Mrjc@@Kjm,2ZSAA&kPI[0)RI(c0K!Hq'G-Rr13(`XAahH1
+lCj`I*h3[RcC&+&`jir8C*i@,mi@2IrhM%bm*&em6[RhQ0d*fKr$-VrYqG+jlc(N
+!N!-B!!!NL!!!9lJ!N!-)!*!$)!!!2c`!"kR`!*!$#PM!!&h!!!"G`!#3"#j"9A-
+b!*!&!e0PCc)(Ff9RE@9ZG&0PCc-(Ff9RE@9ZG&0PCc3(Ff9RE@9ZG!!!'Qi!N!-
+"GJ"1F8U$CL*"l3!J)$`r2!!!)MbTm!!"5N&Q"%T!C`T)3%K"))!K33!%3UG"q[r
+1d2`"!#m),c`!!"PZ,`0K!!+X9)pR3%)i#Pj#Tbmm4%&836mm"0@S(h!"%F!+ANU
+ICaK1F6!mUA#R4N2k!#SLL%(k!#!`2+P`TNG+JfF%F!&1G8lY!#*1F8U$CJ+Tp(!
+!6R9J"J#3"3&1F4mkrrC+(fB551IJi%(krqT3d%kk"Dj-h`F(,cVrhNjeB(*"6%&
+%4%008!!$!*!d8(*"E8MRB2"d8*r#,dJ!)#"2)P3aD3!8!"JK3!!N-A`!!3!XdT%
+K33!ZS!,I`NcI$`C1G8Si#PjR$#!U!!KR$#"!)""R"Lmkri41G8MR(`C"q[qHF!`
+L+J!%`VJ$'Q'NCJ!"2NKkrij1ZJGZ@%q`H[pDCJ!"$U%D,JJ)+J"!!!4R"L"i!UD
+J'b`U!!3U+J!)'#S!"*I8PG3J1[p@S4ir1!)JCJ!!l&42,%JJ1[p%)JE#Z!-D@%&
+K!2p-)$Vr2-#i!aT"q[mi))"+K@B%S5*J"#"&S#GQ!!#d+NJJ$P#!3IVr###!)$V
+r#P'!3IVr!##!3QG)HJ#m,a9)H[m#,cVqiLmkrZ)[1[l+,cVqbLmkrXTK!!e1-"p
+R)$m!5S9R##"0S#UJ+f!%)%fJ)b"1S"mJ4k!E-Gm#)'"J)%kJ(b"(S"Yb!")%j`R
+M'H34!!%!)!)"!1!J6D"T!J!!(i!")%fJDYA8ep4"q[jf5T!!C`K`!D#BF!1JQ#"
+0*8J!#(!!60pJq%je60pJq'!!rVir!#"1S"mJ4k!E-Gm#)0A8ep3`1!)J-F!+B*(
+)*8J!#%cIB2K1G8j@!!")j`!i+'i!$%IkrLT&q[iU)"5`NQd%)")SJ%U!Ea)J8b*
+Z!!LL,L!8dC14NR!!B!3`22rC60mF!%jH6R919[r)51FH1#BZ!!JS,J!-+'i!%%(
+krESY52r83Llrb+%D,8Mrc&92U"``(cS!$%8!!'pF5'lrl$!&8d8r!+J298m[,[r
+XU!d`(c`!$%B!!'rF3LHTQeP2,blrl$!'8dBr!+J1)"mY32r`FJ%I!DQE)'lrm%U
+3!'F398m[#+QQ-"p)`()%`)&Ra#mZrr#TSf#m%#i!&'F+@8mZZ!+Q)&qJ'cmmS2a
+1ZJ5'9%mY32r35S"R!!'H,`"1ZJ2@@%p+!'F+F!%G3!!@6[S#'%KZrq4)E[rJ5'l
+rf%kk"@T2l`!-)#lri+%H,8Mrh#!)C`!"C#!Zrq5K(Le)rqJJ#'F!!93[,[rN,`K
+1ZJ@i8%mJ!fB!!+CC6bmm3dp%48*RU"mJ(be!rr"+J'F!!)iJ3#*3FKM6`5m*6VS
+%Y&K2FJ1`3@Cf)!dJ3(!SdF!Y52rd)Qlrm#44F"M9`#e+rrJ[#Nkk",TB6be!rr`
+JE[r`S#P35LCZrp3R5J!S@8m[,[r`6VS9c#!IFZM3J9'!*d!!,&925(Vq-LmZrr4
+)E[rm,``["#mZrp`[,[rJ,blrk%kk#XC86bmZrr#TSb4Zrp3PE[r3!!`PE[rF!"!
+PE[rJ!"3PE[rS!"Jr2+'B6VS$9P42*N!r2+LI6VS$5P42)J!J#l#"CJ4`!'!#F!%
+J!#9!!"`P4!!J*8`!*%Kkqm`r2+$m2cbJr%kk![K86am!6VS98MmmSCK1ZJ--9%p
++J'F%F!'JQ#"m!!!"@M!35-$JJ()'X)&Q$%(k!+iLI!!!!c`LL"em!!(rb#"Zrmb
+J'e92U"``(cS!$%8!!'pd5'lrl$!&8d8r!+J298m[,[rXU!d`(c`!$%B!!'rF3LH
+TQeP2,blrl$!'8dBr!+J1)"mY32r`FJ%I!DQE98m[,[r`UDB`(dM!FJ6!J@F),bl
+rm+QLB-)NE[r`5T*R%&92,`UTTM!I5-"b"-#"CkS[#UQMB+33,[r)(8!!&NcI((K
+1AL"I6qm!$Nl36PErr%MR!$"#,[rm2cbJr%kk!La86b4!5S"RA#m!6VS"J&K25J"
+R8#!+*N!J3#mS!!`r2+$m2cbJr%kk!Gj86am!6VS81#",)'J!%+!I)%XJD!!BS"m
+JI!!!!9S`%%M!i)"b"V#"CJT`!#"m!!!$2##!(A`!!Irm%#lrr%cI$!"1ANje6PE
+rk%MR(cKC6kPe)"mU!%KZrqLSG#!0)%!J%(+'d)%Y32rm)%"F5%2Zrq`Lf#,B@8m
+[2%4"9%%r2!69UD!J(bK!)%!N8$)U!!L5DJ!%2!%d+J!'P'S!!Mi#0LlrmNM$1#l
+rlNM%PS3i!8M%PS4U!P+$iS-p3rrf0Llrm%M$1#lrl%M%PS3i!NM%PS4U!P+$iS-
+p3rrd0LlrpYC"282rqM)Zrr653Me"rrKC6d+R5'lrp%Kk!'Cb!4m"FJ%r!A,r,`&
+#*d+RU4-J(bC!,`#SF`D&!*!$H#m-)%Y`%0(!,`LSpPP2UA8J(l#&C!*Jp&92UA3
+3(fB#B2C`rcm!3QFJ(k!b,`ZT&#m-UD-[,[rSU(0-haci6Pj1G3!#!!"19J!!51F
+!-#4Z!!JJ#LC!)%!L+!!#$)&"6%&%CKBL+!!'$)&%3de3CJS`+!!+FJ1`3@F%F!"
+J!R!"60m-!%jH6R8[#PP22cbSER!"(`"1ZK*i)&mN5&P22cbUER!"(`"1ZK*Q)Pm
+J5V(*CJB`2!)!B!3`2!3!*&p1G8j@!!![!cBZ!!J`!dM!!S!!!!J!5S"["(!"B!*
+`!#BI6Pj1G8j@rra)ja`!0Li!#$m$6VVrc&42(8$rr()"X!&Q%!*$"rp1Z[q!X%0
+Z"(!!B#KC6cmmU*p`!4m!6VS4m#!I+J"C6cm$(blrr%kk%H!J(bJ!X)9Q!R!!60m
+!1%jH6R919J!!51FB-$JZ!!JNEJ!+)%SJ%#C!)%!b%!a"384Q+$)S!!)-3805CKi
+f"(,rYN&R'L!S!!4b'1+S!S!!N!2r-J0)`E#"C`4`!'!#F!%G3!!160m-'%jH)&p
+F6dl36PB!!&925'i!#($r2`"1Z[q5%"pR%L"Z!!JJ+!!%FKMLU!*!!2pJ!R$r6Pj
+1G8j@!!"96dKZ!!K`rcm!6VVrC"!ICa!JEJ!))#J!"!+!!2q3!f!#F2p1ANje6PB
+!!%MR'$JQEJ!)+'i!$#",-,`$!A!!*%`NJ#Bm!!!"*0H5"T)!!!*)"T)!N!-J+$`
+!N!1!fC,CNLJm!!!%N!$CNYH5fC)'NJ#3!h`'NJ!!J!"`!#4Z!"!NJ!D5!*!$*!D
+5!*!$)!D5!*!$5!D5!*!$2N*!60mF'%jH6R919[rN51FI1#CZ!!JU,J!-)!XS3#e
+!rqK`*0R!,8crl(!JfF!Y62r`F%MC`#e-rr4`2YR!)!b3!)Z`K@-'F'91qJ#b3N!
+q!%*!28$rj$B(F#5f3'4)F!5f3'3%F!"J$(!!-!0CJ'S#9S$NJ(J!1!-Y42rif+l
+rk#4%&)!J,[rid)$3V[r`)%!`V[rNF!%8%R)!%J,MB0&Zrq454f#`3N!q!(!"2!!
+f"h!IYN"N4(!"YN"N"(!!B!a`!$!$8i"U!P+!iS"i!$J$,86rr0LZrq`N4"5!)#l
+rr0#!d+lrp#"!-)C`!435FJ!5!Z0Jh%"54f#d3N"-haci6Pj1G8j@rr")jami*'i
+!##CZ!!`k,J!3+'i!%N*!2!!b"A!!-!(3J$3'FJ!b!V#"Ea4#3$3'FJ!b!Y+"dS`
+J36#!8NCJfN*!2!"`!Me!rr)f"VC&C!!!Z%*!2J"#3$e!rr"`!$!$jB$3LL"!)"!
+Y32rd-JC`!$!"d)XJ3"J3GJ!@",C(B`!!JM!ZrrCb!F""d@lrm(!!-!06J$3(FJ!
+b!V#"Ecii,[r`GJ!f"#e$rrc@JpD-)%0+8'B5)#lrr0#!d)`J3$#Zrr*8E[rb-Ll
+rm(!!-!(3J0#-)%!`%$e!rr"J&M!&d%$34M3Zrr"b!$)#dS(5M#""-)"54b!Zrr6
+LL#e!rr4J!2pX8NCJ!2p%60mFq%jH6R919[rm51FF-#4Z!!Jf,J!-*Qi!$M)$F!!
+`!HD!1!!`!h)(`%%k!(!!,8$rr$3%FJ!b!Y++)%%5%(!!%!%d"A)!-J,LS()"`)(
+4V[rm)Llrr11*dSXJ36)3F!!`!5e!rra546!&FJL`3@B'3N!k!&*%-Li!%R!!-!(
+3J,#ZrraM!Q#U%#lrra)Z!"25!C!!!8cI$$K1ANje6PErr%MR(b!NEJ!)1#i!$$S
+Z!!ib"(!!-!(QJ$`!-J4d"m*#2J&f!$B!eSSJ3a!3G!!8!#e#rra`!$!"0!9b!$)
+#d)(QJ()#X)&R$()"X)&R)%U!Cc4J-M3'FJ!b!P5"dSSJ34)3F!!3!A)3ikL"V[r
+m0!Cb!$)#8S(5LL""%K"`!"!"iBL"V[rm)#lrr$3(FJ!b!Z+S,8$rr($rFL!f"A3
+!0!15JZ+S`'lrrNcI"2K1ANje6PErf%MR(cJQEJ!)+'i!$L!m!!!"*0'Z!")J2!!
+!!NM4VJ!5)#i!%Le!rqab)01Z!")L,J!5,8(rm#3m!*!$J0@Z!")N,J!5,8,rp#4
+,'"*f!"B%,82rq1D$HJI'49*$282rh#BZrrMLJhS$aN983ce$rqCf!6SZrqEVBce
+$rqKq3-J(I!!F"$e'rq*i!HYN8d3p42rJ+Llrq(i"bSGR#(S!1J46K@!#H[mp4Ir
+HH!Jp42rN5NCR4LmZ!")[!$m$8NS[#NkkrcT2l`!1jd$4E[rN,bi!%LmZrr!r!bm
+Zrqa1ZJX)6qm!$LmZrr3r!bmZrq`[,[r`6VVmV%r[!!j#3$e!rpJ`,[rBX'i!$'3
+!!6S`,[rLCcSN3$mZrqJ[,[rd2blrj#m,6VVpMNr[!!`5!#!+F!!3!6e!rpTd!$3
+!e+lrl#"#%""b!")!dflrj'!F2blrjMmZrq3[#dkkrI"36ce!rpS`,[rQd@lrj$!
+ZrpU`E[rHCKBb,[rB8Qlrf(!!-!(3M#"!3K"J!2pk-#lrfV"Zrq"Q!!#8-#lriQF
+k*%!r,[rS,blrp$mZrq3[#dkkr3C2l`!-%J!J#R!!%!%p32rDG!!d!05Zrq`J3K!
+3FJ!5!00Zrq4J($mZrqBr,[rN,`Y1Z[eS8%mp32rD-#lrjY&Zrq4@E[rD-#lrfP0
+ZrpT+3'F!r`!i,[rBGJ!f"#e$rra6JpD-)%-3%#)Zrrc5M#""%)"5E[rBB-i3,[r
+Gd#lrfc3ZrpK5E[rBFJ!b!Y+-)%%3J'!!rVib,[rNF!!`!9k!jS"-haci6Pj1G8j
+@ria)jami*Qi!##SZ!!`SEJ!3,#i!&#e,rmK`*0I!,8[ri(!Jem!Y5rr-F%MA`#e
+,rq3Y62q8*M`!!!%NeklrP#!m!!!#50'Zrj4`)0'Zrj3S2!#3!i$CV[q8fDlrP#e
+Zrj6rY#Jm!!!%N!$CV[q8,@lrP2qieklrP#eZrj6r[0QZrj3YE[q8rp4`I0'Zrj3
+YE[q8rk3J2!!!J!$4V[q8)#lrP*!!M,#&B`T`C6e!!#K1qJCkF!!Z!%*!28$rM#4
+Zrk69r!!!J!!Y5[qS,@lrT2q3!#em!!#!!2rS5'lrk#mZrk3JEJ!N6T!!8%mJ,[r
+SCJT`Cce!!#K1qJBd*'lrN!"55VAZrkKMD#"Zrj!!8NL4l[qS,8Mrp#"Zrj!!NHl
+rT#e)rr!JE[qSNHlrN!!Y52rX)!KR$L"Zrj!!)QlrT#!ZrqbL,L4Zrk69l[rX,8V
+rN!")E[r`,blrT#"Z!#41N!"36b!Zrr#`V[rdC!T`Cce!!#K1qJA!)'lrN!"5V[q
+3!"!3(8$rS()!%J$5390"28(rd$!Zrp$33$e!rp)JEJ!F)"$3VJ!J,8$rX#4!,``
+[,[qi2c`"*#mZrj!!6VVlmNr[!!ib!#!+F!!`!G'Zrj!!,``[,[qd2c`"*#mZrlK
+1ZJHk6qm!$LmZrl`r2!%N,blrZ#mZrl41Z[PF6qm!$L4!,``[,[qi2blrd#mZrj!
+!6VVlS%r[!!ib!#!+F!!`!G'Zrj!!,``[,[qd2blrd#mZrlK1ZJGS6qm!$LmZrp3
+r,[r3,blrZ#mZrl41Z[N+6qm!$R!!,J"#3$e!ri`YEJ!Jrk`JE[qXXHlrX'3!"+K
+#3$e!rjJ-EJ*)rjKN!!$#-#lrM'B!!)`NE[q3!&*+YHlrU'0S)'lrN!"55*(ZrkJ
+Y52rd)'lrN!#4l[qN,8Mrm#"ZrkL4l[q3!#e)rq`J#'F1)'lrN!!LE[qN)#lrl+)
+Z*'lrT0AZrq`Y5[q3!%KZrr![,[qN)'i!*%k3!&"2)#lrm,#Zrr4N#R"R28!!+%l
+k"%)JE[q3!&+Zrj!!%K"`!"!",J"`#$e!ri``"h)"`%(4E[qB-LlrQ(!!-!(3J0#
+Zrl`J3$!328$rQ#!(iSJZ!&0ZriaJ!2mi"'i#52qB$'i"!2qBC"!JE[qX8UlrV"#
+ZrjPJ!2m)"'i"!2qB1#lrQ(B!0J3Y3rrieS2@V[r-)%-`%$e!rjSL,[ridUlrb#"
+"%K"`!"!"28$rR%T!C`!!`JaZ!"MrM')!!*JNE[q3!&*+YHlrU'0S)'lrN!"55*(
+ZrkJY52rd)'lrN!#4l[qN,8Mrm#"ZrkL4l[q3!#e)rq`J#'F1)'lrN!!LE[qN)#l
+rl+)Z*'lrT0AZrq`Y5[q3!%KZrr![,[qN)'i!*%k3!&"2)#lrm,#Zrr4N#R"R28!
+!+%lk!bJJE[q3!&+Zrj!!%K"`!"!"0#lrM()!-J,MU)k!8'lrM'!!rf*`rh)J1#l
+rR(B!0J55Jq+S`%I4E[qD)!IQU#i!Q@lrM%*!28$rQ$!ZrjL`E[r5C!!!`M!Zria
+Q!!#-*'lrN!"55VAZrkKMD#"Zrj!!8NL4l[qS,8Mrp#"Zrj!!NHlrT#e)rr!JE[q
+SNHlrN!!Y52rX)!KR$L"Zrj!!)QlrT#!ZrqbL,L4Zrk69l[rX,8VrN!")E[r`,bl
+rT#"Z!#41N!"36b!Zrr#`V[rdC!T`Cce!!#K1qJ*B)'lrN!"5V[q3!")3F!!3!5i
+!F!Jp32q--!Gb!F""d@lrQ$)ZrjK`!$!"d)$3V[r8)%!`%$e!rjJJ"q+),J"6E[q
+-B!$r0M!Zrp+4E[qB1#lrQ(B!0J3Y3rrmeS2@V[rN)%-`%$e!rjiL,[rmdUlri#"
+"%K"`!"!"28$rR%T!C`!!`JaZ!"MrM')!!*JNE[q3!&*+YHlrU'0S)'lrN!"55*(
+ZrkJY52rd)'lrN!#4l[qN,8Mrm#"ZrkL4l[q3!#e)rq`J#'F1)'lrN!!LE[qN)#l
+rl+)Z*'lrT0AZrq`Y5[q3!%KZrr![,[qN)'i!*%k3!&"2)#lrm,#Zrr4N#R"R28!
+!+%lk!9SJE[q3!&+Zrj!!%K"`!"!"0#lrM()!-J,MU)k!8'lrM'!!rf*`rh)J1#l
+rR(B!0J55Jq+S`%I4E[qH)!IQU#i!Q@lrM#"Zrk`b,[qHF!!`!C(!,8MrP,(Z!#"
+PB#"Zrj45V[q8%"!JE[qX8UlrV"#!)'lrP&+Zrj33%#"Zrka5V[qX%)!JE[q88Ul
+rP"!3)'lrV&+Zrk`3J$!ZrjT6E[qD5N"R!2[H)'lrP&+Zrj33%#"Zrka5V[qX%)"
+Jh&CZrjSJEJ!BdFBb,[qHF!!`!5*Zrkb6lJ!JN!#*NF!Y52q8-#lrQQFQ)'i!'0(
+'XHlrP'-D)'lrP&+Zrj33%#"Zrka5V[qX%)"6E[qDB03YEJ!Jrj3`,[qD8flrQNT
+!C`$lCL"Zrj45V[q8%"!JE[qX8UlrV"#!B0`JE[qXXHlrX'F)F'Fp3!!SB"3JE[q
+XNHi!)#*Z!"`LL%*!28!!+%cI(2K1AL"I6qm!)%l3!(!m!$iJ!!"i)$i`)#BQ)(J
+J2$dc-J!!1N0[EA"bCA0cD@pZ1N4PBfpYF(*PFh0TEfi`-c!a,Q-!!$`!2L!!!(J
+J2M!J*LBJH#!m26-b!!!k3fpYF(*PFh0TEfik4'9MEfe`FQ9cFfP[EM!c-$%ZB`!
+!6PErk%MR(cJq,J!)+'i!$$BZ!!T`!$!$1!Gb!$)%N!#"FJ'`J@m!!E3p42rS282
+rkP*ZrqJ`,[rSX'i!#Q3FFJ!b!0+-)%%3%$3(FJ!b!Y+-)%%5%,!"C!*JeP0ZrqS
+`,[rUX%GM(()!-J$5M#""%"!d"h)!-J,5M#""%K#`!@-#B0J`,[rSX'lrkQ8#B()
+i,[rSGJ!f"#e$rr$@M#4$%K*`!"!"28$rl$SZrqTi!$J&,86rp0L-*N33%a5!&Ul
+rl5!Zrr$3J0#Z!"!J3$!328$rl#)Zrr65JG+Z!"!J36)3*#lrm05#e+i!%#"#-)%
+L,[rddS(5VJ!3)%%`J'!!rc)`,[rUX%GQ"P*(B!$r"$J(GJ!f"#e$rrM@M#4$%K*
+`!"!"28$rl$`ZrqTk!$S',8Arr0U-*N83%a5!&Ulrl5!ZrrM3J0#Z!"!J3$!328$
+rl#)Zrrc5JG+Z!"!J36)3*#lrq05#e+i!%#"#-)%L,[rmdS(5VJ!3)%%`J#!Zrr`
+L,[riN!#"0#i!#R)!-J)N,[rm8S+5JV#"E"i[,J!3,``r"Mm%6VVqA%r[!!``,[r
+U8N!q!'!!rP`[,J!3,``r,J!+-#lrkP*!2`"1Z[if6qm!$$eZrqS!#Q!!rMK-hac
+i6Pj1G8j@rq4)jami*'i!#$SZ!!`QEJ!1+'i!%Le-rr!J2!!!!56C`#e-rr4#3$`
+!0JDf4@3XH!!i!be%rrMBLL"%%"!L,[ridUlrm#""%)!J,[rid)$3V[rd)%!`Je*
+'B-i[,[rd,blrm$m&3QG1Z[fb6qm!$%*!2!!f"VC&C"*`!$!$d+lrm#"!5K"Q"&*
+'B1K`!#e!rq3f"VC&C!!!U%T$Cc)J,[rNH!!i!be%rrcBV[r`)%38%()!%J)Q,[r
+m8i2@V[r`)%-@%(3!&!15JZ1S,8$rj$3'FJ!b!Y+Zrr!J34)3F!!3!6i!,@lrj2r
+XF!!Y32rS-!G64dT!Cb!J,[rSiiJL,[rXG!(#JS#",8$rk#!ZrqcLL#e!rqaJf$3
+'FJ!b!Y+"dUlrp#""-K"`!$!"jB$3Lb"!)+lrk&*'8Ulrj'!!re4-haci6Pj1G5*
+I)&qJ*5k!DJ*#Pdl4)Pm5(c!I5J&R"+G'B!+M4Lk)6Y%LAa)I-"mJAdS"C`5Q4f!
+#SNG1d3#3!`S!1+!"!!8!N!B"!!!"MdN!!Bj*!!!%E&028P3&PJ#!!"`$dJ!838a
+59!!+!+T"9A-b!!!",N*14%`!!3%k3dp%43!(!9*%394"!!!"XN4*9%`!$3'q4%a
+24`!#!QC'8N9'!!3#LNCPBA3!!!,'5801)`!%!Y**3dp1!!!$$P"*3e3!!!-D8(0
+PG!!!!bC659T&!!!$-P088L!!!3-q8e45)`!!!eCKGA0d!!%$BQ0TBfi!!!0kD@0
+X1!!!!iCVD@jN!!!$NRCPFR-!!31H!)$rrb!!",-!N!@"rrmJ!!6$!*!&J[rr)!!
+%F`#3"BArrb3!")--l8hS!)Errb3!"+--mjFi!)Irrb!!"*-!N!@)rrmJ!!66!*!
+%!J$rrb!!"18!N!3#!Irr)!!%p3#3"!3"rrmJ!!4M!*!%"+rrr`!!&"`!N!G!!!!
+Cc`#3"B$rr`!!'CF!N!3"!2rr!!!CG`#3"[rr+!&cE3#3"3%!AK`!(PB-mjFX!!)
+!D"`!N!!I$21A*!!$!()F!+`d$21A"!!%!(`F!21L$21A4!!&!)BF!58[$1raK!!
+'!*!!(!&)6JcaVlJ!"rrr!!&cb3#3"[rr+!"J'!#3"B$rr`!!!DF!N!@#rrm!!!*
+h!*!&KIrr*!!!J!cY6NJ!K[rr*!!"*JcY6H3!Krrr!*!$eJ#3"BMrr`!!!`%!N!@
+errmJ!!)&!*!%!3F!0#!!%fi!N!3#!2rr!!!$f3#3"!)"rrm!!!3A!*!%!qMrrb!
+!!Y8!N!3%!Irr)!#3"`4,!#J%!",J$21A3!5[rrm!!"-`!*!%!3F!(#!!%5-!N!3
+$k2rr)!!*@!#3"!4,!"!%!"%+$21A!!#!rrm!!"P!!*!&JIrr!!!C5`#3"B,rr`!
+!'9B!N!@$rrm!!"PK!*!&K2rr!!!CE!#3"[rr!!'11`#3"B$rr`!!&#`!N!@"rrm
+!!"8`!*!&J[rr!!!@0!#3"B2rr`!!&cJ!N!@%rrm!!"Jm!*!%"%[rr`3!%Q8-mjE
+S!qMrr`!!#E3!N!@!rrm!!!8K!*!%rj!%!!&cL3#3"!)!N!-J!!8&!*!%!J%!"b!
+!"48!N!@!rrm!!!Pd!*!(6`!!'IF!N!@%rrm!!"Rc!*!%"%[rr`3!%6m-l8hX!)6
+rr`!!'P)!N!@!rrm!!A1A!*!&!Irr)!!3q!#3"3,rrb!!%0S!N!3'F(*[EA"d#-3
+JFh9QCQPi#dPZFf9bG#"%DA0V#d9iDA0dD@jR)&"A#dPZFf9bG#"%DA0V#d9iDA0
+dD@jR)&"A$NphEQ9b)(*PFfpeFQ0P$NphEQ9b)(*PFfpeFQ0P#90PCfePER3J-3P
+6C@GYC@jd)$)*8f9RE@9ZG#!c#90PCfePER3J03P6C@GYC@jd)$B*8f9RE@9ZG#!
+fS33:
char macPermision;
int mode;
- static char *switches[] = {"close", "delete" ,"files", "list",
+ static CONST char *switches[] = {"close", "delete" ,"files", "list",
"open", "read", "types", "write", (char *) NULL
};
RESOURCE_OPEN, RESOURCE_READ, RESOURCE_TYPES, RESOURCE_WRITE
};
- static char *writeSwitches[] = {
+ static CONST char *writeSwitches[] = {
"-id", "-name", "-file", "-force", (char *) NULL
};
RESOURCE_WRITE_FILE, RESOURCE_FORCE
};
- static char *deleteSwitches[] = {"-id", "-name", "-file", (char *) NULL};
+ static CONST char *deleteSwitches[] = {"-id", "-name", "-file", (char *) NULL};
enum {RESOURCE_DELETE_ID, RESOURCE_DELETE_NAME, RESOURCE_DELETE_FILE};
return TCL_OK;
case RESOURCE_OPEN: {
Tcl_DString ds, buffer;
- char *str, *native;
+ CONST char *str, *native;
int length;
if (!((objc == 3) || (objc == 4))) {
}
if (objc == 2) {
- string = Tcl_GetStringFromObj(objv[1], &length);
- return Tcl_EvalFile(interp, string);
+ return Tcl_FSEvalFile(interp, objv[1]);
}
/*
int
Tcl_MacEvalResource(
Tcl_Interp *interp, /* Interpreter in which to process file. */
- char *resourceName, /* Name of TEXT resource to source,
+ CONST char *resourceName, /* Name of TEXT resource to source,
NULL if number should be used. */
int resourceNumber, /* Resource id of source. */
- char *fileName) /* Name of file to process.
+ CONST char *fileName) /* Name of file to process.
NULL if application resource. */
{
Handle sourceText;
short saveRef, fileRef = -1;
char idStr[64];
FSSpec fileSpec;
- Tcl_DString buffer;
- char *nativeName;
+ Tcl_DString ds, buffer;
+ CONST char *nativeName;
saveRef = CurResFile();
if (fileName != NULL) {
OSErr err;
- nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (nativeName == NULL) {
+ if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
return TCL_ERROR;
}
+ nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
+ Tcl_DStringLength(&buffer), &ds);
err = FSpLocationFromPath(strlen(nativeName), nativeName,
&fileSpec);
+ Tcl_DStringFree(&ds);
Tcl_DStringFree(&buffer);
if (err != noErr) {
Tcl_AppendResult(interp, "Error finding the file: \"",
* Load the resource by name or ID
*/
if (resourceName != NULL) {
- strcpy((char *) rezName + 1, resourceName);
- rezName[0] = strlen(resourceName);
+ Tcl_DString ds;
+ Tcl_UtfToExternalDString(NULL, resourceName, -1, &ds);
+ strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
+ rezName[0] = (unsigned) Tcl_DStringLength(&ds);
sourceText = GetNamedResource('TEXT', rezName);
+ Tcl_DStringFree(&ds);
} else {
sourceText = GetResource('TEXT', (short) resourceNumber);
}
{
int i, size;
char *resultStr;
+ Tcl_DString dstr;
size = GetResourceSizeOnDisk(resource);
- resultStr = ckalloc(size + 1);
+ Tcl_ExternalToUtfDString(NULL, *resource, size, &dstr);
+
+ size = Tcl_DStringLength(&dstr) + 1;
+ resultStr = (char *) ckalloc((unsigned) size);
+
+ memcpy((VOID *) resultStr, (VOID *) Tcl_DStringValue(&dstr), (size_t) size);
+
+ Tcl_DStringFree(&dstr);
for (i=0; i<size; i++) {
- if ((*resource)[i] == '\r') {
+ if (resultStr[i] == '\r') {
resultStr[i] = '\n';
- } else {
- resultStr[i] = (*resource)[i];
}
}
-
- resultStr[size] = '\0';
return resultStr;
}
Tcl_MacFindResource(
Tcl_Interp *interp, /* Interpreter in which to process file. */
long resourceType, /* Type of resource to load. */
- char *resourceName, /* Name of resource to find,
+ CONST char *resourceName, /* Name of resource to find,
* NULL if number should be used. */
int resourceNumber, /* Resource id of source. */
- char *resFileRef, /* Registered resource file reference,
+ CONST char *resFileRef, /* Registered resource file reference,
* NULL if searching all open resource files. */
int *releaseIt) /* Should we release this resource when done. */
{
resource = GetResource(resourceType, resourceNumber);
}
} else {
- c2pstr(resourceName);
+ Str255 rezName;
+ Tcl_DString ds;
+ Tcl_UtfToExternalDString(NULL, resourceName, -1, &ds);
+ strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
+ rezName[0] = (unsigned) Tcl_DStringLength(&ds);
if (limitSearch) {
resource = Get1NamedResource(resourceType,
- (StringPtr) resourceName);
+ rezName);
} else {
resource = GetNamedResource(resourceType,
- (StringPtr) resourceName);
+ rezName);
}
- p2cstr((StringPtr) resourceName);
+ Tcl_DStringFree(&ds);
}
if (*resource == NULL) {
if (tokenPtr != NULL) {
char *tokenVal;
int length;
- tokenVal = (char *) Tcl_GetStringFromObj(tokenPtr, &length);
+ tokenVal = Tcl_GetStringFromObj(tokenPtr, &length);
if (length > 0) {
nameHashPtr = Tcl_FindHashEntry(&nameTable, tokenVal);
if (nameHashPtr == NULL) {
Tcl_SetStringObj(nameObj, "ROM Map", -1);
} else {
p2cstr((StringPtr) fileName);
- if (strcmp(fileName,(char *) appName) == 0) {
+ if (strcmp(fileName,appName) == 0) {
Tcl_SetStringObj(nameObj, "application", -1);
} else {
Tcl_SetStringObj(nameObj, fileName, -1);
* the version string for Tcl.
*/
-#define RESOURCE_INCLUDED
+#define RC_INVOKED
#include "tcl.h"
-#if (TCL_RELEASE_LEVEL == 0)
-# define RELEASE_LEVEL alpha
-#elif (TCL_RELEASE_LEVEL == 1)
-# define RELEASE_LEVEL beta
-#elif (TCL_RELEASE_LEVEL == 2)
-# define RELEASE_LEVEL final
-#endif
-
-#if (TCL_RELEASE_LEVEL == 2)
-# define MINOR_VERSION (TCL_MINOR_VERSION * 16) + TCL_RELEASE_SERIAL
-#else
-# define MINOR_VERSION TCL_MINOR_VERSION * 16
-#endif
-
-resource 'vers' (1) {
- TCL_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
- TCL_PATCH_LEVEL,
- TCL_PATCH_LEVEL ", by Ray Johnson & Jim Ingham © Scriptics Inc."
-};
-
-resource 'vers' (2) {
- TCL_MAJOR_VERSION, MINOR_VERSION,
- RELEASE_LEVEL, 0x00, verUS,
- TCL_PATCH_LEVEL,
- "Simple Tcl Shell " TCL_PATCH_LEVEL " © 1996 - 1999"
-};
-
-
/*
* The mechanisim below loads Tcl source into the resource fork of the
* application. The example below creates a TEXT resource named
* will load the TEXT resource named "Init".
*/
+#ifndef TCLTK_NO_LIBRARY_TEXT_RESOURCES
#include "tclMacTclCode.r"
-
-/*
- * The following resource is used when creating the 'env' variable in
- * the Macintosh environment. The creation mechanisim looks for the
- * 'STR#' resource named "Tcl Environment Variables" rather than a
- * specific resource number. (In other words, feel free to change the
- * resource id if it conflicts with your application.) Each string in
- * the resource must be of the form "KEYWORD=SOME STRING". See Tcl
- * documentation for futher information about the env variable.
- *
- * A good example of something you may want to set is: "TCL_LIBRARY=My
- * disk:etc."
- */
-
-resource 'STR#' (128, "Tcl Environment Variables") {
- { "SCHEDULE_NAME=Agent Controller Schedule",
- "SCHEDULE_PATH=Lozoya:System Folder:Tcl Lib:Tcl-Scheduler"
- };
-};
+#endif
+++ /dev/null
-AddrToName
-AddrToStr
-BuildAFPVolMountInfo
-BumpDate
-ChangeCreatorType
-ChangeFDFlags
-CheckObjectLock
-CheckVolLock
-ClearHasBeenInited
-ClearHasCustomIcon
-ClearIsInvisible
-ClearIsStationery
-ClearNameLocked
-CloseResolver
-ConfigureMemory
-CopyDirectoryAccess
-CopyFileMgrAttributes
-CopyFork
-CreateFileIDRef
-DTCopyComment
-DTGetIcon
-DTOpen
-DTSetComment
-DeleteDirectory
-DeleteDirectoryContents
-DeleteFileIDRef
-DetermineVRefNum
-DirectoryCopy
-EnumCache
-##EnvStr
-ExchangeFiles
-FSMakeFSSpecCompat
-FSReadNoCache
-FSWriteNoCache
-FSWriteVerify
-FSpBumpDate
-FSpCatMoveCompat
-FSpChangeCreatorType
-FSpChangeFDFlags
-FSpCheckObjectLock
-FSpClearHasBeenInited
-FSpClearHasCustomIcon
-FSpClearIsInvisible
-FSpClearIsStationery
-FSpClearNameLocked
-FSpCopyDirectoryAccess
-FSpCopyFile
-FSpCopyFileMgrAttributes
-FSpCreateCompat
-FSpCreateFileIDRef
-FSpCreateMinimum
-FSpCreateResFileCompat
-FSpDTCopyComment
-FSpDTSetComment
-FSpDeleteCompat
-FSpDirCreateCompat
-FSpDirectoryCopy
-FSpExchangeFilesCompat
-FSpFileCopy
-FSpFilteredDirectoryCopy
-FSpFindFolder
-FSpGetDInfo
-FSpGetDefaultDir
-FSpGetDirAccess
-FSpGetDirectoryID
-FSpGetFInfoCompat
-FSpGetFLockCompat
-FSpGetFileLocation
-FSpGetFileSize
-FSpGetForeignPrivs
-FSpGetFullPath
-FSpGetIOACUser
-FSpLocationFromFullPath
-FSpLocationFromPath
-FSpMoveRename
-FSpMoveRenameCompat
-FSpOpenAware
-FSpOpenDFCompat
-FSpOpenRFAware
-FSpOpenRFCompat
-FSpOpenResFileCompat
-FSpPathFromLocation
-FSpRenameCompat
-FSpResolveFileIDRef
-FSpRstFLockCompat
-FSpSetDInfo
-FSpSetDefaultDir
-FSpSetDirAccess
-FSpSetFInfoCompat
-FSpSetFLockCompat
-FSpSetForeignPrivs
-FSpSetHasCustomIcon
-FSpSetIsInvisible
-FSpSetIsStationery
-FSpSetNameLocked
-FSpShare
-FSpUnshare
-FileCopy
-FilteredDirectoryCopy
-FindDrive
-FlushFile
-FreeAllMemory
-GetCPanelFolder
-GetCatInfoNoName
-GetDInfo
-GetDirItems
-GetDirName
-GetDirectoryID
-GetDiskBlocks
-GetDriverName
-GetFileLocation
-GetFileSize
-GetFilenameFromPathname
-GetForeignPrivs
-GetFullPath
-GetGlobalMouse
-GetIOACUser
-GetObjectLocation
-GetParentID
-GetSystemFolder
-GetTempBuffer
-GetTrapType
-GetUGEntries
-GetUGEntry
-GetVolMountInfo
-GetVolMountInfoSize
-GetVolumeInfoNoName
-HCopyFile
-HCreateMinimum
-HGetDirAccess
-HGetLogInInfo
-HGetVInfo
-HGetVolParms
-HInfo
-HMapID
-HMapName
-HMoveRename
-HMoveRenameCompat
-HOpenAware
-HOpenRFAware
-hypotd
-HSetDirAccess
-InstallConsole
-LocationFromFullPath
-LockRange
-MXInfo
-NumToolboxTraps
-OnLine
-OpenOurRF
-OpenResolver
-PBXGetVolInfoSync
-ReadCharsFromConsole
-RemoveConsole
-ResolveFileIDRef
-RestoreDefault
-RetrieveAFPVolMountInfo
-SIOUXBigRect
-SIOUXCantSaveAlert
-SIOUXDoAboutBox
-SIOUXDoContentClick
-SIOUXDoEditClear
-SIOUXDoEditCopy
-SIOUXDoEditCut
-SIOUXDoEditPaste
-SIOUXDoEditSelectAll
-SIOUXDoMenuChoice
-SIOUXDoPageSetup
-SIOUXDoPrintText
-SIOUXDoSaveText
-SIOUXDragRect
-SIOUXDrawGrowBox
-SIOUXHandleOneEvent
-SIOUXIsAppWindow
-SIOUXMyGrowWindow
-SIOUXQuitting
-SIOUXSetTitle
-SIOUXSettings
-SIOUXSetupMenus
-SIOUXSetupTextWindow
-SIOUXState
-SIOUXTextWindow
-SIOUXUpdateMenuItems
-SIOUXUpdateScrollbar
-SIOUXUpdateStatusLine
-SIOUXUpdateWindow
-SIOUXUseWaitNextEvent
-SIOUXYesNoCancelAlert
-SIOUXisinrange
-SIOUXselstart
-SearchFolderForDNRP
-SetDInfo
-SetDefault
-SetForeignPrivs
-SetHasCustomIcon
-SetIsInvisible
-SetIsStationery
-SetNameLocked
-Share
-StrToAddr
-TclAccess
-TclAllocateFreeObjects
-TclChdir
-TclCleanupByteCode
-TclCleanupCommand
-TclCompileBreakCmd
-TclCompileCatchCmd
-TclCompileContinueCmd
-TclCompileDollarVar
-TclCompileExpr
-TclCompileExprCmd
-TclCompileForCmd
-TclCompileForeachCmd
-TclCompileIfCmd
-TclCompileIncrCmd
-TclCompileQuotes
-TclCompileSetCmd
-TclCompileString
-TclCompileWhileCmd
-TclCopyAndCollapse
-TclCopyChannel
-TclCreateAuxData
-TclCreateExecEnv
-TclDate_TclDates
-TclDate_TclDatev
-TclDateact
-TclDatechar
-TclDatechk
-TclDatedebug
-TclDatedef
-TclDateerrflag
-TclDateexca
-TclDatelval
-TclDatenerrs
-TclDatepact
-TclDateparse
-TclDatepgo
-TclDateps
-TclDatepv
-TclDater1
-TclDater2
-TclDates
-TclDatestate
-TclDatetmp
-TclDatev
-TclDateval
-TclDeleteCompiledLocalVars
-TclDeleteExecEnv
-TclDeleteVars
-TclDoGlob
-TclEmitForwardJump
-TclExecuteByteCode
-TclExpandCodeArray
-TclExpandJumpFixupArray
-TclExprFloatError
-TclFileAttrsCmd
-TclFileCopyCmd
-TclFileDeleteCmd
-TclFileMakeDirsCmd
-TclFileRenameCmd
-TclFindElement
-TclFindProc
-TclFixupForwardJump
-TclFormatInt
-TclFreeCompileEnv
-TclFreeJumpFixupArray
-TclFreeObj
-TclFreePackageInfo
-TclGetCwd
-TclGetDate
-TclGetDefaultStdChannel
-TclGetElementOfIndexedArray
-TclGetEnv
-TclGetExceptionRangeForPc
-TclGetExtension
-TclGetFrame
-TclGetIndexedScalar
-TclGetIntForIndex
-TclGetLoadedPackages
-TclGetLong
-TclGetNamespaceForQualName
-TclGetOpenMode
-TclGetOriginalCommand
-TclGetRegError
-TclGetSrcInfoForPc
-TclGetUserHome
-TclGlobalInvoke
-TclGuessPackageName
-TclHasSockets
-TclHideUnsafeCommands
-TclInExit
-TclIncrElementOfIndexedArray
-TclIncrIndexedScalar
-TclIncrVar2
-TclInitByteCodeObj
-TclInitCompileEnv
-TclInitJumpFixupArray
-TclInitNamespaces
-TclInterpInit
-TclInvoke
-TclInvokeObjectCommand
-TclInvokeStringCommand
-TclIsProc
-TclLoadFile
-TclLooksLikeInt
-TclLookupVar
-TclpAccess
-TclMacCreateEnv
-TclMacExitHandler
-TclMacFOpenHack
-TclMacInitExitToShell
-TclMacInstallExitToShellPatch
-TclMacOSErrorToPosixError
-TclMacReadlink
-TclMacRemoveTimer
-TclMacStartTimer
-TclpStat
-TclMacTimerExpired
-TclMatchFiles
-TclNeedSpace
-TclObjIndexForString
-TclObjInterpProc
-TclObjInvoke
-TclObjInvokeGlobal
-TclPlatformExit
-TclPlatformInit
-TclPreventAliasLoop
-TclPrintByteCodeObj
-TclPrintInstruction
-TclPrintSource
-TclRegComp
-TclRegError
-TclRegExec
-TclRenameCommand
-TclResetShadowedCmdRefs
-TclServiceIdle
-TclSetElementOfIndexedArray
-TclSetEnv
-TclSetIndexedScalar
-TclSetupEnv
-TclSockGetPort
-TclStat
-TclTeardownNamespace
-TclTestChannelCmd
-TclTestChannelEventCmd
-TclUnsetEnv
-TclUpdateReturnInfo
-TclWordEnd
-Tcl_AddErrorInfo
-Tcl_AddObjErrorInfo
-Tcl_AfterCmd
-Tcl_Alloc
-Tcl_AllowExceptions
-Tcl_AppendAllObjTypes
-Tcl_AppendElement
-Tcl_AppendObjCmd
-Tcl_AppendResult
-Tcl_AppendStringsToObj
-Tcl_AppendToObj
-Tcl_ArrayObjCmd
-Tcl_AsyncCreate
-Tcl_AsyncDelete
-Tcl_AsyncInvoke
-Tcl_AsyncMark
-Tcl_AsyncReady
-Tcl_BackgroundError
-Tcl_Backslash
-Tcl_BeepObjCmd
-Tcl_BinaryObjCmd
-Tcl_BreakCmd
-Tcl_CallWhenDeleted
-Tcl_CancelIdleCall
-Tcl_CaseObjCmd
-Tcl_CatchObjCmd
-Tcl_ClockObjCmd
-Tcl_Close
-Tcl_CommandComplete
-Tcl_Concat
-Tcl_ConcatObj
-Tcl_ConcatObjCmd
-Tcl_ContinueCmd
-Tcl_ConvertCountedElement
-Tcl_ConvertElement
-Tcl_ConvertToType
-Tcl_CreateAlias
-Tcl_CreateAliasObj
-Tcl_CreateChannel
-Tcl_CreateChannelHandler
-Tcl_CreateCloseHandler
-Tcl_CreateCommand
-Tcl_CreateEventSource
-Tcl_CreateExitHandler
-Tcl_CreateInterp
-Tcl_CreateMathFunc
-Tcl_CreateNamespace
-Tcl_CreateObjCommand
-Tcl_CreateSlave
-Tcl_CreateTimerHandler
-Tcl_CreateTrace
-Tcl_DStringAppend
-Tcl_DStringAppendElement
-Tcl_DStringEndSublist
-Tcl_DStringFree
-Tcl_DStringGetResult
-Tcl_DStringInit
-Tcl_DStringResult
-Tcl_DStringSetLength
-Tcl_DStringStartSublist
-Tcl_DbCkalloc
-Tcl_DbCkfree
-Tcl_DbCkrealloc
-Tcl_DbDecrRefCount
-Tcl_DbIsShared
-Tcl_DbIncrRefCount
-Tcl_DbNewBooleanObj
-Tcl_DbNewDoubleObj
-Tcl_DbNewListObj
-Tcl_DbNewLongObj
-Tcl_DbNewObj
-Tcl_DbNewStringObj
-Tcl_DeleteAssocData
-Tcl_DeleteChannelHandler
-Tcl_DeleteCloseHandler
-Tcl_DeleteCommand
-Tcl_DeleteCommandFromToken
-Tcl_DeleteEventSource
-Tcl_DeleteEvents
-Tcl_DeleteExitHandler
-Tcl_DeleteHashEntry
-Tcl_DeleteHashTable
-Tcl_DeleteInterp
-Tcl_DeleteNamespace
-Tcl_DeleteTimerHandler
-Tcl_DeleteTrace
-Tcl_DoOneEvent
-Tcl_DoWhenIdle
-Tcl_DontCallWhenDeleted
-Tcl_DumpActiveMemory
-Tcl_DuplicateObj
-Tcl_EchoCmd
-Tcl_Eof
-Tcl_ErrnoId
-Tcl_ErrnoMsg
-Tcl_ErrorObjCmd
-Tcl_Eval
-Tcl_EvalFile
-Tcl_EvalObj
-Tcl_EvalObjCmd
-Tcl_EventuallyFree
-Tcl_ExecCmd
-Tcl_Exit
-Tcl_ExitObjCmd
-Tcl_ExposeCommand
-Tcl_ExprBoolean
-Tcl_ExprBooleanObj
-Tcl_ExprDouble
-Tcl_ExprDoubleObj
-Tcl_ExprLong
-Tcl_ExprLongObj
-Tcl_ExprObjCmd
-Tcl_ExprString
-Tcl_FconfigureCmd
-Tcl_FcopyObjCmd
-Tcl_FileEventCmd
-Tcl_FileObjCmd
-Tcl_Finalize
-Tcl_FindCommand
-Tcl_FindExecutable
-Tcl_FindNamespace
-Tcl_FindNamespaceVar
-Tcl_FirstHashEntry
-Tcl_Flush
-Tcl_FlushObjCmd
-Tcl_ForCmd
-Tcl_ForeachObjCmd
-Tcl_ForgetImport
-Tcl_FormatCmd
-Tcl_Free
-Tcl_FreeResult
-Tcl_GetAlias
-Tcl_GetAliasObj
-Tcl_GetAssocData
-Tcl_GetBoolean
-Tcl_GetBooleanFromObj
-Tcl_GetChannel
-Tcl_GetChannelBufferSize
-Tcl_GetChannelHandle
-Tcl_GetChannelInstanceData
-Tcl_GetChannelMode
-Tcl_GetChannelName
-Tcl_GetChannelOption
-Tcl_GetChannelType
-Tcl_GetCommandFromObj
-Tcl_GetCommandFullName
-Tcl_GetCommandInfo
-Tcl_GetCommandName
-Tcl_GetCurrentNamespace
-Tcl_GetDouble
-Tcl_GetDoubleFromObj
-Tcl_GetErrno
-Tcl_GetGlobalNamespace
-Tcl_GetHostName
-Tcl_GetIndexFromObj
-Tcl_GetInt
-Tcl_GetIntFromObj
-Tcl_GetInterpPath
-Tcl_GetLongFromObj
-Tcl_GetMaster
-Tcl_GetOSTypeFromObj
-Tcl_GetObjResult
-Tcl_GetObjType
-Tcl_GetPathType
-Tcl_GetServiceMode
-Tcl_GetSlave
-Tcl_GetStdChannel
-Tcl_GetStringFromObj
-Tcl_GetStringResult
-Tcl_GetVar
-Tcl_GetVar2
-Tcl_GetVariableFullName
-Tcl_Gets
-Tcl_GetsObj
-Tcl_GetsObjCmd
-Tcl_GlobCmd
-Tcl_GlobalEval
-Tcl_GlobalEvalObj
-Tcl_GlobalObjCmd
-Tcl_HashStats
-Tcl_HideCommand
-Tcl_IfCmd
-Tcl_Import
-Tcl_IncrCmd
-Tcl_InfoObjCmd
-Tcl_Init
-Tcl_InitHashTable
-Tcl_InitMemory
-Tcl_InputBlocked
-Tcl_InputBuffered
-Tcl_InterpDeleted
-Tcl_InterpObjCmd
-Tcl_IsSafe
-Tcl_JoinObjCmd
-Tcl_JoinPath
-Tcl_LappendObjCmd
-Tcl_LindexObjCmd
-Tcl_LinkVar
-Tcl_LinsertObjCmd
-Tcl_ListObjAppendElement
-Tcl_ListObjAppendList
-Tcl_ListObjCmd
-Tcl_ListObjGetElements
-Tcl_ListObjIndex
-Tcl_ListObjLength
-Tcl_ListObjReplace
-Tcl_LlengthObjCmd
-Tcl_LoadCmd
-Tcl_LrangeObjCmd
-Tcl_LreplaceObjCmd
-Tcl_LsCmd
-Tcl_LsearchObjCmd
-Tcl_LsortObjCmd
-Tcl_MacConvertTextResource
-Tcl_MacEvalResource
-Tcl_MacFindResource
-Tcl_MacSetEventProc
-Tcl_MacSourceObjCmd
-Tcl_Main
-Tcl_MakeSafe
-Tcl_MakeTcpClientChannel
-Tcl_Merge
-Tcl_NamespaceObjCmd
-Tcl_NewBooleanObj
-Tcl_NewDoubleObj
-Tcl_NewIntObj
-Tcl_NewListObj
-Tcl_NewLongObj
-Tcl_NewOSTypeObj
-Tcl_NewObj
-Tcl_NewStringObj
-Tcl_NextHashEntry
-Tcl_NotifyChannel
-Tcl_ObjGetVar2
-Tcl_ObjSetVar2
-Tcl_OpenCmd
-Tcl_OpenFileChannel
-Tcl_OpenTcpClient
-Tcl_OpenTcpServer
-Tcl_PackageCmd
-Tcl_ParseVar
-Tcl_PidObjCmd
-Tcl_PkgProvide
-Tcl_PkgRequire
-Tcl_PopCallFrame
-Tcl_PosixError
-Tcl_Preserve
-Tcl_PrintDouble
-Tcl_ProcObjCmd
-Tcl_PushCallFrame
-Tcl_PutEnv
-Tcl_PutsObjCmd
-Tcl_PwdCmd
-Tcl_QueueEvent
-Tcl_Read
-Tcl_ReadObjCmd
-Tcl_Realloc
-Tcl_RecordAndEval
-Tcl_RegExpCompile
-Tcl_RegExpExec
-Tcl_RegExpMatch
-Tcl_RegExpRange
-Tcl_RegexpCmd
-Tcl_RegisterChannel
-Tcl_RegisterObjType
-Tcl_RegsubCmd
-Tcl_Release
-Tcl_RenameObjCmd
-Tcl_ResetResult
-Tcl_ResourceObjCmd
-Tcl_ReturnObjCmd
-Tcl_ScanCmd
-Tcl_ScanCountedElement
-Tcl_ScanElement
-Tcl_Seek
-Tcl_SeekCmd
-Tcl_ServiceAll
-Tcl_ServiceEvent
-Tcl_SetAssocData
-Tcl_SetBooleanObj
-Tcl_SetChannelBufferSize
-Tcl_SetChannelOption
-Tcl_SetCmd
-Tcl_SetCommandInfo
-Tcl_SetDoubleObj
-Tcl_SetErrno
-Tcl_SetErrorCode
-Tcl_SetIntObj
-Tcl_SetListObj
-Tcl_SetLongObj
-Tcl_SetMaxBlockTime
-Tcl_SetOSTypeObj
-Tcl_SetObjErrorCode
-Tcl_SetObjLength
-Tcl_SetObjResult
-Tcl_SetPanicProc
-Tcl_SetRecursionLimit
-Tcl_SetResult
-Tcl_SetServiceMode
-Tcl_SetStdChannel
-Tcl_SetStringObj
-Tcl_SetTimer
-Tcl_SetVar
-Tcl_SetVar2
-Tcl_SignalId
-Tcl_SignalMsg
-Tcl_Sleep
-Tcl_SocketCmd
-Tcl_SourceObjCmd
-Tcl_SourceRCFile
-Tcl_SplitList
-Tcl_SplitPath
-Tcl_StaticPackage
-Tcl_StringMatch
-Tcl_StringObjCmd
-Tcl_SubstCmd
-Tcl_SwitchObjCmd
-Tcl_Tell
-Tcl_TellCmd
-Tcl_TimeObjCmd
-Tcl_TraceCmd
-Tcl_TraceVar
-Tcl_TraceVar2
-Tcl_TranslateFileName
-Tcl_Ungets
-Tcl_UnlinkVar
-Tcl_UnregisterChannel
-Tcl_UnsetObjCmd
-Tcl_UnsetVar
-Tcl_UnsetVar2
-Tcl_UntraceVar
-Tcl_UntraceVar2
-Tcl_UpVar
-Tcl_UpVar2
-Tcl_UpdateCmd
-Tcl_UpdateLinkedVar
-Tcl_UplevelObjCmd
-Tcl_UpvarObjCmd
-Tcl_ValidateAllMemory
-Tcl_VarEval
-Tcl_VarTraceInfo
-Tcl_VarTraceInfo2
-Tcl_VariableObjCmd
-Tcl_VwaitCmd
-Tcl_WaitForEvent
-Tcl_WaitPid
-Tcl_WhileCmd
-Tcl_Write
-Tcl_WrongNumArgs
-TclpAlloc
-TclpCopyDirectory
-TclpCopyFile
-TclpCreateDirectory
-TclpDeleteFile
-TclpFree
-TclpGetClicks
-TclpGetDate
-TclpGetSeconds
-TclpGetTime
-TclpGetTimeZone
-TclpListVolumes
-TclpRealloc
-TclpRemoveDirectory
-TclpRenameFile
-TrapExists
-TruncPString
-UnlockRange
-UnmountAndEject
-Unshare
-VolumeMount
-WriteCharsToConsole
-XGetVInfo
-_Ctype
-_Stderr
-_Stoul
-abort
-abs
-acosf
-appMemory
-asctime
-asinf
-atan
-atan2
-atan2_d_dd
-atan2_d_pdpd
-atan2_r_prpr
-atan2_r_rr
-atan2f
-atan_d_d
-atan_d_pd
-atan_r_pr
-atan_r_r
-atanf
-atexit
-atof
-atoi
-atol
-bsearch
-builtinFuncTable
-calloc
-ccommand
-ceilf
-chdir
-clearerr
-clock
-close
-closeUPP
-completeUPP
-cos
-cos_d_d
-cos_d_pd
-cos_r_pr
-cos_r_r
-cosf
-coshf
-creat
-ctime
-cuserid
-difftime
-div
-environ
-errno
-exec
-exit
-exp
-exp_d_d
-exp_d_pd
-exp_r_pr
-exp_r_r
-expf
-fabsf
-fclose
-fcntl
-fdopen
-feof
-ferror
-fflush
-fgetc
-fgetpos
-fgets
-fileno
-floorf
-fmodf
-fopen
-fprintf
-fputc
-fputs
-fread
-free
-freopen
-frexpf
-fscanf
-fseek
-fsetpos
-fstat
-ftell
-fwrite
-getStdChannelsProc
-getc
-getchar
-getcwd
-getenv
-getlogin
-gets
-gmtime
-instructionTable
-isalnum
-isalpha
-isatty
-iscntrl
-isdigit
-isgraph
-islower
-isprint
-ispunct
-isspace
-isupper
-isxdigit
-labs
-ldexpf
-ldiv
-localeconv
-localtime
-log
-log10
-log10_d_d
-log10_d_pd
-log10f
-log_d_d
-log_d_pd
-logf
-longjmp
-lseek
-malloc
-mblen
-mbstowcs
-mbtowc
-memchr
-memcmp
-memcpy
-memmove
-memset
-mkdir
-mktime
-open
-panic
-panicProc
-perror
-pow
-power_d_dd
-powf
-printf
-putc
-putchar
-puts
-qsort
-raise
-rand
-read
-realloc
-remove
-rename
-resultUPP
-rewind
-rmdir
-scanf
-setbuf
-setlocale
-setvbuf
-signal
-sin
-sin_d_d
-sin_d_pd
-sin_r_pr
-sin_r_r
-sinf
-sinhf
-sleep
-sprintf
-sqrt
-sqrt_d_d
-sqrt_d_pd
-sqrt_r_pr
-sqrt_r_r
-sqrtf
-srand
-sscanf
-stat
-strcasecmp
-strcat
-strchr
-strcmp
-strcoll
-strcpy
-strcspn
-strerror
-strftime
-strlen
-strncasecmp
-strncat
-strncmp
-strncpy
-strpbrk
-strrchr
-strspn
-strstr
-strtod
-strtok
-strtol
-strtoul
-strxfrm
-system
-systemMemory
-tanf
-tanhf
-tclBooleanType
-tclByteCodeType
-tclCmdNameType
-tclDoubleType
-tclDummyLinkVarPtr
-tclExecutableName
-tclFreeObjList
-tclIndexType
-tclIntType
-tclListType
-tclMemDumpFileName
-tclNsNameType
-tclPlatform
-tclStringType
-tclTraceCompile
-tclTraceExec
-tclTypeTable
-tcl_MathInProgress
-tclpFileAttrProcs
-tclpFileAttrStrings
-tell
-time
-tmpfile
-tmpnam
-tolower
-toupper
-ttyname
-uname
-ungetc
-unlink
-utime
-utimes
-vfprintf
-vprintf
-vsprintf
-wcstombs
-wctob
-wctomb
-write
-#DTGetAPPL
-#DTGetComment
-#FSpDTGetAPPL
-#FSpDTGetComment
-#TclMacInitializeFragment
-#TclMacTerminateFragment
-#_Aldata
-#_Assert
-#_Atcount
-#_Atfuns
-#_Clocale
-#_Closreg
-#_Costate
-#_Daysto
-#_Dbl
-#_Defloc
-#_Environ
-#_Environ1
-#_Fgpos
-#_Files
-#_Flt
-#_Fopen
-#_Foprep
-#_Fread
-#_Freeloc
-#_Frprep
-#_Fspos
-#_Fwprep
-#_Fwrite
-#_Genld
-#_Gentime
-#_Getdst
-#_Getfld
-#_Getfloat
-#_Getint
-#_Getloc
-#_Getmem
-#_Getstr
-#_Gettime
-#_Getzone
-#_Isdst
-#_Ldbl
-#_Ldtob
-#_Litob
-#_Locale
-#_Locsum
-#_Loctab
-#_Locterm
-#_Locvar
-#_MWERKS_Atcount
-#_MWERKS_Atfuns
-#_Makeloc
-#_Makestab
-#_Makewct
-#_Mbcurmax
-#_Mbstate
-#_Mbtowc
-#_Nnl
-#_PJP_C_Copyright
-#_Printf
-#_Putfld
-#_Putstr
-#_Puttxt
-#_Randseed
-#_Readloc
-#_Scanf
-#_Setloc
-#_Skip
-#_Stdin
-#_Stdout
-#_Stod
-#_Stof
-#_Stoflt
-#_Stold
-#_Strerror
-#_Strftime
-#_Strxfrm
-#_Times
-#_Tolower
-#_Toupper
-#_Ttotm
-#_WCostate
-#_Wcstate
-#_Wctob
-#_Wctomb
-#_Wctrans
-#_Wctype
-#__CheckForSystem7
-#__RemoveConsoleHandler__
-#__aborting
-#__ctopstring
-#__cvt_fp2unsigned
-#__getcreator
-#__gettype
-#__initialize
-#__myraise
-#__ptmf_null
-#__ptr_glue
-#__system7present
-#__terminate
-#__ttyname
-#_atexit
-#_exit
-#_fcreator
-#_ftype
* TCL_WRITABLE as set by an asynchronous
* event handler. */
int watchMask; /* OR'ed combination of TCL_READABLE and
- * TCL_WRITABLE as set by Tcl_WatchFile. */
+ * TCL_WRITABLE as set by TcpWatch. */
Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */
ClientData acceptProcData; /* The data for the accept proc. */
wdsEntry dataSegment[2]; /* List of buffers to be written async. */
static void ClearZombieSockets _ANSI_ARGS_((void));
static void CloseCompletionRoutine _ANSI_ARGS_((TCPiopb *pb));
static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp,
- int port, char *host, char *myAddr, int myPort,
- int server, int async));
+ int port, CONST char *host, CONST char *myAddr,
+ int myPort, int server, int async));
static pascal void DNRCompletionRoutine _ANSI_ARGS_((
struct hostInfo *hostinfoPtr,
DNRState *dnrStatePtr));
static void FreeSocketInfo _ANSI_ARGS_((TcpState *statePtr));
static long GetBufferSize _ANSI_ARGS_((void));
-static OSErr GetHostFromString _ANSI_ARGS_((char *name,
+static OSErr GetHostFromString _ANSI_ARGS_((CONST char *name,
ip_addr *address));
static OSErr GetLocalAddress _ANSI_ARGS_((unsigned long *addr));
static void IOCompletionRoutine _ANSI_ARGS_((TCPiopb *pb));
static int TcpGetHandle _ANSI_ARGS_((ClientData instanceData,
int direction, ClientData *handlePtr));
static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
+ Tcl_Interp *interp, CONST char *optionName,
Tcl_DString *dsPtr));
static int TcpInput _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCodePtr));
static int TcpOutput _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCodePtr));
+ CONST char *buf, int toWrite, int *errorCodePtr));
static void TcpWatch _ANSI_ARGS_((ClientData instanceData,
int mask));
static int WaitForSocketEvent _ANSI_ARGS_((TcpState *infoPtr,
static Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
- TcpBlockMode, /* Set blocking or
+ (Tcl_ChannelTypeVersion)TcpBlockMode, /* Set blocking or
* non-blocking mode.*/
TcpClose, /* Close proc. */
TcpInput, /* Input proc. */
static int
TcpOutput(
ClientData instanceData, /* Channel state. */
- char *buf, /* The data buffer. */
+ CONST char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
TcpGetOptionProc(
ClientData instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL.*/
- char *optionName, /* Name of the option to
+ CONST char *optionName, /* Name of the option to
* retrieve the value for, or
* NULL to get all options and
* their values. */
* value; initialized by caller. */
{
TcpState *statePtr = (TcpState *) instanceData;
- int doPeerName = false, doSockName = false, doAll = false;
+ int doPeerName = false, doSockName = false, doError = false, doAll = false;
ip_addr tcpAddress;
char buffer[128];
OSErr err;
Tcl_DString dString;
TCPiopb statusPB;
int errorCode;
+ size_t len = 0;
/*
* If an asynchronous connect is in progress, attempt to wait for it
* if optionName is NULL.
*/
- if (optionName == (char *) NULL || optionName[0] == '\0') {
+ if (optionName == (CONST char *) NULL || optionName[0] == '\0') {
doAll = true;
} else {
- if (!strcmp(optionName, "-peername")) {
+ len = strlen(optionName);
+ if (!strncmp(optionName, "-peername", len)) {
doPeerName = true;
- } else if (!strcmp(optionName, "-sockname")) {
+ } else if (!strncmp(optionName, "-sockname", len)) {
doSockName = true;
+ } else if (!strncmp(optionName, "-error", len)) {
+ /* SF Bug #483575 */
+ doError = true;
} else {
return Tcl_BadChannelOption(interp, optionName,
- "peername sockname");
+ "error peername sockname");
+ }
+ }
+
+ /*
+ * SF Bug #483575
+ *
+ * Return error information. Currently we ignore
+ * this option. IOW, we always return the empty
+ * string, signaling 'no error'.
+ *
+ * FIXME: Get a mac/socket expert to write a correct
+ * FIXME: implementation.
+ */
+
+ if (doAll || doError) {
+ if (doAll) {
+ Tcl_DStringAppendElement(dsPtr, "-error");
+ Tcl_DStringAppendElement(dsPtr, "");
+ } else {
+ Tcl_DStringAppend (dsPtr, "", -1);
+ return TCL_OK;
}
}
CreateSocket(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
int port, /* Port number to open. */
- char *host, /* Name of host on which to open port. */
- char *myaddr, /* Optional client-side address */
+ CONST char *host, /* Name of host on which to open port. */
+ CONST char *myaddr, /* Optional client-side address */
int myport, /* Optional client-side port */
int server, /* 1 if socket should be a server socket,
* else 0 for a client socket. */
Tcl_OpenTcpClient(
Tcl_Interp *interp, /* For error reporting; can be NULL. */
int port, /* Port number to open. */
- char *host, /* Host on which to open port. */
- char *myaddr, /* Client-side address */
+ CONST char *host, /* Host on which to open port. */
+ CONST char *myaddr, /* Client-side address */
int myport, /* Client-side port */
int async) /* If nonzero, attempt to do an
* asynchronous connect. Otherwise
Tcl_Interp *interp, /* For error reporting - may be
* NULL. */
int port, /* Port number to open. */
- char *host, /* Name of local host. */
+ CONST char *host, /* Name of local host. */
Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections
* from new clients. */
ClientData acceptProcData) /* Data for the callback. */
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetHostName()
{
static int hostnameInited = 0;
static OSErr
GetHostFromString(
- char *name, /* Host in string form. */
+ CONST char *name, /* Host in string form. */
ip_addr *address) /* Returned IP address. */
{
OSErr err;
}
dnrState.done = 0;
GetCurrentProcess(&(dnrState.psn));
- err = StrToAddr(name, &dnrState.hostInfo, resultUPP, (Ptr) &dnrState);
+ err = StrToAddr((char*)name, &dnrState.hostInfo, resultUPP, (Ptr) &dnrState);
if (err == cacheFault) {
while (!dnrState.done) {
WaitNextEvent(0, &dummy, 1, NULL);
if (dnrState.hostInfo.rtnCode == cacheFault) {
dnrState.done = 0;
- err = StrToAddr(name, &dnrState.hostInfo, resultUPP, (Ptr) &dnrState);
+ err = StrToAddr((char*)name, &dnrState.hostInfo, resultUPP, (Ptr) &dnrState);
if (err == cacheFault) {
while (!dnrState.done) {
WaitNextEvent(0, &dummy, 1, NULL);
* will load the TEXT resource named "Init".
*/
-read 'TEXT' (TCL_LIBRARY_RESOURCES, "Init", purgeable) "::library:init.tcl";
-read 'TEXT' (TCL_LIBRARY_RESOURCES + 1, "Auto", purgeable) "::library:auto.tcl";
-read 'TEXT' (TCL_LIBRARY_RESOURCES + 2, "Package", purgeable,preload) "::library:package.tcl";
-read 'TEXT' (TCL_LIBRARY_RESOURCES + 3, "History", purgeable) "::library:history.tcl";
-read 'TEXT' (TCL_LIBRARY_RESOURCES + 4, "Word", purgeable,preload) "::library:word.tcl";
-read 'TEXT' (TCL_LIBRARY_RESOURCES + 5, "Parray", purgeable,preload) "::library:parray.tcl";
+read 'TEXT' (TCL_LIBRARY_RESOURCES, "init", purgeable) "::library:init.tcl";
+read 'TEXT' (TCL_LIBRARY_RESOURCES + 1, "auto", purgeable) "::library:auto.tcl";
+read 'TEXT' (TCL_LIBRARY_RESOURCES + 2, "package", purgeable,preload) "::library:package.tcl";
+read 'TEXT' (TCL_LIBRARY_RESOURCES + 3, "history", purgeable) "::library:history.tcl";
+read 'TEXT' (TCL_LIBRARY_RESOURCES + 4, "word", purgeable,preload) "::library:word.tcl";
+read 'TEXT' (TCL_LIBRARY_RESOURCES + 5, "parray", purgeable,preload) "::library:parray.tcl";
*/
#define TCL_TEST
-
+#define USE_COMPAT_CONST
#include "tclInt.h"
#include "tclMacInt.h"
#include "tclMacPort.h"
int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
static int DebuggerCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int WriteTextResource _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
\f
/*
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Not used. */
int argc, /* Not used. */
- char **argv) /* Not used. */
+ CONST char **argv) /* Not used. */
{
Debugger();
return TCL_OK;
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
- char **argv) /* Argument strings. */
+ CONST char **argv) /* Argument strings. */
{
char *errNum = "wrong # args: ";
char *errBad = "bad argument: ";
char *errStr;
- char *fileName = NULL, *rsrcName = NULL;
- char *data = NULL;
+ CONST char *fileName = NULL, *rsrcName = NULL;
+ CONST char *data = NULL;
int rsrcID = -1, i, protectIt = 0;
short fileRef = -1;
OSErr err;
TclMacThrdData *GetThreadDataStruct(Tcl_ThreadDataKey keyVal);
TclMacThrdData *RemoveThreadDataStruct(Tcl_ThreadDataKey keyVal);
+
+/*
+ * Note: The race evoked by the emulation layer for joinable threads
+ * (see ../win/tclWinThrd.c) cannot occur on this platform due to
+ * the cooperative implementation of multithreading.
+ */
\f
/*
*----------------------------------------------------------------------
int flags; /* Flags controlling behaviour of
* the new thread */
{
-
if (!TclMacHaveThreads()) {
return TCL_ERROR;
}
#if TARGET_CPU_68K && TARGET_RT_MAC_CFM
{
ThreadEntryProcPtr entryProc;
- entryProc = NewThreadEntryProc(proc);
+ entryProc = NewThreadEntryUPP(proc);
NewThread(kCooperativeThread, entryProc, (void *) clientData,
stackSize, kCreateIfNeeded, NULL, (ThreadID *) idPtr);
if ((ThreadID) *idPtr == kNoThreadID) {
return TCL_ERROR;
} else {
+ if (flags & TCL_THREAD_JOINABLE) {
+ TclRememberJoinableThread (*idPtr);
+ }
+
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_JoinThread --
+ *
+ * This procedure waits upon the exit of the specified thread.
+ *
+ * Results:
+ * TCL_OK if the wait was successful, TCL_ERROR else.
+ *
+ * Side effects:
+ * The result area is set to the exit code of the thread we
+ * waited upon.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_JoinThread(id, result)
+ Tcl_ThreadId id; /* Id of the thread to wait upon */
+ int* result; /* Reference to the storage the result
+ * of the thread we wait upon will be
+ * written into. */
+{
+ if (!TclMacHaveThreads()) {
+ return TCL_ERROR;
+ }
+
+ return TclJoinThread (id, result);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclpThreadExit --
*
* This procedure terminates the current thread.
}
GetCurrentThread(&curThread);
+ TclSignalExitThread ((Tcl_ThreadId) curThread, status);
+
DisposeThread(curThread, NULL, false);
}
#include "tclInt.h"
#include "tclPort.h"
+#include "tclMacInt.h"
#include <OSUtils.h>
#include <Timer.h>
#include <time.h>
/*
- * Static variables used by the TclpGetTime function.
+ * Static variables used by the Tcl_GetTime function.
*/
static int initalized = false;
static unsigned long baseSeconds;
static UnsignedWide microOffset;
+static int gmt_initialized = false;
+static long gmt_offset;
+static int gmt_isdst;
+TCL_DECLARE_MUTEX(gmtMutex)
+
+static int gmt_lastGetDateUseGMT = 0;
+
+typedef struct _TABLE {
+ char *name;
+ int type;
+ time_t value;
+} TABLE;
+
+
+#define HOUR(x) ((time_t) (3600 * x))
+
+#define tZONE 0
+#define tDAYZONE 1
+
+
+/*
+ * inverse timezone table, adapted from tclDate.c by removing duplicates and
+ * adding some made up names for unusual daylight savings
+ */
+static TABLE invTimezoneTable[] = {
+ { "Z", -1, HOUR( 36) }, /* Unknown */
+ { "GMT", tZONE, HOUR( 0) }, /* Greenwich Mean */
+ { "BST", tDAYZONE, HOUR( 0) }, /* British Summer */
+ { "WAT", tZONE, HOUR( 1) }, /* West Africa */
+ { "WADST", tDAYZONE, HOUR( 1) }, /* West Africa Daylight*/
+ { "AT", tZONE, HOUR( 2) }, /* Azores Daylight*/
+ { "ADST", tDAYZONE, HOUR( 2) }, /* Azores */
+ { "NFT", tZONE, HOUR( 7/2) }, /* Newfoundland */
+ { "NDT", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */
+ { "AST", tZONE, HOUR( 4) }, /* Atlantic Standard */
+ { "ADT", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */
+ { "EST", tZONE, HOUR( 5) }, /* Eastern Standard */
+ { "EDT", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */
+ { "CST", tZONE, HOUR( 6) }, /* Central Standard */
+ { "CDT", tDAYZONE, HOUR( 6) }, /* Central Daylight */
+ { "MST", tZONE, HOUR( 7) }, /* Mountain Standard */
+ { "MDT", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
+ { "PST", tZONE, HOUR( 8) }, /* Pacific Standard */
+ { "PDT", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
+ { "YST", tZONE, HOUR( 9) }, /* Yukon Standard */
+ { "YDT", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
+ { "HST", tZONE, HOUR(10) }, /* Hawaii Standard */
+ { "HDT", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
+ { "NT", tZONE, HOUR(11) }, /* Nome */
+ { "NST", tDAYZONE, HOUR(11) }, /* Nome Daylight*/
+ { "IDLW", tZONE, HOUR(12) }, /* International Date Line West */
+ { "CET", tZONE, -HOUR( 1) }, /* Central European */
+ { "CEST", tDAYZONE, -HOUR( 1) }, /* Central European Summer */
+ { "EET", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */
+ { "EEST", tDAYZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 Daylight*/
+ { "BT", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */
+ { "BDST", tDAYZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 Daylight*/
+ { "IT", tZONE, -HOUR( 7/2) }, /* Iran */
+ { "IDST", tDAYZONE, -HOUR( 7/2) }, /* Iran Daylight*/
+ { "ZP4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */
+ { "ZP4S", tDAYZONE, -HOUR( 4) }, /* USSR Zone 3 */
+ { "ZP5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */
+ { "ZP5S", tDAYZONE, -HOUR( 5) }, /* USSR Zone 4 */
+ { "IST", tZONE, -HOUR(11/2) }, /* Indian Standard */
+ { "ISDST", tDAYZONE, -HOUR(11/2) }, /* Indian Standard */
+ { "ZP6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */
+ { "ZP6S", tDAYZONE, -HOUR( 6) }, /* USSR Zone 5 */
+ { "WAST", tZONE, -HOUR( 7) }, /* West Australian Standard */
+ { "WADT", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
+ { "JT", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
+ { "JDST", tDAYZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
+ { "CCT", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
+ { "CCST", tDAYZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
+ { "JST", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
+ { "JSDST", tDAYZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
+ { "CAST", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
+ { "CADT", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
+ { "EAST", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
+ { "EADT", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
+ { "NZT", tZONE, -HOUR(12) }, /* New Zealand */
+ { "NZDT", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */
+ { NULL }
+};
+
/*
* Prototypes for procedures that are private to this file:
*/
/*
*-----------------------------------------------------------------------------
*
+ * TclpGetGMTOffset --
+ *
+ * This procedure gets the offset seconds that needs to be _added_ to tcl time
+ * in seconds (i.e. GMT time) to get local time needed as input to various
+ * Mac OS APIs, to convert Mac OS API output to tcl time, _subtract_ this value.
+ *
+ * Results:
+ * Number of seconds separating GMT time and mac.
+ *
+ * Side effects:
+ * None.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+long
+TclpGetGMTOffset()
+{
+ if (gmt_initialized == false) {
+ MachineLocation loc;
+
+ Tcl_MutexLock(&gmtMutex);
+ ReadLocation(&loc);
+ gmt_offset = loc.u.gmtDelta & 0x00ffffff;
+ if (gmt_offset & 0x00800000) {
+ gmt_offset = gmt_offset | 0xff000000;
+ }
+ gmt_isdst=(loc.u.dlsDelta < 0);
+ gmt_initialized = true;
+ Tcl_MutexUnlock(&gmtMutex);
+ }
+ return (gmt_offset);
+}
+\f
+/*
+ *-----------------------------------------------------------------------------
+ *
* TclpGetSeconds --
*
* This procedure returns the number of seconds from the epoch. On
TclpGetSeconds()
{
unsigned long seconds;
- MachineLocation loc;
- long int offset;
-
- ReadLocation(&loc);
- offset = loc.u.gmtDelta & 0x00ffffff;
- if (offset & 0x00800000) {
- offset = offset | 0xff000000;
- }
- if (ReadDateTime(&seconds) == noErr) {
- return (seconds - offset);
- } else {
- panic("Can't get time.");
- return 0;
- }
+ GetDateTime(&seconds);
+ return (seconds - TclpGetGMTOffset() + tcl_mac_epoch_offset);
}
\f
/*
TclpGetTimeZone (
unsigned long currentTime) /* Ignored on Mac. */
{
- MachineLocation loc;
- long int offset;
-
- ReadLocation(&loc);
- offset = loc.u.gmtDelta & 0x00ffffff;
- if (offset & 0x00700000) {
- offset |= 0xff000000;
- }
+ long offset;
/*
* Convert the Mac offset from seconds to minutes and
* add an hour if we have daylight savings time.
*/
- offset = -offset;
+ offset = -TclpGetGMTOffset();
offset /= 60;
- if (loc.u.dlsDelta < 0) {
+ if (gmt_isdst) {
offset += 60;
}
/*
*----------------------------------------------------------------------
*
- * TclpGetTime --
+ * Tcl_GetTime --
*
* Gets the current system time in seconds and microseconds
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
*/
void
-TclpGetTime(
+Tcl_GetTime(
Tcl_Time *timePtr) /* Location to store time information. */
{
UnsignedWide micro;
#endif
if (initalized == false) {
- MachineLocation loc;
- long int offset;
-
- ReadLocation(&loc);
- offset = loc.u.gmtDelta & 0x00ffffff;
- if (offset & 0x00800000) {
- offset = offset | 0xff000000;
- }
- if (ReadDateTime(&baseSeconds) != noErr) {
- /*
- * This should never happen!
- */
- return;
- }
+ GetDateTime(&baseSeconds);
/*
* Remove the local offset that ReadDateTime() adds.
*/
- baseSeconds -= offset;
+ baseSeconds -= TclpGetGMTOffset() - tcl_mac_epoch_offset;
Microseconds(µOffset);
initalized = true;
}
{
const time_t *tp = (const time_t *)time;
DateTimeRec dtr;
- MachineLocation loc;
- long int offset;
+ unsigned long offset=0L;
static struct tm statictime;
static const short monthday[12] =
{0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334};
-
- ReadLocation(&loc);
-
- if (useGMT) {
- SecondsToDate(*tp, &dtr);
- } else {
- offset = loc.u.gmtDelta & 0x00ffffff;
- if (offset & 0x00700000) {
- offset |= 0xff000000;
- }
+
+ if(useGMT)
+ SecondsToDate(*tp - tcl_mac_epoch_offset, &dtr);
+ else
+ SecondsToDate(*tp + TclpGetGMTOffset() - tcl_mac_epoch_offset, &dtr);
- SecondsToDate(*tp + offset, &dtr);
- }
-
statictime.tm_sec = dtr.second;
statictime.tm_min = dtr.minute;
statictime.tm_hour = dtr.hour;
if (1 < statictime.tm_mon && !(statictime.tm_year & 3)) {
++statictime.tm_yday;
}
- statictime.tm_isdst = loc.u.dlsDelta;
+ if(useGMT)
+ statictime.tm_isdst = 0;
+ else
+ statictime.tm_isdst = gmt_isdst;
+ gmt_lastGetDateUseGMT=useGMT; /* hack to make TclpGetTZName below work */
return(&statictime);
}
\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpGetTZName --
+ *
+ * Gets the current timezone string.
+ *
+ * Results:
+ * Returns a pointer to a static string, or NULL on failure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpGetTZName(int dst)
+{
+ register TABLE *tp;
+ long zonevalue=-TclpGetGMTOffset();
+
+ if (gmt_isdst)
+ zonevalue += HOUR(1);
+
+ if(gmt_lastGetDateUseGMT) /* hack: if last TclpGetDate was called */
+ zonevalue=0; /* with useGMT==1 then we're using GMT */
+
+ for (tp = invTimezoneTable; tp->name; tp++) {
+ if ((tp->value == zonevalue) && (tp->type == dst)) break;
+ }
+ if(!tp->name)
+ tp = invTimezoneTable; /* default to unknown */
+
+ return tp->name;
+}
+\f
#ifdef NO_LONG_LONG
/*
*----------------------------------------------------------------------
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
- char **argv) /* Argument strings. */
+ CONST char **argv) /* Argument strings. */
{
Tcl_Channel chan;
int mode, result, i;
resultObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultObjPtr);
- if (Tcl_ListObjGetElements(interp, resultObjPtr, &objc, &objv) != TCL_OK) {
+ if (Tcl_ListObjGetElements(interp, resultObjPtr, &objc, (Tcl_Obj ***)&objv) != TCL_OK) {
Tcl_DecrRefCount(resultObjPtr);
return TCL_ERROR;
}
*----------------------------------------------------------------------
*/
-#if defined(THINK_C) || defined(__MWERKS__)
+#if defined(THINK_C)
double hypotd(double x, double y);
double
err = FSMakeFSSpecCompat(foundVRefNum, foundDirID, "\p", spec);
return err;
}
+
+static int
+FSpLocationFromPathAlias _ANSI_ARGS_((int length, CONST char *path,
+ FSSpecPtr fileSpecPtr, Boolean resolveLink));
\f
/*
*----------------------------------------------------------------------
CONST char *path, /* The path to convert. */
FSSpecPtr fileSpecPtr) /* On return the spec for the path. */
{
+ return FSpLocationFromPathAlias(length, path, fileSpecPtr, TRUE);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FSpLLocationFromPath --
+ *
+ * This function obtains an FSSpec for a given macintosh path.
+ * Unlike the More Files function FSpLocationFromFullPath, this
+ * function will also accept partial paths and resolve any aliases
+ * along the path expect for the last path component.
+ *
+ * Results:
+ * OSErr code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+FSpLLocationFromPath(
+ int length, /* Length of path. */
+ CONST char *path, /* The path to convert. */
+ FSSpecPtr fileSpecPtr) /* On return the spec for the path. */
+{
+ return FSpLocationFromPathAlias(length, path, fileSpecPtr, FALSE);
+}
+
+static int
+FSpLocationFromPathAlias(
+ int length, /* Length of path. */
+ CONST char *path, /* The path to convert. */
+ FSSpecPtr fileSpecPtr, /* On return the spec for the path. */
+ Boolean resolveLink) /* Resolve the last path component? */
+{
Str255 fileName;
OSErr err;
short vRefNum;
long dirID;
int pos, cur;
Boolean isDirectory;
- Boolean wasAlias;
+ Boolean wasAlias=FALSE;
+ FSSpec lastFileSpec;
/*
* Check to see if this is a full path. If partial
}
err = FSMakeFSSpecCompat(vRefNum, dirID, fileName, fileSpecPtr);
if (err != noErr) return err;
+ lastFileSpec=*fileSpecPtr;
err = ResolveAliasFile(fileSpecPtr, true, &isDirectory, &wasAlias);
if (err != noErr) return err;
FSpGetDirectoryID(fileSpecPtr, &dirID, &isDirectory);
}
}
+ if(!resolveLink && wasAlias)
+ *fileSpecPtr=lastFileSpec;
+
return noErr;
}
\f
/*
*----------------------------------------------------------------------
*
- * GetGlobalMouse --
+ * GetGlobalMouseTcl --
*
* This procedure obtains the current mouse position in global
* coordinates.
*/
void
-GetGlobalMouse(
+GetGlobalMouseTcl(
Point *mouse) /* Mouse position. */
{
EventRecord event;
*mouse = event.where;
}
+pascal OSErr FSpGetDirectoryIDTcl (CONST FSSpec * spec,
+ long * theDirID, Boolean * isDirectory)
+{
+ return(FSpGetDirectoryID(spec, theDirID, isDirectory));
+}
+
+pascal short FSpOpenResFileCompatTcl (CONST FSSpec * spec, SignedByte permission)
+{
+ return(FSpOpenResFileCompat(spec,permission));
+}
+
+pascal void FSpCreateResFileCompatTcl (
+ CONST FSSpec * spec, OSType creator,
+ OSType fileType, ScriptCode scriptTag)
+{
+ FSpCreateResFileCompat (spec,creator,fileType,scriptTag);
+}
#
################################################################################
-INSTALL_ROOT =
+INSTALL_ROOT ?=
-BUILD_DIR = ../../build
+BUILD_DIR ?= ${CURDIR}/../../build
TARGET = Tcl
install: install-develop install-deploy
-embedded: embedded-develop embedded-deploy
+embedded: embedded-deploy
-install-embedded: install-embedded-develop install-embedded-deploy
+install-embedded: install-embedded-deploy
clean: clean-develop clean-deploy
install-deploy:
${DEPBUILD} install ${INSTALLOPTS}
-embedded-develop:
+embedded-develop: forceRelink
${DEVBUILD} ${EMBEDDEDOPTS}
-embedded-deploy:
+embedded-deploy: forceRelink
${DEPBUILD} ${EMBEDDEDOPTS}
install-embedded-develop:
${DEPBUILD} clean
################################################################################
+
+forceRelink:
+ @-cd ${BUILD_DIR}; \
+ rm -rf Tcl.framework tclsh8.4 \
+ Development.build/Tcl.build/Tcl Deployment.build/Tcl.build/Tcl
+
+################################################################################
+
+.PHONY: all install embedded clean develop deploy install-develop install-deploy \
+embedded-develop embedded-deploy install-embedded-develop install-embedded-deploy \
+clean-develop clean-deploy forceRelink \
+
+################################################################################
+++ /dev/null
-// !$*UTF8*$!
-{
- 005751AA02FB00930AC916F0 = {
- fRef = 005751AB02FB00930AC916F0;
- isa = PBXTextBookmark;
- name = "DefaultsDoc.rtf: 30";
- rLen = 32;
- rLoc = 2777;
- rType = 0;
- vrLen = 1334;
- vrLoc = 2136;
- };
- 005751AB02FB00930AC916F0 = {
- isa = PBXFileReference;
- name = DefaultsDoc.rtf;
- path = "/Developer/Applications/Project Builder.app/Contents/Resources/DefaultsDoc.rtf";
- refType = 0;
- };
- 00E2F845016E82EB0ACA28DC = {
- activeBuildStyle = 00E2F847016E82EB0ACA28DC;
- activeTarget = F50DC359017027D801DC9062;
- addToTargets = (
- 00E2F84C016E8B780ACA28DC,
- );
- breakpoints = (
- );
- perUserDictionary = {
- PBXPerProjectTemplateStateSaveDate = 49920633;
- "PBXTemplateGeometry-F5314676015831810DCA290F" = {
- ContentSize = "{789, 551}";
- LeftSlideOut = {
- Collapsed = NO;
- Frame = "{{0, 23}, {789, 528}}";
- Split0 = {
- ActiveTab = 2;
- Collapsed = NO;
- Frame = "{{0, 0}, {789, 528}}";
- Split0 = {
- Frame = "{{0, 204}, {789, 324}}";
- };
- SplitCount = 1;
- Tab0 = {
- Debugger = {
- Collapsed = NO;
- Frame = "{{0, 0}, {952, 321}}";
- Split0 = {
- Frame = "{{0, 24}, {952, 297}}";
- Split0 = {
- Frame = "{{0, 0}, {468, 297}}";
- };
- Split1 = {
- DebugVariablesTableConfiguration = (
- Name,
- 123,
- Value,
- 85,
- Summary,
- 241.123,
- );
- Frame = "{{477, 0}, {475, 297}}";
- };
- SplitCount = 2;
- };
- SplitCount = 1;
- Tab0 = {
- Frame = "{{0, 0}, {100, 50}}";
- };
- Tab1 = {
- Frame = "{{0, 0}, {100, 50}}";
- };
- TabCount = 2;
- TabsVisible = YES;
- };
- Frame = "{{0, 0}, {952, 321}}";
- LauncherConfigVersion = 7;
- };
- Tab1 = {
- Frame = "{{0, 0}, {781, 452}}";
- LauncherConfigVersion = 3;
- Runner = {
- Frame = "{{0, 0}, {781, 452}}";
- };
- };
- Tab2 = {
- BuildMessageFrame = "{{0, 0}, {791, 191}}";
- BuildTranscriptFrame = "{{0, 200}, {791, 0}}";
- Frame = "{{0, 0}, {789, 198}}";
- };
- Tab3 = {
- Frame = "{{0, 0}, {612, 295}}";
- };
- TabCount = 4;
- TabsVisible = NO;
- };
- SplitCount = 1;
- Tab0 = {
- Frame = "{{0, 0}, {300, 533}}";
- GroupTreeTableConfiguration = (
- TargetStatusColumn,
- 18,
- MainColumn,
- 267,
- );
- };
- Tab1 = {
- ClassesFrame = "{{0, 0}, {280, 398}}";
- ClassesTreeTableConfiguration = (
- PBXBookColumnIdentifier,
- 20,
- PBXClassColumnIdentifier,
- 237,
- );
- Frame = "{{0, 0}, {278, 659}}";
- MembersFrame = "{{0, 407}, {280, 252}}";
- MembersTreeTableConfiguration = (
- PBXBookColumnIdentifier,
- 20,
- PBXMethodColumnIdentifier,
- 236,
- );
- };
- Tab2 = {
- Frame = "{{0, 0}, {200, 100}}";
- };
- Tab3 = {
- Frame = "{{0, 0}, {200, 100}}";
- TargetTableConfiguration = (
- ActiveObject,
- 16,
- ObjectNames,
- 202.296,
- );
- };
- Tab4 = {
- BreakpointsTreeTableConfiguration = (
- breakpointColumn,
- 197,
- enabledColumn,
- 31,
- );
- Frame = "{{0, 0}, {250, 100}}";
- };
- TabCount = 5;
- TabsVisible = NO;
- };
- StatusViewVisible = YES;
- Template = F5314676015831810DCA290F;
- ToolbarVisible = YES;
- WindowLocation = "{7, 385}";
- };
- PBXWorkspaceContents = (
- {
- LeftSlideOut = {
- Split0 = {
- Split0 = {
- NavContent0 = {
- bookmark = 005751AA02FB00930AC916F0;
- history = (
- F5BFE56402F8B7A901DC9062,
- F5BFE56702F8B7A901DC9062,
- 00F4D9CE02F9BA490AC916F0,
- );
- prevStack = (
- F5BFE56A02F8B7A901DC9062,
- );
- };
- NavCount = 1;
- NavGeometry0 = {
- Frame = "{{0, 0}, {571, 548}}";
- NavBarVisible = YES;
- };
- };
- SplitCount = 1;
- Tab0 = {
- Debugger = {
- Split0 = {
- SplitCount = 2;
- };
- SplitCount = 1;
- TabCount = 2;
- };
- LauncherConfigVersion = 7;
- };
- Tab1 = {
- LauncherConfigVersion = 3;
- Runner = {
- };
- };
- TabCount = 4;
- };
- SplitCount = 1;
- Tab1 = {
- OptionsSetName = "Default Options";
- };
- TabCount = 5;
- };
- },
- );
- PBXWorkspaceGeometries = (
- {
- ContentSize = "{855, 571}";
- LeftSlideOut = {
- ActiveTab = 0;
- Collapsed = NO;
- Frame = "{{0, 23}, {855, 548}}";
- Split0 = {
- Collapsed = NO;
- Frame = "{{284, 0}, {571, 548}}";
- Split0 = {
- Frame = "{{0, 0}, {571, 548}}";
- };
- SplitCount = 1;
- Tab0 = {
- Debugger = {
- Collapsed = NO;
- Frame = "{{0, 0}, {681, 289}}";
- Split0 = {
- Frame = "{{0, 24}, {681, 265}}";
- Split0 = {
- Frame = "{{0, 0}, {333, 265}}";
- };
- Split1 = {
- DebugVariablesTableConfiguration = (
- Name,
- 82.80298,
- Value,
- 104.074,
- Summary,
- 126.123,
- );
- Frame = "{{342, 0}, {339, 265}}";
- };
- SplitCount = 2;
- };
- SplitCount = 1;
- Tab0 = {
- Frame = "{{0, 0}, {100, 50}}";
- };
- Tab1 = {
- Frame = "{{0, 0}, {100, 50}}";
- };
- TabCount = 2;
- TabsVisible = YES;
- };
- Frame = "{{0, 0}, {681, 289}}";
- LauncherConfigVersion = 7;
- };
- Tab1 = {
- Frame = "{{0, 0}, {681, 120}}";
- LauncherConfigVersion = 3;
- Runner = {
- Frame = "{{0, 0}, {681, 120}}";
- };
- };
- Tab2 = {
- BuildMessageFrame = "{{0, 0}, {683, 127}}";
- BuildTranscriptFrame = "{{0, 136}, {683, 100}}";
- Frame = "{{0, 0}, {681, 234}}";
- };
- Tab3 = {
- Frame = "{{0, 0}, {681, 238}}";
- };
- TabCount = 4;
- TabsVisible = NO;
- };
- SplitCount = 1;
- Tab0 = {
- Frame = "{{0, 0}, {260, 548}}";
- GroupTreeTableConfiguration = (
- SCMStatusColumn,
- 22,
- TargetStatusColumn,
- 18,
- MainColumn,
- 205,
- );
- };
- Tab1 = {
- ClassesFrame = "{{0, 0}, {250, 333}}";
- ClassesTreeTableConfiguration = (
- PBXBookColumnIdentifier,
- 20,
- PBXClassColumnIdentifier,
- 207,
- );
- Frame = "{{0, 0}, {248, 554}}";
- MembersFrame = "{{0, 342}, {250, 212}}";
- MembersTreeTableConfiguration = (
- PBXBookColumnIdentifier,
- 20,
- PBXMethodColumnIdentifier,
- 206,
- );
- };
- Tab2 = {
- Frame = "{{0, 0}, {217, 554}}";
- };
- Tab3 = {
- Frame = "{{0, 0}, {239, 548}}";
- TargetTableConfiguration = (
- ActiveObject,
- 16,
- ObjectNames,
- 206,
- );
- };
- Tab4 = {
- BreakpointsTreeTableConfiguration = (
- breakpointColumn,
- 197,
- enabledColumn,
- 31,
- );
- Frame = "{{0, 0}, {250, 554}}";
- };
- TabCount = 5;
- TabsVisible = YES;
- };
- StatusViewVisible = YES;
- Template = 64ABBB4501FA494900185B06;
- ToolbarVisible = YES;
- WindowLocation = "{77, 330}";
- },
- );
- PBXWorkspaceStateSaveDate = 49920633;
- };
- perUserProjectItems = {
- 005751AA02FB00930AC916F0 = 005751AA02FB00930AC916F0;
- 00F4D9CE02F9BA490AC916F0 = 00F4D9CE02F9BA490AC916F0;
- F5BFE56402F8B7A901DC9062 = F5BFE56402F8B7A901DC9062;
- F5BFE56702F8B7A901DC9062 = F5BFE56702F8B7A901DC9062;
- F5BFE56A02F8B7A901DC9062 = F5BFE56A02F8B7A901DC9062;
- };
- projectwideBuildSettings = {
- OBJROOT = "/Volumes/TheCloset/jingham/tcl-tk/source/tcl-merge/Objects";
- SYMROOT = "/Volumes/TheCloset/jingham/tcl-tk/source/tcl-merge/Products";
- };
- wantsIndex = 1;
- wantsSCM = 1;
- };
- 00E2F84B016E8A830ACA28DC = {
- activeExec = 0;
- };
- 00E2F84C016E8B780ACA28DC = {
- activeExec = 0;
- };
- 00E2F84E016E92110ACA28DC = {
- activeExec = 0;
- };
- 00F4D9CE02F9BA490AC916F0 = {
- fRef = 00F4D9CF02F9BA4A0AC916F0;
- isa = PBXTextBookmark;
- name = "DefaultsDoc.rtf: 30";
- rLen = 32;
- rLoc = 2777;
- rType = 0;
- vrLen = 1334;
- vrLoc = 2136;
- };
- 00F4D9CF02F9BA4A0AC916F0 = {
- isa = PBXFileReference;
- name = DefaultsDoc.rtf;
- path = "/Developer/Applications/Project Builder.app/Contents/Resources/DefaultsDoc.rtf";
- refType = 0;
- };
- F50DC359017027D801DC9062 = {
- activeExec = 0;
- };
- F5BFE56402F8B7A901DC9062 = {
- fRef = F5BFE56E02F8B7AA01DC9062;
- isa = PBXTextBookmark;
- name = "stat.h: 1";
- rLen = 0;
- rLoc = 0;
- rType = 0;
- vrLen = 1666;
- vrLoc = 3618;
- };
- F5BFE56702F8B7A901DC9062 = {
- fRef = F5F24F6E016ECAA401DC9062;
- isa = PBXTextBookmark;
- name = "tcl.h: 397";
- rLen = 6;
- rLoc = 11199;
- rType = 0;
- vrLen = 1293;
- vrLoc = 10644;
- };
- F5BFE56A02F8B7A901DC9062 = {
- fRef = F5F24F6E016ECAA401DC9062;
- isa = PBXTextBookmark;
- name = "tcl.h: 397";
- rLen = 6;
- rLoc = 11199;
- rType = 0;
- vrLen = 1293;
- vrLoc = 10644;
- };
- F5BFE56E02F8B7AA01DC9062 = {
- isa = PBXFileReference;
- name = stat.h;
- path = /usr/include/sys/stat.h;
- refType = 0;
- };
-}
+++ /dev/null
-// !$*UTF8*$!
-{
- archiveVersion = 1;
- classes = {
- };
- objectVersion = 38;
- objects = {
- 00530A0D0173C8270ACA28DC = {
- buildActionMask = 12;
- files = (
- );
- generatedFileNames = (
- );
- isa = PBXShellScriptBuildPhase;
- neededFileNames = (
- );
- runOnlyForDeploymentPostprocessing = 0;
- shellPath = /bin/sh;
- shellScript = "# install to ${INSTALL_ROOT} with optional stripping\ncd ${TEMP_DIR}/..\nif test \"${INSTALL_STRIP}\" = \"YES\"; then\nexport INSTALL_PROGRAM='${INSTALL} ${INSTALL_STRIP_PROGRAM}'\nexport INSTALL_LIBRARY='${INSTALL} ${INSTALL_STRIP_LIBRARY}'\nelse\nexport INSTALL_PROGRAM='${INSTALL}'\nexport INSTALL_LIBRARY='${INSTALL}'\nfi\ngnumake install-binaries install-libraries TCL_LIBRARY=\"@TCL_IN_FRAMEWORK@\" INSTALL_ROOT=\"${INSTALL_ROOT}\" SCRIPT_INSTALL_DIR=\"${INSTALL_ROOT}${LIBDIR}/Resources/Scripts\" INSTALL_PROGRAM=\"${INSTALL_PROGRAM}\" INSTALL_LIBRARY=\"${INSTALL_LIBRARY}\"";
- };
- 00530A0E0173CC960ACA28DC = {
- buildActionMask = 12;
- files = (
- );
- generatedFileNames = (
- );
- isa = PBXShellScriptBuildPhase;
- neededFileNames = (
- );
- runOnlyForDeploymentPostprocessing = 0;
- shellPath = /bin/sh;
- shellScript = "# fixup Framework structure\ncd \"${INSTALL_ROOT}${LIBDIR}\"\nln -fs Versions/Current/Headers ../..\nmv -f tclConfig.sh Resources\nif [ \"${BUILD_STYLE}\" = \"Development\" ]; then\n\t# keep copy of debug library around, so that\n\t# Deployment build can be installed on top\n\t# of Development build without overwriting\n\t# the debuglibrary\n\tcp -fp \"${PRODUCT_NAME}\" \"${PRODUCT_NAME}_debug\"\nfi";
- };
- 00E2F845016E82EB0ACA28DC = {
- buildStyles = (
- 00E2F847016E82EB0ACA28DC,
- 00E2F848016E82EB0ACA28DC,
- );
- isa = PBXProject;
- mainGroup = 00E2F846016E82EB0ACA28DC;
- productRefGroup = 00E2F84A016E8A830ACA28DC;
- projectDirPath = "";
- targets = (
- 00E2F84E016E92110ACA28DC,
- 00E2F84B016E8A830ACA28DC,
- 00E2F84C016E8B780ACA28DC,
- );
- };
- 00E2F846016E82EB0ACA28DC = {
- children = (
- F5C88655017D604601DC9062,
- F5F24FEE016ED0DF01DC9062,
- 00E2F855016E922C0ACA28DC,
- 00E2F857016E92B00ACA28DC,
- 00E2F85A016E92B00ACA28DC,
- 00E2F84A016E8A830ACA28DC,
- );
- isa = PBXGroup;
- refType = 4;
- };
- 00E2F847016E82EB0ACA28DC = {
- buildRules = (
- );
- buildSettings = {
- EXTRA_CONFIGURE_FLAGS = "--enable-symbols";
- INSTALL_STRIP = NO;
- TEMP_DIR = "${OBJROOT}/Development.build/$(PROJECT_NAME).build/$(TARGET_NAME).build";
- };
- isa = PBXBuildStyle;
- name = Development;
- };
- 00E2F848016E82EB0ACA28DC = {
- buildRules = (
- );
- buildSettings = {
- INSTALL_STRIP = YES;
- TEMP_DIR = "${OBJROOT}/Deployment.build/$(PROJECT_NAME).build/$(TARGET_NAME).build";
- };
- isa = PBXBuildStyle;
- name = Deployment;
- };
- 00E2F84A016E8A830ACA28DC = {
- children = (
- 00E2F84D016E92110ACA28DC,
- F53ACC5C031D9D11016F146B,
- F53ACC73031DA405016F146B,
- );
- isa = PBXGroup;
- name = Products;
- refType = 4;
- };
- 00E2F84B016E8A830ACA28DC = {
- buildArgumentsString = "-c \"if [ \\\"${ACTION}\\\" != \\\"clean\\\" ]; then if [ -z \\\"`find . -name Makefile -newer \\\"${SRCROOT}/../unix/configure\\\"`\\\" ]; then \\\"${SRCROOT}/../unix/configure\\\" --prefix=/usr --mandir=/usr/share/man --libdir=\\\"${LIBDIR}\\\" --includedir=\\\"${LIBDIR}/Headers\\\" --enable-threads --enable-framework ${EXTRA_CONFIGURE_FLAGS}; mkdir -p Tcl.framework; ln -fs ../Tcl Tcl.framework/Tcl; fi; else rm -f Makefile; fi\"";
- buildPhases = (
- );
- buildSettings = {
- EXTRA_CONFIGURE_FLAGS = "";
- FRAMEWORK_VERSION = 8.4;
- INSTALL_PATH = /Library/Frameworks;
- LIBDIR = "${INSTALL_PATH}/${PRODUCT_NAME}.framework/Versions/${FRAMEWORK_VERSION}";
- PRODUCT_NAME = Tcl;
- };
- buildToolPath = /bin/sh;
- buildWorkingDirectory = "${TEMP_DIR}/..";
- dependencies = (
- );
- isa = PBXLegacyTarget;
- name = Configure;
- productName = Configure;
- settingsToExpand = 6;
- settingsToPassInEnvironment = 287;
- settingsToPassOnCommandLine = 280;
- shouldUseHeadermap = 0;
- };
- 00E2F84C016E8B780ACA28DC = {
- buildArgumentsString = "-c \"if [ \\\"${ACTION}\\\" != \\\"clean\\\" ]; then gnumake tclsh tcltest TCL_LIBRARY=\\\"@TCL_IN_FRAMEWORK@\\\" TCL_PACKAGE_PATH=\\\"~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl\\\" DYLIB_INSTALL_DIR=\\\"${DYLIB_INSTALL_DIR}\\\" ${EXTRA_MAKE_FLAGS}; else gnumake clean; fi\"";
- buildPhases = (
- );
- buildSettings = {
- DYLIB_INSTALL_DIR = "${DYLIB_INSTALL_PATH}/${PRODUCT_NAME}.framework/Versions/${FRAMEWORK_VERSION}";
- DYLIB_INSTALL_PATH = "${INSTALL_PATH}";
- EXTRA_MAKE_FLAGS = "";
- FRAMEWORK_VERSION = 8.4;
- INSTALL_PATH = /Library/Frameworks;
- PRODUCT_NAME = Tcl;
- };
- buildToolPath = /bin/sh;
- buildWorkingDirectory = "${TEMP_DIR}/..";
- dependencies = (
- F5877EB5031F7997016F146B,
- );
- isa = PBXLegacyTarget;
- name = Make;
- productName = Make;
- settingsToExpand = 6;
- settingsToPassInEnvironment = 287;
- settingsToPassOnCommandLine = 280;
- shouldUseHeadermap = 0;
- };
- 00E2F84D016E92110ACA28DC = {
- isa = PBXFrameworkReference;
- path = Tcl.framework;
- refType = 3;
- };
- 00E2F84E016E92110ACA28DC = {
- buildPhases = (
- F5877FB6031F97AF016F146B,
- F50DC36A01703B7301DC9062,
- F50DC367017033D701DC9062,
- F50DC3680170344801DC9062,
- 00E2F84F016E92110ACA28DC,
- F5BE9BBF02FB5974016F146B,
- 00530A0D0173C8270ACA28DC,
- 00530A0E0173CC960ACA28DC,
- F5877FBB031FA90A016F146B,
- F59AE5E3017AC67A01DC9062,
- );
- buildSettings = {
- DSTROOT = "${TEMP_DIR}";
- EXTRA_MAKE_INSTALL_FLAGS = "";
- FRAMEWORK_VERSION = 8.4;
- INSTALL_PATH = /Library/Frameworks;
- LIBDIR = "${INSTALL_PATH}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}/Versions/${FRAMEWORK_VERSION}";
- PRODUCT_NAME = Tcl;
- WRAPPER_EXTENSION = framework;
- };
- dependencies = (
- F5877EB6031F79A4016F146B,
- );
- isa = PBXFrameworkTarget;
- name = Tcl;
- productInstallPath = /Library/Frameworks;
- productName = TclLibrary;
- productReference = 00E2F84D016E92110ACA28DC;
- productSettingsXML = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
-<!DOCTYPE plist PUBLIC \"-//Apple Computer//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">
-<plist version=\"1.0\">
-<dict>
- <key>CFBundleDevelopmentRegion</key>
- <string>English</string>
- <key>CFBundleExecutable</key>
- <string>Tcl</string>
- <key>CFBundleGetInfoString</key>
- <string>Tcl Library 8.4, Copyright © 2002 Tcl Core Team.
-MacOS X Port by Jim Ingham <jingham@apple.com> & Ian Reid, Copyright © 2001-2002, Apple Computer, Inc.</string>
- <key>CFBundleIconFile</key>
- <string></string>
- <key>CFBundleIdentifier</key>
- <string>com.tcltk.tcllibrary</string>
- <key>CFBundleInfoDictionaryVersion</key>
- <string>6.0</string>
- <key>CFBundleName</key>
- <string>Tcl Library 8.4</string>
- <key>CFBundlePackageType</key>
- <string>FMWK</string>
- <key>CFBundleShortVersionString</key>
- <string>8.4.0</string>
- <key>CFBundleSignature</key>
- <string>Tcl </string>
- <key>CFBundleVersion</key>
- <string>8.4.0</string>
-</dict>
-</plist>
-";
- shouldUseHeadermap = 0;
- };
- 00E2F84F016E92110ACA28DC = {
- buildActionMask = 2147483647;
- files = (
- );
- isa = PBXHeadersBuildPhase;
- runOnlyForDeploymentPostprocessing = 0;
- };
- 00E2F854016E922C0ACA28DC = {
- children = (
- F5F24F87016ECAFC01DC9062,
- F5F24F88016ECAFC01DC9062,
- F5F24F89016ECAFC01DC9062,
- F5F24F8A016ECAFC01DC9062,
- F5F24F8B016ECAFC01DC9062,
- F5F24F8C016ECAFC01DC9062,
- F5F24F8D016ECAFC01DC9062,
- F5F24F8E016ECAFC01DC9062,
- F5F24F8F016ECAFC01DC9062,
- F5F24F90016ECAFC01DC9062,
- F5F24F91016ECAFC01DC9062,
- F5F24F92016ECAFC01DC9062,
- F5F24F93016ECAFC01DC9062,
- F5F24F94016ECAFC01DC9062,
- F5F24F95016ECAFC01DC9062,
- F5F24F96016ECAFC01DC9062,
- F5F24F97016ECAFC01DC9062,
- F5F24F98016ECAFC01DC9062,
- F5F24F99016ECAFC01DC9062,
- F5F24F9A016ECAFC01DC9062,
- F5F24F9B016ECAFC01DC9062,
- F5F24F9C016ECAFC01DC9062,
- F5F24F9D016ECAFC01DC9062,
- F5F24F9E016ECAFC01DC9062,
- F5F24F9F016ECAFC01DC9062,
- F5F24FA0016ECAFC01DC9062,
- F5F24FA1016ECAFC01DC9062,
- F5F24FA2016ECAFC01DC9062,
- F5F24FA3016ECAFC01DC9062,
- F5F24FA4016ECAFC01DC9062,
- F5F24FA5016ECAFC01DC9062,
- F5F24FA6016ECAFC01DC9062,
- F5F24FA7016ECAFC01DC9062,
- F5F24FA8016ECAFC01DC9062,
- F5F24FA9016ECAFC01DC9062,
- F5F24FAA016ECAFC01DC9062,
- F5F24FAB016ECAFC01DC9062,
- F5F24FAC016ECAFC01DC9062,
- F5F24FAD016ECAFC01DC9062,
- F5F24FAE016ECAFC01DC9062,
- F5F24FAF016ECAFC01DC9062,
- F5F24FB0016ECAFC01DC9062,
- F5F24FB1016ECAFC01DC9062,
- F5F24FB2016ECAFC01DC9062,
- F5F24FB3016ECAFC01DC9062,
- F5F24FB4016ECAFC01DC9062,
- F5F24FB5016ECAFC01DC9062,
- F5F24FB6016ECAFC01DC9062,
- F5F24FB7016ECAFC01DC9062,
- F5F24FB8016ECAFC01DC9062,
- F5F24FB9016ECAFC01DC9062,
- F5F24FBA016ECAFC01DC9062,
- F5F24FBB016ECAFC01DC9062,
- F5F24FD3016ECB4901DC9062,
- F5F24FBC016ECAFC01DC9062,
- F5F24FBD016ECAFC01DC9062,
- F5F24FBE016ECAFC01DC9062,
- F5F24FBF016ECAFC01DC9062,
- F5F24FC0016ECAFC01DC9062,
- F5F24FC1016ECAFC01DC9062,
- F5F24FC2016ECAFC01DC9062,
- F5F24FC3016ECAFC01DC9062,
- F5F24FC4016ECAFC01DC9062,
- F5F24FC5016ECAFC01DC9062,
- F5F24FC6016ECAFC01DC9062,
- F5F24FC7016ECAFC01DC9062,
- F5F24FC8016ECAFC01DC9062,
- F5F24FC9016ECAFC01DC9062,
- F5F24FCA016ECAFC01DC9062,
- F5F24FCB016ECAFC01DC9062,
- F5F24FCC016ECAFC01DC9062,
- F5F24FCD016ECAFC01DC9062,
- F5F24FCE016ECAFC01DC9062,
- F5F24FCF016ECAFC01DC9062,
- F5F24FD0016ECAFC01DC9062,
- );
- isa = PBXGroup;
- name = Sources;
- path = "";
- refType = 4;
- };
- 00E2F855016E922C0ACA28DC = {
- children = (
- 00E2F856016E92B00ACA28DC,
- 00E2F854016E922C0ACA28DC,
- );
- isa = PBXGroup;
- name = generic;
- refType = 4;
- };
- 00E2F856016E92B00ACA28DC = {
- children = (
- F5F24F6B016ECAA401DC9062,
- F5F24F6C016ECAA401DC9062,
- F5F24F6D016ECAA401DC9062,
- F5F24F6E016ECAA401DC9062,
- F5F24F6F016ECAA401DC9062,
- F5F24F70016ECAA401DC9062,
- F5F24F71016ECAA401DC9062,
- F5F24F72016ECAA401DC9062,
- F5F24F73016ECAA401DC9062,
- F5F24F74016ECAA401DC9062,
- F5F24F75016ECAA401DC9062,
- F5F24F76016ECAA401DC9062,
- F5F24F77016ECAA401DC9062,
- F5F24F78016ECAA401DC9062,
- F5F24FD1016ECB1E01DC9062,
- F5F24FD2016ECB1E01DC9062,
- );
- isa = PBXGroup;
- name = Headers;
- refType = 4;
- };
- 00E2F857016E92B00ACA28DC = {
- children = (
- 00E2F858016E92B00ACA28DC,
- 00E2F859016E92B00ACA28DC,
- );
- isa = PBXGroup;
- name = macosx;
- refType = 4;
- };
- 00E2F858016E92B00ACA28DC = {
- children = (
- );
- isa = PBXGroup;
- name = Headers;
- refType = 4;
- };
- 00E2F859016E92B00ACA28DC = {
- children = (
- F5A1836F018242A501DC9062,
- );
- isa = PBXGroup;
- name = Sources;
- refType = 4;
- };
- 00E2F85A016E92B00ACA28DC = {
- children = (
- 00E2F85B016E92B00ACA28DC,
- 00E2F85C016E92B00ACA28DC,
- );
- isa = PBXGroup;
- name = unix;
- refType = 4;
- };
- 00E2F85B016E92B00ACA28DC = {
- children = (
- F5F24FD6016ECC0F01DC9062,
- F5F24FD7016ECC0F01DC9062,
- );
- isa = PBXGroup;
- name = Headers;
- refType = 4;
- };
- 00E2F85C016E92B00ACA28DC = {
- children = (
- F5F24FD8016ECC0F01DC9062,
- F5F24FD9016ECC0F01DC9062,
- F5F24FDB016ECC0F01DC9062,
- F5F24FDC016ECC0F01DC9062,
- F5F24FDD016ECC0F01DC9062,
- F5F24FDE016ECC0F01DC9062,
- F5F24FDF016ECC0F01DC9062,
- F5F24FE0016ECC0F01DC9062,
- F5F24FE1016ECC0F01DC9062,
- F5F24FE2016ECC0F01DC9062,
- F5F24FE3016ECC0F01DC9062,
- F5F24FE4016ECC0F01DC9062,
- F5F24FE5016ECC0F01DC9062,
- F5F24FE6016ECC0F01DC9062,
- F5F24FE7016ECC0F01DC9062,
- );
- isa = PBXGroup;
- name = Sources;
- refType = 4;
- };
-//000
-//001
-//002
-//003
-//004
-//F50
-//F51
-//F52
-//F53
-//F54
- F50DC367017033D701DC9062 = {
- buildActionMask = 2147483647;
- files = (
- );
- isa = PBXFrameworksBuildPhase;
- runOnlyForDeploymentPostprocessing = 0;
- };
- F50DC3680170344801DC9062 = {
- buildActionMask = 2147483647;
- files = (
- );
- isa = PBXResourcesBuildPhase;
- runOnlyForDeploymentPostprocessing = 0;
- };
- F50DC36A01703B7301DC9062 = {
- buildActionMask = 2147483647;
- files = (
- );
- isa = PBXSourcesBuildPhase;
- runOnlyForDeploymentPostprocessing = 0;
- };
- F53ACC5C031D9D11016F146B = {
- isa = PBXExecutableFileReference;
- name = tclsh8.4;
- path = ../../build/tclsh8.4;
- refType = 2;
- };
- F53ACC73031DA405016F146B = {
- isa = PBXExecutableFileReference;
- name = tcltest;
- path = ../../build/tcltest;
- refType = 2;
- };
- F5877EB5031F7997016F146B = {
- isa = PBXTargetDependency;
- target = 00E2F84B016E8A830ACA28DC;
- };
- F5877EB6031F79A4016F146B = {
- isa = PBXTargetDependency;
- target = 00E2F84C016E8B780ACA28DC;
- };
- F5877FB6031F97AF016F146B = {
- buildActionMask = 8;
- files = (
- );
- generatedFileNames = (
- );
- isa = PBXShellScriptBuildPhase;
- neededFileNames = (
- );
- runOnlyForDeploymentPostprocessing = 1;
- shellPath = /bin/sh;
- shellScript = "# ensure we can overwrite a previous install\nif [ -d \"${INSTALL_ROOT}${INSTALL_PATH}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}\" ]; then\n chmod -RH u+w \"${INSTALL_ROOT}${INSTALL_PATH}/${PRODUCT_NAME}.${WRAPPER_EXTENSION}\"\nfi";
- };
- F5877FBB031FA90A016F146B = {
- buildActionMask = 8;
- files = (
- );
- generatedFileNames = (
- );
- isa = PBXShellScriptBuildPhase;
- neededFileNames = (
- );
- runOnlyForDeploymentPostprocessing = 1;
- shellPath = /bin/sh;
- shellScript = "if [ `echo \"${DYLIB_INSTALL_PATH:-}\" | grep -c \"@executable_path\"` -gt 0 ]; then\n# if we are embedding frameworks, don't install tclsh\nrm -f \"${INSTALL_ROOT}/usr/bin/tclsh${FRAMEWORK_VERSION}\"\nrmdir -p \"${INSTALL_ROOT}/usr/bin\"\necho \"tclsh removed\"\nelse\n# redo prebinding\ncd \"${INSTALL_ROOT}\"\nif [ ! -d usr/lib ]; then mkdir -p usr; ln -fs /usr/lib usr/; RM_USRLIB=1; fi\nif [ ! -d System ]; then ln -fs /System .; RM_SYSTEM=1; fi\nredo_prebinding -r . \"./usr/bin/tclsh${FRAMEWORK_VERSION}\"\nif [ -n \"${RM_USRLIB:-}\" ]; then rm -f usr/lib; rmdir -p usr; fi\nif [ -n \"${RM_SYSTEM:-}\" ]; then rm -f System; fi\nfi";
- };
- F59AE5E3017AC67A01DC9062 = {
- buildActionMask = 8;
- files = (
- );
- generatedFileNames = (
- );
- isa = PBXShellScriptBuildPhase;
- neededFileNames = (
- );
- runOnlyForDeploymentPostprocessing = 1;
- shellPath = /bin/sh;
- shellScript = "# build html documentation\nif [ \"${BUILD_STYLE}\" = \"Deployment\" ]; then\n cd \"${TEMP_DIR}/..\"\n gnumake html DISTDIR=\"${INSTALL_ROOT}${LIBDIR}/Resources/English.lproj/Documentation/Reference\"\n cd \"${INSTALL_ROOT}${LIBDIR}/Resources/English.lproj/Documentation/Reference\"\n ln -fs contents.htm html/index.html\n rm -f \"${PRODUCT_NAME}\"; ln -fs html \"${PRODUCT_NAME}\"\nfi";
- };
- F5A1836F018242A501DC9062 = {
- isa = PBXFileReference;
- path = tclMacOSXBundle.c;
- refType = 4;
- };
- F5BE9BBF02FB5974016F146B = {
- buildActionMask = 2147483647;
- files = (
- );
- generatedFileNames = (
- );
- isa = PBXShellScriptBuildPhase;
- neededFileNames = (
- );
- runOnlyForDeploymentPostprocessing = 0;
- shellPath = /bin/sh;
- shellScript = "# symolic link hackery to trick\n# 'make install INSTALL_ROOT=${TEMP_DIR}'\n# into building Tcl.framework and tclsh in ${SYMROOT}\ncd \"${TEMP_DIR}\"\nmkdir -p Library\nmkdir -p usr\nrm -f Library/Frameworks; ln -fs \"${SYMROOT}\" Library/Frameworks\nrm -f usr/bin; ln -fs \"${SYMROOT}\" usr/bin\nln -fs \"${TEMP_DIR}/../tcltest\" \"${SYMROOT}\"";
- };
- F5C88655017D604601DC9062 = {
- children = (
- F5C88656017D604601DC9062,
- F5C88657017D60C901DC9062,
- F5C88658017D60C901DC9062,
- );
- isa = PBXGroup;
- name = "Header Tools";
- refType = 4;
- };
- F5C88656017D604601DC9062 = {
- isa = PBXFileReference;
- name = genStubs.tcl;
- path = ../tools/genStubs.tcl;
- refType = 2;
- };
- F5C88657017D60C901DC9062 = {
- isa = PBXFileReference;
- name = tcl.decls;
- path = ../generic/tcl.decls;
- refType = 2;
- };
- F5C88658017D60C901DC9062 = {
- isa = PBXFileReference;
- name = tclInt.decls;
- path = ../generic/tclInt.decls;
- refType = 2;
- };
- F5F24F6B016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = regcustom.h;
- path = ../generic/regcustom.h;
- refType = 2;
- };
- F5F24F6C016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = regerrs.h;
- path = ../generic/regerrs.h;
- refType = 2;
- };
- F5F24F6D016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = regguts.h;
- path = ../generic/regguts.h;
- refType = 2;
- };
- F5F24F6E016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tcl.h;
- path = ../generic/tcl.h;
- refType = 2;
- };
- F5F24F6F016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclCompile.h;
- path = ../generic/tclCompile.h;
- refType = 2;
- };
- F5F24F70016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclDecls.h;
- path = ../generic/tclDecls.h;
- refType = 2;
- };
- F5F24F71016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclInitScript.h;
- path = ../generic/tclInitScript.h;
- refType = 2;
- };
- F5F24F72016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclInt.h;
- path = ../generic/tclInt.h;
- refType = 2;
- };
- F5F24F73016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclIntDecls.h;
- path = ../generic/tclIntDecls.h;
- refType = 2;
- };
- F5F24F74016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclIntPlatDecls.h;
- path = ../generic/tclIntPlatDecls.h;
- refType = 2;
- };
- F5F24F75016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclIO.h;
- path = ../generic/tclIO.h;
- refType = 2;
- };
- F5F24F76016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclMath.h;
- path = ../generic/tclMath.h;
- refType = 2;
- };
- F5F24F77016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclPlatDecls.h;
- path = ../generic/tclPlatDecls.h;
- refType = 2;
- };
- F5F24F78016ECAA401DC9062 = {
- isa = PBXFileReference;
- name = tclRegexp.h;
- path = ../generic/tclRegexp.h;
- refType = 2;
- };
- F5F24F87016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regc_color.c;
- path = ../generic/regc_color.c;
- refType = 2;
- };
- F5F24F88016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regc_cvec.c;
- path = ../generic/regc_cvec.c;
- refType = 2;
- };
- F5F24F89016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regc_lex.c;
- path = ../generic/regc_lex.c;
- refType = 2;
- };
- F5F24F8A016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regc_locale.c;
- path = ../generic/regc_locale.c;
- refType = 2;
- };
- F5F24F8B016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regc_nfa.c;
- path = ../generic/regc_nfa.c;
- refType = 2;
- };
- F5F24F8C016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regcomp.c;
- path = ../generic/regcomp.c;
- refType = 2;
- };
- F5F24F8D016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = rege_dfa.c;
- path = ../generic/rege_dfa.c;
- refType = 2;
- };
- F5F24F8E016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regerror.c;
- path = ../generic/regerror.c;
- refType = 2;
- };
- F5F24F8F016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regexec.c;
- path = ../generic/regexec.c;
- refType = 2;
- };
- F5F24F90016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regfree.c;
- path = ../generic/regfree.c;
- refType = 2;
- };
- F5F24F91016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = regfronts.c;
- path = ../generic/regfronts.c;
- refType = 2;
- };
- F5F24F92016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclAlloc.c;
- path = ../generic/tclAlloc.c;
- refType = 2;
- };
- F5F24F93016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclAsync.c;
- path = ../generic/tclAsync.c;
- refType = 2;
- };
- F5F24F94016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclBasic.c;
- path = ../generic/tclBasic.c;
- refType = 2;
- };
- F5F24F95016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclBinary.c;
- path = ../generic/tclBinary.c;
- refType = 2;
- };
- F5F24F96016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclCkalloc.c;
- path = ../generic/tclCkalloc.c;
- refType = 2;
- };
- F5F24F97016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclClock.c;
- path = ../generic/tclClock.c;
- refType = 2;
- };
- F5F24F98016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclCmdAH.c;
- path = ../generic/tclCmdAH.c;
- refType = 2;
- };
- F5F24F99016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclCmdIL.c;
- path = ../generic/tclCmdIL.c;
- refType = 2;
- };
- F5F24F9A016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclCmdMZ.c;
- path = ../generic/tclCmdMZ.c;
- refType = 2;
- };
- F5F24F9B016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclCompCmds.c;
- path = ../generic/tclCompCmds.c;
- refType = 2;
- };
- F5F24F9C016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclCompExpr.c;
- path = ../generic/tclCompExpr.c;
- refType = 2;
- };
- F5F24F9D016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclCompile.c;
- path = ../generic/tclCompile.c;
- refType = 2;
- };
- F5F24F9E016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclDate.c;
- path = ../generic/tclDate.c;
- refType = 2;
- };
- F5F24F9F016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclEncoding.c;
- path = ../generic/tclEncoding.c;
- refType = 2;
- };
- F5F24FA0016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclEnv.c;
- path = ../generic/tclEnv.c;
- refType = 2;
- };
- F5F24FA1016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclEvent.c;
- path = ../generic/tclEvent.c;
- refType = 2;
- };
- F5F24FA2016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclExecute.c;
- path = ../generic/tclExecute.c;
- refType = 2;
- };
- F5F24FA3016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclFCmd.c;
- path = ../generic/tclFCmd.c;
- refType = 2;
- };
- F5F24FA4016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclFileName.c;
- path = ../generic/tclFileName.c;
- refType = 2;
- };
- F5F24FA5016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclGet.c;
- path = ../generic/tclGet.c;
- refType = 2;
- };
- F5F24FA6016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclHash.c;
- path = ../generic/tclHash.c;
- refType = 2;
- };
- F5F24FA7016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclHistory.c;
- path = ../generic/tclHistory.c;
- refType = 2;
- };
- F5F24FA8016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclIndexObj.c;
- path = ../generic/tclIndexObj.c;
- refType = 2;
- };
- F5F24FA9016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclInterp.c;
- path = ../generic/tclInterp.c;
- refType = 2;
- };
- F5F24FAA016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclIO.c;
- path = ../generic/tclIO.c;
- refType = 2;
- };
- F5F24FAB016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclIOCmd.c;
- path = ../generic/tclIOCmd.c;
- refType = 2;
- };
- F5F24FAC016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclIOGT.c;
- path = ../generic/tclIOGT.c;
- refType = 2;
- };
- F5F24FAD016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclIOSock.c;
- path = ../generic/tclIOSock.c;
- refType = 2;
- };
- F5F24FAE016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclIOUtil.c;
- path = ../generic/tclIOUtil.c;
- refType = 2;
- };
- F5F24FAF016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclLink.c;
- path = ../generic/tclLink.c;
- refType = 2;
- };
- F5F24FB0016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclListObj.c;
- path = ../generic/tclListObj.c;
- refType = 2;
- };
- F5F24FB1016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclLiteral.c;
- path = ../generic/tclLiteral.c;
- refType = 2;
- };
- F5F24FB2016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclLoad.c;
- path = ../generic/tclLoad.c;
- refType = 2;
- };
- F5F24FB3016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclLoadNone.c;
- path = ../generic/tclLoadNone.c;
- refType = 2;
- };
- F5F24FB4016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclMain.c;
- path = ../generic/tclMain.c;
- refType = 2;
- };
- F5F24FB5016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclNamesp.c;
- path = ../generic/tclNamesp.c;
- refType = 2;
- };
- F5F24FB6016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclNotify.c;
- path = ../generic/tclNotify.c;
- refType = 2;
- };
- F5F24FB7016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclObj.c;
- path = ../generic/tclObj.c;
- refType = 2;
- };
- F5F24FB8016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclPanic.c;
- path = ../generic/tclPanic.c;
- refType = 2;
- };
- F5F24FB9016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclParse.c;
- path = ../generic/tclParse.c;
- refType = 2;
- };
- F5F24FBA016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclParseExpr.c;
- path = ../generic/tclParseExpr.c;
- refType = 2;
- };
- F5F24FBB016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclPipe.c;
- path = ../generic/tclPipe.c;
- refType = 2;
- };
- F5F24FBC016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclPosixStr.c;
- path = ../generic/tclPosixStr.c;
- refType = 2;
- };
- F5F24FBD016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclPreserve.c;
- path = ../generic/tclPreserve.c;
- refType = 2;
- };
- F5F24FBE016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclProc.c;
- path = ../generic/tclProc.c;
- refType = 2;
- };
- F5F24FBF016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclRegexp.c;
- path = ../generic/tclRegexp.c;
- refType = 2;
- };
- F5F24FC0016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclResolve.c;
- path = ../generic/tclResolve.c;
- refType = 2;
- };
- F5F24FC1016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclResult.c;
- path = ../generic/tclResult.c;
- refType = 2;
- };
- F5F24FC2016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclScan.c;
- path = ../generic/tclScan.c;
- refType = 2;
- };
- F5F24FC3016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclStringObj.c;
- path = ../generic/tclStringObj.c;
- refType = 2;
- };
- F5F24FC4016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclStubInit.c;
- path = ../generic/tclStubInit.c;
- refType = 2;
- };
- F5F24FC5016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclStubLib.c;
- path = ../generic/tclStubLib.c;
- refType = 2;
- };
- F5F24FC6016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclTest.c;
- path = ../generic/tclTest.c;
- refType = 2;
- };
- F5F24FC7016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclTestObj.c;
- path = ../generic/tclTestObj.c;
- refType = 2;
- };
- F5F24FC8016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclTestProcBodyObj.c;
- path = ../generic/tclTestProcBodyObj.c;
- refType = 2;
- };
- F5F24FC9016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclThread.c;
- path = ../generic/tclThread.c;
- refType = 2;
- };
- F5F24FCA016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclThreadJoin.c;
- path = ../generic/tclThreadJoin.c;
- refType = 2;
- };
- F5F24FCB016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclThreadTest.c;
- path = ../generic/tclThreadTest.c;
- refType = 2;
- };
- F5F24FCC016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclTimer.c;
- path = ../generic/tclTimer.c;
- refType = 2;
- };
- F5F24FCD016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclUniData.c;
- path = ../generic/tclUniData.c;
- refType = 2;
- };
- F5F24FCE016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclUtf.c;
- path = ../generic/tclUtf.c;
- refType = 2;
- };
- F5F24FCF016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclUtil.c;
- path = ../generic/tclUtil.c;
- refType = 2;
- };
- F5F24FD0016ECAFC01DC9062 = {
- isa = PBXFileReference;
- name = tclVar.c;
- path = ../generic/tclVar.c;
- refType = 2;
- };
- F5F24FD1016ECB1E01DC9062 = {
- isa = PBXFileReference;
- name = regex.h;
- path = ../generic/regex.h;
- refType = 2;
- };
- F5F24FD2016ECB1E01DC9062 = {
- isa = PBXFileReference;
- name = tclPort.h;
- path = ../generic/tclPort.h;
- refType = 2;
- };
- F5F24FD3016ECB4901DC9062 = {
- isa = PBXFileReference;
- name = tclPkg.c;
- path = ../generic/tclPkg.c;
- refType = 2;
- };
- F5F24FD6016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixPort.h;
- path = ../unix/tclUnixPort.h;
- refType = 2;
- };
- F5F24FD7016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixThrd.h;
- path = ../unix/tclUnixThrd.h;
- refType = 2;
- };
- F5F24FD8016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclAppInit.c;
- path = ../unix/tclAppInit.c;
- refType = 2;
- };
- F5F24FD9016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclLoadDyld.c;
- path = ../unix/tclLoadDyld.c;
- refType = 2;
- };
- F5F24FDB016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixChan.c;
- path = ../unix/tclUnixChan.c;
- refType = 2;
- };
- F5F24FDC016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixEvent.c;
- path = ../unix/tclUnixEvent.c;
- refType = 2;
- };
- F5F24FDD016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixFCmd.c;
- path = ../unix/tclUnixFCmd.c;
- refType = 2;
- };
- F5F24FDE016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixFile.c;
- path = ../unix/tclUnixFile.c;
- refType = 2;
- };
- F5F24FDF016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixInit.c;
- path = ../unix/tclUnixInit.c;
- refType = 2;
- };
- F5F24FE0016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixNotfy.c;
- path = ../unix/tclUnixNotfy.c;
- refType = 2;
- };
- F5F24FE1016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixPipe.c;
- path = ../unix/tclUnixPipe.c;
- refType = 2;
- };
- F5F24FE2016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixSock.c;
- path = ../unix/tclUnixSock.c;
- refType = 2;
- };
- F5F24FE3016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixTest.c;
- path = ../unix/tclUnixTest.c;
- refType = 2;
- };
- F5F24FE4016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixThrd.c;
- path = ../unix/tclUnixThrd.c;
- refType = 2;
- };
- F5F24FE5016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclUnixTime.c;
- path = ../unix/tclUnixTime.c;
- refType = 2;
- };
- F5F24FE6016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclXtNotify.c;
- path = ../unix/tclXtNotify.c;
- refType = 2;
- };
- F5F24FE7016ECC0F01DC9062 = {
- isa = PBXFileReference;
- name = tclXtTest.c;
- path = ../unix/tclXtTest.c;
- refType = 2;
- };
- F5F24FEE016ED0DF01DC9062 = {
- children = (
- F5F24FEF016ED0DF01DC9062,
- F5F24FF0016ED0DF01DC9062,
- F5F24FF3016ED0DF01DC9062,
- F5F24FF4016ED0DF01DC9062,
- F5F24FF5016ED0DF01DC9062,
- F5F24FF6016ED0DF01DC9062,
- F5F24FFA016ED0DF01DC9062,
- F5F24FFB016ED0DF01DC9062,
- F5F24FFC016ED0DF01DC9062,
- F5F24FFE016ED0DF01DC9062,
- F5F25001016ED0DF01DC9062,
- F5F25002016ED0DF01DC9062,
- F5F25003016ED0DF01DC9062,
- F5F25005016ED0DF01DC9062,
- F5F25007016ED0DF01DC9062,
- F5F25008016ED0DF01DC9062,
- F5F2500A016ED0DF01DC9062,
- );
- isa = PBXGroup;
- name = Scripts;
- refType = 4;
- };
- F5F24FEF016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = auto.tcl;
- path = ../library/auto.tcl;
- refType = 2;
- };
- F5F24FF0016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = dde;
- path = ../library/dde;
- refType = 2;
- };
- F5F24FF3016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = encoding;
- path = ../library/encoding;
- refType = 2;
- };
- F5F24FF4016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = history.tcl;
- path = ../library/history.tcl;
- refType = 2;
- };
- F5F24FF5016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = http;
- path = ../library/http;
- refType = 2;
- };
- F5F24FF6016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = http1.0;
- path = ../library/http1.0;
- refType = 2;
- };
- F5F24FFA016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = init.tcl;
- path = ../library/init.tcl;
- refType = 2;
- };
- F5F24FFB016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = ldAout.tcl;
- path = ../library/ldAout.tcl;
- refType = 2;
- };
- F5F24FFC016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = msgcat;
- path = ../library/msgcat;
- refType = 2;
- };
- F5F24FFE016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = opt;
- path = ../library/opt;
- refType = 2;
- };
- F5F25001016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = package.tcl;
- path = ../library/package.tcl;
- refType = 2;
- };
- F5F25002016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = parray.tcl;
- path = ../library/parray.tcl;
- refType = 2;
- };
- F5F25003016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = reg;
- path = ../library/reg;
- refType = 2;
- };
- F5F25005016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = safe.tcl;
- path = ../library/safe.tcl;
- refType = 2;
- };
- F5F25007016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = tclIndex;
- path = ../library/tclIndex;
- refType = 2;
- };
- F5F25008016ED0DF01DC9062 = {
- includeInIndex = 0;
- isa = PBXFolderReference;
- name = tcltest;
- path = ../library/tcltest;
- refType = 2;
- };
- F5F2500A016ED0DF01DC9062 = {
- isa = PBXFileReference;
- name = word.tcl;
- path = ../library/word.tcl;
- refType = 2;
- };
- };
- rootObject = 00E2F845016E82EB0ACA28DC;
-}
* software in accordance with the terms specified in this
* license.
*/
-
- #include <CoreFoundation/CoreFoundation.h>
- #include "tcl.h"
+
+#include <CoreFoundation/CoreFoundation.h>
+#include "tcl.h"
/*
*----------------------------------------------------------------------
*
* Tcl_MacOSXOpenBundleResources --
*
- * Given the bundle name for a shared library, this routine
- * sets libraryPath to the Resources/Scripts directory
- * in the framework package. If hasResourceFile is
- * true, it will also open the main resource file for the bundle.
+ * Given the bundle name for a shared library, this routine sets
+ * libraryPath to the Resources/Scripts directory in the framework
+ * package. If hasResourceFile is true, it will also open the main
+ * resource file for the bundle.
*
*
* Results:
*/
int
-Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
- CONST char *bundleName,
- int hasResourceFile,
- int maxPathLen,
- char *libraryPath)
+Tcl_MacOSXOpenBundleResources(
+ Tcl_Interp *interp,
+ CONST char *bundleName,
+ int hasResourceFile,
+ int maxPathLen,
+ char *libraryPath)
{
CFBundleRef bundleRef;
CFStringRef bundleNameRef;
-
+
libraryPath[0] = '\0';
-
- bundleNameRef = CFStringCreateWithCString(NULL,
- bundleName, kCFStringEncodingUTF8);
-
+
+ bundleNameRef = CFStringCreateWithCString(NULL,
+ bundleName, kCFStringEncodingUTF8);
+
bundleRef = CFBundleGetBundleWithIdentifier(bundleNameRef);
CFRelease(bundleNameRef);
-
+
if (bundleRef == 0) {
- return TCL_ERROR;
+ return TCL_ERROR;
} else {
- CFURLRef libURL;
-
- if (hasResourceFile) {
- short refNum;
- refNum = CFBundleOpenBundleResourceMap(bundleRef);
- }
-
- libURL = CFBundleCopyResourceURL(bundleRef,
- CFSTR("Scripts"),
- NULL,
- NULL);
+ CFURLRef libURL;
- if (libURL != NULL) {
- /*
- * FIXME: This is a quick fix, it is probably not right
- * for internationalization.
- */
-
- if (CFURLGetFileSystemRepresentation (libURL, true,
- libraryPath, maxPathLen)) {
- }
- CFRelease(libURL);
- } else {
- return TCL_ERROR;
- }
+ if (hasResourceFile) {
+ short refNum;
+ refNum = CFBundleOpenBundleResourceMap(bundleRef);
+ }
+
+ libURL = CFBundleCopyResourceURL(bundleRef,
+ CFSTR("Scripts"), NULL, NULL);
+
+ if (libURL != NULL) {
+ /*
+ * FIXME: This is a quick fix, it is probably not right
+ * for internationalization.
+ */
+
+ if (CFURLGetFileSystemRepresentation(libURL, true,
+ libraryPath, maxPathLen)) {
+ }
+ CFRelease(libURL);
+ } else {
+ return TCL_ERROR;
+ }
}
-
+
return TCL_OK;
}
-
You can run the tests in three ways:
- (a) type "make test" in ../unix; this will run all of the tests.
+ (a) type "make test" in ../unix; this will create the tcltest
+ executable and run all of the tests. At least "make tcltest"
+ must be run to create the tcltest executable for the other
+ options.
(b) type "tcltest <testFile> ?<option> <value>?
- Command line options include:
-
- -help display usage information
-
- -verbose <level> set the level of verbosity to a substring
- of "bps". See the "Test output" section
- of the tcltest man page for an
- explanation of this option.
-
- -match <matchList> only run tests that match one or more of
- the glob patterns in <matchList>
-
- -skip <skipList> do not run tests that match one or more
- of the glob patterns in <skipList>
-
- -file <globPatternList>
- only source test files that match one or
- more of the glob patterns in
- <globPatternList> (relative to the
- "tests" directory). This option only
- applies when you run the test suite with
- the "all.tcl" file.
-
- -notfile <globPatternList>
- do not source test files that match one
- or more of the patterns in
- <globPatternList> (relative to the
- "tests" directory). This option only
- applies when you run the test suite with
- the "all.tcl" file.
-
- -constraints <list> tests with any constraints in <list> will
- not be skipped. Not that elements of
- <list> must exactly match the existing
- constraints.
-
- -limitconstraints <bool>
- If 1, limit test runs to those tests that
- match the constraints listed using the
- -constraints flag. Use of this flag
- requires use of the -constraints flag.
- The default value is 0.
-
- -tmpdir <dirname> put temporary files created by
- ::tcltest::makeFile and
- ::tcltest::makeDirectory in the named
- directory. The default location is
- ::tcltest::workingDirectory.
-
- -preservecore <level>
- check for core files. If level is 0,
- check for core files only when
- cleanupTests is called from an all.tcl
- file. If 1, also check at the end of
- every test command. If 2, also save core
- files in ::tcltest::temporaryDirectory.
- The default level is 0.
+
+ where the options and values are the configuration options
+ of the tcltest package.
(c) start up tcltest in this directory, then "source" the test
file (for example, type "source parse.test"). To run all
of the tests, type "source all.tcl". To use the options in
- interactive mode, you can set their corresponding tcltest
- namespace variables after loading the tcltest package.
- For example, some of the tcltest variables are:
- ::tcltest::match
- ::tcltest::skip
- ::tcltest::testConstraints(nonPortable)
- ::tcltest::testConstraints(knownBug)
- ::tcltest::testConstraints(userInteractive)
+ interactive mode, you can set them with the tcltest::configure
+ command. Set constraints with the tcltest::testConstraints
+ command.
Please see the tcltest man page for more information regarding how to
write and run tests.
Be sure your new test file can be run from any working directory.
Be sure no temporary files are left behind by your test file.
+Use [tcltest::makeFile], [tcltest::removeFile], and [tcltest::cleanupTests]
+properly to be sure of this.
Be sure your tests can run cross-platform in both a build environment
as well as an installation environment. If your test file contains
tests that should not be run in one or more of those cases, please use
the constraints mechanism to skip those tests.
-2. Incompatibilities with prior Tcl versions:
----------------------------------------------
-
-1) Global variables such as VERBOSE, TESTS, and testConfig are now
- renamed to use the new "tcltest" namespace.
+2. Incompatibilities of package tcltest 2.1 with
+ testing machinery of very old versions of Tcl:
+------------------------------------------------
- old name new name
- -------- --------
- VERBOSE ::tcltest::verbose
- TESTS ::tcltest::match
- testConfig ::tcltest::testConstraints
+1) Global variables such as VERBOSE, TESTS, and testConfig of the
+ old machinery correspond to the [configure -verbose],
+ [configure -match], and [testConstraint] commands of tcltest 2.1,
+ respectively.
-2) VERBOSE values are no longer numeric.
+2) VERBOSE values were longer numeric. [configure -verbose] values
+ are lists of keywords.
3) When you run "make test", the working dir for the test suite is now
the one from which you called "make test", rather than the "tests"
other or with existing files. All tests must now run independently
of their working directory.
-4) The "all" and "visual" files are now called "all.tcl" and
- "visual_bb.test".
+4) The "all" file is now called "all.tcl"
-5) The "defs" file no longer exists.
+5) The "defs" and "defs.tcl" files no longer exist.
6) Instead of creating a doAllTests file in the tests directory, to
run all nonPortable tests, just use the "-constraints nonPortable"
- command line flag. If you are running interactively, you can set
- the ::tcltest::testConstraints(nonPortable) variable to 1 (after
- loading the tcltest package).
+ command line flag. If you are running interactively, you can run
+ [tcltest::testConstraint nonPortable 1] (after loading the tcltest
+ package).
+++ /dev/null
-# This file contains a top-level script to run all of the Tcl
-# tests. Execute it by invoking "source all" when running tclTest
-# in this directory.
-#
-# RCS: @(#) $Id$
-
-if {$tcl_platform(os) == "Win32s"} {
- set files [glob *.tes]
-} else {
- set files [glob *.test]
-}
-
-foreach i [lsort $files] {
- if [string match l.*.test $i] {
- # This is an SCCS lockfile
- continue
- }
- puts stdout $i
- if [catch {source $i} msg] {
- puts $msg
- }
-}
# tests. Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
-# Copyright (c) 1998-2000 Ajuba Solutions.
-# All rights reserved.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2000 by Ajuba Solutions
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
-
-set ::tcltest::testSingleFile false
-set ::tcltest::testsDirectory [file dir [info script]]
-
-# We need to ensure that the testsDirectory is absolute
-::tcltest::normalizePath ::tcltest::testsDirectory
-
-puts stdout "Tcl $tcl_patchLevel tests running in interp: [info nameofexecutable]"
-puts stdout "Tests running in working dir: $::tcltest::testsDirectory"
-if {[llength $::tcltest::skip] > 0} {
- puts stdout "Skipping tests that match: $::tcltest::skip"
-}
-if {[llength $::tcltest::match] > 0} {
- puts stdout "Only running tests that match: $::tcltest::match"
-}
+set tcltestVersion [package require tcltest]
+namespace import -force tcltest::*
-if {[llength $::tcltest::skipFiles] > 0} {
- puts stdout "Skipping test files that match: $::tcltest::skipFiles"
-}
-if {[llength $::tcltest::matchFiles] > 0} {
- puts stdout "Only sourcing test files that match: $::tcltest::matchFiles"
+if {$tcl_platform(platform) == "macintosh"} {
+ tcltest::singleProcess 1
}
-set timeCmd {clock format [clock seconds]}
-puts stdout "Tests began at [eval $timeCmd]"
-
-# source each of the specified tests
-foreach file [lsort [::tcltest::getMatchingFiles]] {
- set tail [file tail $file]
- puts stdout $tail
- if {[catch {source $file} msg]} {
- puts stdout $msg
- }
-}
+tcltest::testsDirectory [file dir [info script]]
+tcltest::runAllTests
-# cleanup
-puts stdout "\nTests ended at [eval $timeCmd]"
-::tcltest::cleanupTests 1
return
-
-
catch {unset x}
lappend x
} {}
+test append-4.18 {lappend command} {
+ catch {unset x}
+ lappend x {}
+} {{}}
+test append-4.19 {lappend command} {
+ catch {unset x}
+ lappend x(0)
+} {}
+test append-4.20 {lappend command} {
+ catch {unset x}
+ lappend x(0) abc
+} {abc}
proc check {var size} {
set l [llength $var]
return ok
}
test append-5.1 {long lappends} {
+ catch {unset x}
set x ""
for {set i 0} {$i < 300} {set i [expr $i+1]} {
lappend x "item $i"
lappend x 1
list [info exists x] [catch {set x} msg] $msg
} {0 1 {can't read "x": no such variable}}
+test append-7.2 {lappend var triggers read trace} {
+ catch {unset myvar}
+ catch {unset ::result}
+ trace variable myvar r foo
+ proc foo {args} {append ::result $args}
+ lappend myvar a
+ list [catch {set ::result} msg] $msg
+} {0 {myvar {} r}}
+test append-7.3 {lappend var triggers read trace, array var} {
+ # The behavior of read triggers on lappend changed in 8.0 to
+ # not trigger them, and was changed back in 8.4.
+ catch {unset myvar}
+ catch {unset ::result}
+ trace variable myvar r foo
+ proc foo {args} {append ::result $args}
+ lappend myvar(b) a
+ list [catch {set ::result} msg] $msg
+} {0 {myvar b r}}
+test append-7.4 {lappend var triggers read trace, array var exists} {
+ catch {unset myvar}
+ catch {unset ::result}
+ set myvar(0) 1
+ trace variable myvar r foo
+ proc foo {args} {append ::result $args}
+ lappend myvar(b) a
+ list [catch {set ::result} msg] $msg
+} {0 {myvar b r}}
+test append-7.5 {append var does not trigger read trace} {
+ catch {unset myvar}
+ catch {unset ::result}
+ trace variable myvar r foo
+ proc foo {args} {append ::result $args}
+ append myvar a
+ info exists ::result
+} {0}
+
catch {unset i x result y}
catch {rename foo ""}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
+++ /dev/null
-# Test file for:
-# auto_mkindex
-#
-# This file provides example cases for testing the Tcl autoloading
-# facility. Things are much more complicated with namespaces and classes.
-# The "auto_mkindex" facility can no longer be built on top of a simple
-# regular expression parser. It must recognize constructs like this:
-#
-# namespace eval foo {
-# proc test {x y} { ... }
-# namespace eval bar {
-# proc another {args} { ... }
-# }
-# }
-#
-# Note that procedures and itcl class definitions can be nested inside
-# of namespaces.
-#
-# Copyright (c) 1993-1998 Lucent Technologies, Inc.
-
-# This shouldn't cause any problems
-namespace import -force blt::*
-
-# Should be able to handle "proc" definitions, even if they are
-# preceded by white space.
-
-proc normal {x y} {return [expr $x+$y]}
- proc indented {x y} {return [expr $x+$y]}
-
-#
-# Should be able to handle proc declarations within namespaces,
-# even if they have explicit namespace paths.
-#
-namespace eval buried {
- proc inside {args} {return "inside: $args"}
-
- namespace export pub_*
- proc pub_one {args} {return "one: $args"}
- proc pub_two {args} {return "two: $args"}
-}
-proc buried::within {args} {return "within: $args"}
-
-namespace eval buried {
- namespace eval under {
- proc neath {args} {return "neath: $args"}
- }
- namespace eval ::buried {
- proc relative {args} {return "relative: $args"}
- proc ::top {args} {return "top: $args"}
- proc ::buried::explicit {args} {return "explicit: $args"}
- }
-}
-
-# With proper hooks, we should be able to support other commands
-# that create procedures
-
-proc buried::myproc {name body args} {
- ::proc $name $body $args
-}
-namespace eval ::buried {
- proc mycmd1 args {return "mycmd"}
- myproc mycmd2 args {return "mycmd"}
-}
-::buried::myproc mycmd3 args {return "another"}
-
-proc {buried::my proc} {name body args} {
- ::proc $name $body $args
-}
-namespace eval ::buried {
- proc mycmd4 args {return "mycmd"}
- {my proc} mycmd5 args {return "mycmd"}
-}
-{::buried::my proc} mycmd6 args {return "another"}
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
-# temporarily copy the autoMkindex.tcl file from testsDirectory to
-# temporaryDirectory
-set origMkindexFile [file join $::tcltest::testsDirectory autoMkindex.tcl]
-set newMkindexFile [file join $::tcltest::temporaryDirectory autoMkindex.tcl]
-if {![catch {file copy $origMkindexFile $newMkindexFile}]} {
- set removeAutoMkindex 1
+makeFile {# Test file for:
+# auto_mkindex
+#
+# This file provides example cases for testing the Tcl autoloading
+# facility. Things are much more complicated with namespaces and classes.
+# The "auto_mkindex" facility can no longer be built on top of a simple
+# regular expression parser. It must recognize constructs like this:
+#
+# namespace eval foo {
+# proc test {x y} { ... }
+# namespace eval bar {
+# proc another {args} { ... }
+# }
+# }
+#
+# Note that procedures and itcl class definitions can be nested inside
+# of namespaces.
+#
+# Copyright (c) 1993-1998 Lucent Technologies, Inc.
+
+# This shouldn't cause any problems
+namespace import -force blt::*
+
+# Should be able to handle "proc" definitions, even if they are
+# preceded by white space.
+
+proc normal {x y} {return [expr $x+$y]}
+ proc indented {x y} {return [expr $x+$y]}
+
+#
+# Should be able to handle proc declarations within namespaces,
+# even if they have explicit namespace paths.
+#
+namespace eval buried {
+ proc inside {args} {return "inside: $args"}
+
+ namespace export pub_*
+ proc pub_one {args} {return "one: $args"}
+ proc pub_two {args} {return "two: $args"}
}
+proc buried::within {args} {return "within: $args"}
+
+namespace eval buried {
+ namespace eval under {
+ proc neath {args} {return "neath: $args"}
+ }
+ namespace eval ::buried {
+ proc relative {args} {return "relative: $args"}
+ proc ::top {args} {return "top: $args"}
+ proc ::buried::explicit {args} {return "explicit: $args"}
+ }
+}
+
+# With proper hooks, we should be able to support other commands
+# that create procedures
+
+proc buried::myproc {name body args} {
+ ::proc $name $body $args
+}
+namespace eval ::buried {
+ proc mycmd1 args {return "mycmd"}
+ myproc mycmd2 args {return "mycmd"}
+}
+::buried::myproc mycmd3 args {return "another"}
+
+proc {buried::my proc} {name body args} {
+ ::proc $name $body $args
+}
+namespace eval ::buried {
+ proc mycmd4 args {return "mycmd"}
+ {my proc} mycmd5 args {return "mycmd"}
+}
+{::buried::my proc} mycmd6 args {return "another"}
+
+# A correctly functioning [auto_import] won't choke when a child
+# namespace [namespace import]s from its parent.
+#
+namespace eval ::parent::child {
+ namespace import ::parent::*
+}
+proc ::parent::child::test {} {}
+
+} autoMkindex.tcl
+
# Save initial state of auto_mkindex_parser
auto_load auto_mkindex
-if {[info exist auto_mkindex_parser::initCommands]} {
+if {[info exists auto_mkindex_parser::initCommands]} {
set saveCommands $auto_mkindex_parser::initCommands
}
proc AutoMkindexTestReset {} {
global saveCommands
- if {[info exist saveCommands]} {
+ if {[info exists saveCommands]} {
set auto_mkindex_parser::initCommands $saveCommands
- } elseif {[info exist auto_mkindex_parser::initCommands]} {
+ } elseif {[info exists auto_mkindex_parser::initCommands]} {
unset auto_mkindex_parser::initCommands
}
}
set result ""
set origDir [pwd]
-cd $::tcltest::testsDirectory
+cd $::tcltest::temporaryDirectory
test autoMkindex-1.1 {remove any existing tclIndex file} {
file delete tclIndex
}
namespace delete tcl_autoMkindex_tmp
set ::result
-} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {indented $element} {normal $element} {top $element}"
+} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}"
test autoMkindex-2.1 {commands on the autoload path can be imported} {
AutoMkindexTestReset
set ::result
-} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}"
+} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}"
test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} {
list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*]
} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"
+
+makeDirectory pkg
+makeFile {
+package provide football 1.0
+
+namespace eval ::pro:: {
+ #
+ # export only public functions.
+ #
+ namespace export {[a-z]*}
+}
+namespace eval ::college:: {
+ #
+ # export only public functions.
+ #
+ namespace export {[a-z]*}
+}
+
+proc ::pro::team {} {
+ puts "go packers!"
+ return true
+}
+
+proc ::college::team {} {
+ puts "go badgers!"
+ return true
+}
+
+} [file join pkg samename.tcl]
+
+
test autoMkindex-4.1 {platform indenpendant source commands} {
file delete tclIndex
auto_mkindex . pkg/samename.tcl
set result
} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}
+removeFile [file join pkg samename.tcl]
+
+makeFile {
+set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
+set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo"
+set bracket1 "this contains an unescaped bracket [NoSuchProc]"
+set bracket2 "this contains an escaped bracket \[NoSuchProc\]"
+set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]"
+proc testProc {} {}
+} [file join pkg magicchar.tcl]
+
test autoMkindex-5.1 {escape magic tcl chars in general code} {
file delete tclIndex
set result {}
}
set result
} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}
+
+removeFile [file join pkg magicchar.tcl]
+
+makeFile {
+proc {[magic mojo proc]} {} {}
+} [file join pkg magicchar2.tcl]
+
test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
file delete tclIndex
set res {}
set res
} 0
+removeFile [file join pkg magicchar2.tcl]
+removeDirectory pkg
+
# Clean up.
unset result
AutoMkindexTestReset
-if {[info exist saveCommands]} {
+if {[info exists saveCommands]} {
unset saveCommands
}
rename AutoMkindexTestReset ""
-if {[info exists removeAutoMkindex]} {
- catch {file delete $newMkindexFile}
-}
+removeFile autoMkindex.tcl
if {[file exists tclIndex]} {
file delete -force tclIndex
}
cd $origDir
::tcltest::cleanupTests
-
# RCS: @(#) $Id$
#
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
+
+testConstraint testcmdtoken [llength [info commands testcmdtoken]]
+testConstraint testcmdtrace [llength [info commands testcmdtrace]]
+testConstraint testcreatecommand [llength [info commands testcreatecommand]]
+testConstraint exec [llength [info commands exec]]
+
+# This variable needs to be changed when the major or minor version number for
+# Tcl changes.
+set tclvers 8.4
catch {namespace delete test_ns_basic}
catch {interp delete test_interp}
[p]
} {42 {} {} Hello {} {} 42}
-if {[info commands testcreatecommand] == ""} {
- puts "This application hasn't been compiled with the testcreatecommand"
- puts "command. Skipping affected tests."
-} else {
-test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {
+test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [testcreatecommand create] \
[test_ns_basic::createdcommand] \
[testcreatecommand delete]
} {{} {CreatedCommandProc in ::test_ns_basic} {}}
-test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {
+test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename value:at: ""}
list [testcreatecommand create2] \
[value:at:] \
[testcreatecommand delete2]
} {{} {CreatedCommandProc2 in ::} {}}
-}
test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
catch {eval namespace delete [namespace children :: test_ns_*]}
test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
} {}
-if {[info commands testcmdtoken] == {}} {
- puts "This application hasn't been compiled with the \"testcmdtoken\""
- puts "command, so I can't test Tcl_GetCommandInfo."
-} else {
-test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {
+test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
[rename ::p q] \
[testcmdtoken name $x]
} {{p ::p} {} {q ::q}}
-test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {
+test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
catch {rename q ""}
set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
list [testcmdtoken name $x] \
[rename test_ns_basic::test_ns_basic2::p q] \
[testcmdtoken name $x]
} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
-}
test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}
# message.
proc bgerror {args} {set ::x $::errorInfo}
- set f [open test1 w]
+ set fName [makeFile {} test1]
+ set f [open $fName w]
fileevent $f writable "fileevent $f writable {}; error foo"
set x {}
vwait x
close $f
- file delete test1
+ removeFile test1
rename bgerror {}
set x
} "foo\n while executing\n\"error foo\""
test basic-38.1 {Tcl_ExprObj} {emptyTest} {
} {}
-if {[info commands testcmdtrace] == {}} {
- puts "This application hasn't been compiled with the \"testcmdtrace\""
- puts "command, so I can't test Tcl_CreateTrace."
-} else {
-test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [expr 14 + 16]}
} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
-test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [info tclversion]}
-} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $::tcltest::version"]
-test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $tclvers"]
+test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace deletetest {set stuff [info tclversion]}
-} $::tcltest::version
-}
+} $tclvers
+test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} {
+ # Note that the proc call is the same as the variable name, and that
+ # the call can be direct or indirect by way of another procedure
+ proc tracer {args} {}
+ proc tracedLoop {level} {
+ incr level
+ tracer
+ foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}
+ }
+ testcmdtrace tracetest {tracedLoop 0}
+} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}}
+catch {rename tracer {}}
+catch {rename tracedLoop {}}
+
+test basic-39.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} {
+ proc Error { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Error $x}} result] [set result]
+} {1 {Error $x}}
+
+test basic-39.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} {
+ proc Return { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Return $x}} result] [set result]
+} {2 {}}
+
+test basic-39.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} {
+ proc Break { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Break $x}} result] [set result]
+} {3 {}}
+
+test basic-39.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} {
+ proc Continue { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {Continue $x}} result] [set result]
+} {4 {}}
+
+test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
+ proc OtherStatus { args } { error "Shouldn't get here" }
+ set x 1;
+ list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
+} {6 {}}
test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
+ # the above tests have tested Tcl_DeleteTrace
} {}
test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}
-test basic-46.1 {Tcl_AllowExceptions} {emptyTest} {
-} {}
+test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
+ catch {close $f}
+ set res [catch {
+ set f [open |[list [interpreter]] w+]
+ fconfigure $f -buffering line
+ puts $f {fconfigure stdout -buffering line}
+ puts $f continue
+ puts $f {puts $errorInfo}
+ puts $f {puts DONE}
+ set newMsg {}
+ set msg {}
+ while {$newMsg != "DONE"} {
+ set newMsg [gets $f]
+ append msg "${newMsg}\n"
+ }
+ close $f
+ } error]
+ list $res $msg
+} {1 {invoked "continue" outside of a loop
+ while executing
+"continue
+"
+DONE
+}}
+
+test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} {
+ set fName [makeFile {
+ puts hello
+ break
+ } BREAKtest]
+ set res [list [catch {exec [interpreter] $fName} msg] $msg]
+ removeFile BREAKtest
+ regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
+ set res
+} {1 {hello
+invoked "break" outside of a loop
+ while executing
+"break"
+ (file "BREAKtest" line 3)}}
+
+test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {exec} {
+ set fName [makeFile {
+ interp alias {} patch {} info patchlevel
+ patch
+ break
+ } BREAKtest]
+ set res [list [catch {exec [interpreter] $fName} msg] $msg]
+ removeFile BREAKtest
+ regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
+ set res
+} {1 {invoked "break" outside of a loop
+ while executing
+"break"
+ (file "BREAKtest" line 4)}}
+
+test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {exec} {
+ set fName [makeFile {
+ foo [set a 1] [break]
+ } BREAKtest]
+ set res [list [catch {exec [interpreter] $fName} msg] $msg]
+ removeFile BREAKtest
+ regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
+ set res
+} {1 {invoked "break" outside of a loop
+ while executing
+"break"
+ invoked from within
+"foo [set a 1] [break]"
+ (file "BREAKtest" line 2)}}
+
+test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} {
+ set fName [makeFile {
+ return -code return
+ } BREAKtest]
+ set res [list [catch {exec [interpreter] $fName} msg] $msg]
+ removeFile BREAKtest
+ regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
+ set res
+} {1 {command returned bad code: 2
+ while executing
+"return -code return"
+ (file "BREAKtest" line 2)}}
+
# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {unset x}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
namespace import -force ::tcltest::*
}
-test binary-2.1 {DupByteArrayInternalRep} {
+test binary-0.1 {DupByteArrayInternalRep} {
set hdr [binary format cc 0 0316]
set buf hellomatt
} {}
-
test binary-2.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format a } msg] $msg
} {1 {not enough arguments for all format specifiers}}
} {1 abc}
test binary-20.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
- list [binary scan abc a5 arg1] [info exist arg1]
+ list [binary scan abc a5 arg1] [info exists arg1]
} {0 0}
test binary-20.6 {Tcl_BinaryObjCmd: scan} {
set arg1 foo
} {1 abc}
test binary-21.5 {Tcl_BinaryObjCmd: scan} {
catch {unset arg1}
- list [binary scan abc A5 arg1] [info exist arg1]
+ list [binary scan abc A5 arg1] [info exists arg1]
} {0 0}
test binary-21.6 {Tcl_BinaryObjCmd: scan} {
set arg1 foo
set result
} {bad option "": must be format or scan}
+# Wide int (guaranteed at least 64-bit) handling
+test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} {
+ binary format w 7810179016327718216
+} HelloTcl
+test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
+ binary format W 7810179016327718216
+} lcTolleH
+
+test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
+ binary scan HelloTcl W x
+ set x
+} 5216694956358656876
+test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
+ binary scan lcTolleH w x
+ set x
+} 5216694956358656876
+
+test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
+ binary scan [binary format sws 16450 -1 19521] c* x
+ set x
+} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
+test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
+ binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
+ set x
+} {66 64 0 0 0 0 127 -1 -1 -1 65 76}
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
#
# RCS: @(#) $Id$
+set env(LC_TIME) POSIX
+
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
test clock-2.3 {clock clicks tests} {
list [catch {clock clicks foo} msg] $msg
} {1 {bad switch "foo": must be -milliseconds}}
-test clock-2.3 {clock clicks tests} {
+test clock-2.4 {clock clicks tests} {
expr [clock clicks -milliseconds]+1
concat {}
} {}
-test clock-2.2 {clock clicks tests, millisecond timing test} {
+test clock-2.5 {clock clicks tests, millisecond timing test} {
set start [clock clicks -milli]
after 10
set end [clock clicks -milli]
- # assume, even with slow interp'ing, the diff is less than 60 msecs
- expr {($end > $start) && (($end - $start) < 60)}
+ # 60 msecs seems to be the max time slice under Windows 95/98
+ expr {($end > $start) && (($end - $start) <= 60)}
} {1}
# clock format
test clock-3.12 {clock format tests} {
clock format 123 -format ""
} ""
+test clock-3.13 {clock format with non-ASCII character in the format string} {
+ set oldenc [encoding system]
+ encoding system iso8859-1
+ set res [clock format 0 -format \u00c4]
+ encoding system $oldenc
+ unset oldenc
+ set res
+} "\u00c4"
# clock scan
test clock-4.1 {clock scan tests} {
-format %m.%Y
} "05.2001"
+# We use 5am PST, 31-12-1999 as the base for these scans because irrespective
+# of your local timezone it should always give us times on December 31
+set 5amPST 946645200
+test clock-8.1 {clock scan midnight/gmt range bug 413397} {
+ set fmt "%m/%d"
+ list [clock format [clock scan year -base $5amPST -gmt 0] -format $fmt] \
+ [clock format [clock scan year -base $5amPST -gmt 1] -format $fmt]
+} {12/31 12/31}
+
+set ::tcltest::testConstraints(needPST) [expr {
+ [regexp {^(Pacific.*|P[DS]T)$} [clock format 1 -format %Z]]
+ && ([clock format 1 -format %s] != "%s")
+}]
+test clock-9.1 {%s gmt testing} {needPST} {
+ # We need PST to guarantee the difference value below, and %s isn't
+ # valid on all OSes (like Solaris).
+ set s 100000
+ set a [clock format $s -format %s -gmt 0]
+ set b [clock format $s -format %s -gmt 1]
+ # This should be the offset in seconds between current locale and GMT.
+ # This didn't seem to be correctly on Windows until the fix for
+ # Bug #559376, which fiddled with env(TZ) when -gmt 1 was used.
+ # It's hard-coded to check P[SD]T now. (8 hours)
+ set c [expr {$b-$a}]
+} {28800}
+
# cleanup
::tcltest::cleanupTests
return
-
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2.1
namespace import -force ::tcltest::*
}
+tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]
+
global env
set cmdAHwd [pwd]
catch {set platform [testgetplatform]}
test cmdAH-2.1 {Tcl_CdObjCmd} {
list [catch {cd foo bar} msg] $msg
} {1 {wrong # args: should be "cd ?dirName?"}}
+set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} {
- file delete -force foo
- file mkdir foo
- cd foo
+ file delete -force $foodir
+ file mkdir $foodir
+ cd $foodir
set result [file tail [pwd]]
cd ..
- file delete foo
+ file delete $foodir
set result
} foo
test cmdAH-2.3 {Tcl_CdObjCmd} {
set oldpwd [pwd]
set temp $env(HOME)
set env(HOME) $oldpwd
- file delete -force foo
- file mkdir foo
- cd foo
+ file delete -force $foodir
+ file mkdir $foodir
+ cd $foodir
cd ~
- set result [string match [pwd] $oldpwd]
- file delete foo
+ set result [string equal [pwd] $oldpwd]
+ file delete $foodir
set env(HOME) $temp
set result
} 1
set oldpwd [pwd]
set temp $env(HOME)
set env(HOME) $oldpwd
- file delete -force foo
- file mkdir foo
- cd foo
+ file delete -force $foodir
+ file mkdir $foodir
+ cd $foodir
cd
- set result [string match [pwd] $oldpwd]
- file delete foo
+ set result [string equal [pwd] $oldpwd]
+ file delete $foodir
set env(HOME) $temp
set result
} 1
} {1 {wrong # args: should be "file option ?arg ...?"}}
test cmdAH-5.2 {Tcl_FileObjCmd} {
list [catch {file x} msg] $msg
-} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-5.3 {Tcl_FileObjCmd} {
list [catch {file exists} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
-
+test cmdAH-5.4 {Tcl_FileObjCmd} {
+ list [catch {file exists ""} msg] $msg
+} {0 0}
#volume
list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}]
} {0 1 0}
+test cmdAH-6.5 {cd} {unixOnly nonPortable} {
+ set dir [pwd]
+ cd /
+ set res [pwd]
+ cd $dir
+ set res
+} {/}
+
# attributes
test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} {
- catch {file delete -force foo.file}
- close [open foo.file w]
- list [catch {file attributes foo.file}] [file delete -force foo.file]
-} {0 {}}
+ set foofile [makeFile abcde foo.file]
+ catch {file delete -force $foofile}
+ close [open $foofile w]
+ set res [catch {file attributes $foofile}]
+ # We used [makeFile] so we undo with [removeFile]
+ removeFile $foofile
+ set res
+} {0}
# dirname
# readable
+set gorpfile [makeFile abcde gorp.file]
+set dirfile [makeDirectory dir.file]
+
if {[info commands testchmod] == {}} {
puts "This application hasn't been compiled with the \"testchmod\""
puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
-makeFile abcde gorp.file
-makeDirectory dir.file
-
-test cmdAH-16.1 {Tcl_FileObjCmd: readable} {
+test cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} {
list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
-testchmod 444 gorp.file
-test cmdAH-16.2 {Tcl_FileObjCmd: readable} {
- file readable gorp.file
+testchmod 0444 $gorpfile
+test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} {
+ file readable $gorpfile
} 1
-testchmod 333 gorp.file
-test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot} {
- file reada gorp.file
+testchmod 0333 $gorpfile
+test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} {
+ file reada $gorpfile
} 0
# writable
-test cmdAH-17.1 {Tcl_FileObjCmd: writable} {
+test cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} {
list [catch {file writable a b} msg] $msg
} {1 {wrong # args: should be "file writable name"}}
-testchmod 555 gorp.file
-test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot} {
- file writable gorp.file
+testchmod 0555 $gorpfile
+test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} {
+ file writable $gorpfile
} 0
-testchmod 222 gorp.file
-test cmdAH-17.3 {Tcl_FileObjCmd: writable} {
- file writable gorp.file
+testchmod 0222 $gorpfile
+test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} {
+ file writable $gorpfile
} 1
+}
# executable
-file delete -force dir.file gorp.file
-file mkdir dir.file
-makeFile abcde gorp.file
+removeFile $gorpfile
+removeDirectory $dirfile
+set dirfile [makeDirectory dir.file]
+set gorpfile [makeFile abcde gorp.file]
-test cmdAH-18.1 {Tcl_FileObjCmd: executable} {
+test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} {
list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
-test cmdAH-18.2 {Tcl_FileObjCmd: executable} {
- file executable gorp.file
+test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod} {
+ file executable $gorpfile
} 0
-test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly} {
+test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} {
# Only on unix will setting the execute bit on a regular file
# cause that file to be executable.
- testchmod 775 gorp.file
- file exe gorp.file
+ testchmod 0775 $gorpfile
+ file exe $gorpfile
} 1
-test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly} {
+test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} {
# On mac, the only executable files are of type APPL.
- set x [file exe gorp.file]
- file attrib gorp.file -type APPL
- lappend x [file exe gorp.file]
+ set x [file exe $gorpfile]
+ file attrib $gorpfile -type APPL
+ lappend x [file exe $gorpfile]
} {0 1}
-test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly} {
+test cmdAH-18.5 {Tcl_FileObjCmd: executable} {pcOnly testchmod} {
# On pc, must be a .exe, .com, etc.
- set x [file exe gorp.file]
- makeFile foo gorp.exe
- lappend x [file exe gorp.exe]
- file delete gorp.exe
+ set x [file exe $gorpfile]
+ set gorpexe [makeFile foo gorp.exe]
+ lappend x [file exe $gorpexe]
+ removeFile $gorpexe
set x
} {0 1}
-test cmdAH-18.6 {Tcl_FileObjCmd: executable} {
+test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} {
# Directories are always executable.
- file exe dir.file
+ file exe $dirfile
} 1
-file delete -force dir.file
-file delete gorp.file
-file delete link.file
-}
+removeDirectory $dirfile
+removeFile $gorpfile
+set linkfile [file join [temporaryDirectory] link.file]
+file delete $linkfile
# exists
test cmdAH-19.1 {Tcl_FileObjCmd: exists} {
list [catch {file exists a b} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
-test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists gorp.file} 0
+test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists $gorpfile} 0
test cmdAH-19.3 {Tcl_FileObjCmd: exists} {
- file exists [file join dir.file gorp.file]
+ file exists [file join [temporaryDirectory] dir.file gorp.file]
} 0
catch {
- makeFile abcde gorp.file
- makeDirectory dir.file
- makeFile 12345 [file join dir.file gorp.file]
+ set gorpfile [makeFile abcde gorp.file]
+ set dirfile [makeDirectory dir.file]
+ set subgorp [makeFile 12345 [file join $dirfile gorp.file]]
}
test cmdAH-19.4 {Tcl_FileObjCmd: exists} {
- file exists gorp.file
+ file exists $gorpfile
} 1
test cmdAH-19.5 {Tcl_FileObjCmd: exists} {
- file exists [file join dir.file gorp.file]
+ file exists $subgorp
} 1
# nativename
# NFS file systems won't do the stuff below correctly.
test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} {
- removeFile /tmp/tcl.foo.dir/file
- removeDirectory /tmp/tcl.foo.dir
+ file delete -force /tmp/tcl.foo.dir/file
+ file delete -force /tmp/tcl.foo.dir
makeDirectory /tmp/tcl.foo.dir
makeFile 12345 /tmp/tcl.foo.dir/file
- exec chmod 000 /tmp/tcl.foo.dir
+ file attributes /tmp/tcl.foo.dir -permissions 0000
set result [file exists /tmp/tcl.foo.dir/file]
- exec chmod 775 /tmp/tcl.foo.dir
+ file attributes /tmp/tcl.foo.dir -permissions 0775
removeFile /tmp/tcl.foo.dir/file
removeDirectory /tmp/tcl.foo.dir
set result
# Stat related commands
catch {testsetplatform $platform}
-file delete gorp.file
-makeFile "Test string" gorp.file
-catch {exec chmod 765 gorp.file}
+removeFile $gorpfile
+set gorpfile [makeFile "Test string" gorp.file]
+catch {file attributes $gorpfile -permissions 0765}
# atime
} {1 {wrong # args: should be "file atime name ?time?"}}
test cmdAH-20.2 {Tcl_FileObjCmd: atime} {
catch {unset stat}
- file stat gorp.file stat
- list [expr {[file mtime gorp.file] == $stat(mtime)}] \
- [expr {[file atime gorp.file] == $stat(atime)}]
+ file stat $gorpfile stat
+ list [expr {[file mtime $gorpfile] == $stat(mtime)}] \
+ [expr {[file atime $gorpfile] == $stat(atime)}]
} {1 1}
test cmdAH-20.3 {Tcl_FileObjCmd: atime} {
string tolower [list [catch {file atime _bogus_} msg] \
test cmdAH-20.4 {Tcl_FileObjCmd: atime} {
list [catch {file atime $file notint} msg] $msg
} {1 {expected integer but got "notint"}}
-test cmdAH-20.5 {Tcl_FileObjCmd: atime touch} {
+test cmdAH-20.5 {Tcl_FileObjCmd: atime touch} {unixOrPc} {
if {[string equal $tcl_platform(platform) "windows"]} {
set old [pwd]
cd $::tcltest::temporaryDirectory
set atime [file atime $file]
after 1100; # pause a sec to notice change in atime
set newatime [clock seconds]
- expr {$newatime==[file atime $file $newatime]}
+ set modatime [file atime $file $newatime]
+ expr {$newatime == $modatime ? 1 : "$newatime != $modatime"}
} 1
+removeFile touch.me
# isdirectory
test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} {
list [catch {file isdirectory a b} msg] $msg
} {1 {wrong # args: should be "file isdirectory name"}}
test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} {
- file isdirectory gorp.file
+ file isdirectory $gorpfile
} 0
test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} {
- file isd dir.file
+ file isd $dirfile
} 1
# isfile
test cmdAH-22.1 {Tcl_FileObjCmd: isfile} {
list [catch {file isfile a b} msg] $msg
} {1 {wrong # args: should be "file isfile name"}}
-test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile gorp.file} 1
-test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile dir.file} 0
+test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile $gorpfile} 1
+test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0
# lstat and readlink: don't run these tests everywhere, since not all
# sites will have symbolic links
-catch {exec ln -s gorp.file link.file}
+catch {file link -symbolic $linkfile $gorpfile}
test cmdAH-23.1 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
catch {unset stat}
- file lstat link.file stat
+ file lstat $linkfile stat
lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
catch {unset stat}
- file lstat link.file stat
+ file lstat $linkfile stat
list $stat(nlink) [expr $stat(mode)&0777] $stat(type)
} {1 511 link}
test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} {
test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} {
catch {unset x}
set x 44
- list [catch {file lstat gorp.file x} msg] $msg $errorCode
+ list [catch {file lstat $gorpfile x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
catch {unset stat}
+# mkdir
+
+set dirA [file join [temporaryDirectory] a]
+set dirB [file join [temporaryDirectory] a]
+test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} {
+ catch {file delete -force $dirA}
+ file mkdir $dirA
+ set res [file isdirectory $dirA]
+ file delete $dirA
+ set res
+} {1}
+test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} {
+ catch {file delete -force $dirA}
+ file mkdir $dirA/b
+ set res [file isdirectory $dirA/b]
+ file delete -force $dirA
+ set res
+} {1}
+test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} {
+ catch {file delete -force $dirA}
+ file mkdir $dirA/b/c
+ set res [file isdirectory $dirA/b/c]
+ file delete -force $dirA
+ set res
+} {1}
+test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} {
+ catch {file delete -force $dirA}
+ catch {file delete -force $dirB}
+ file mkdir $dirA/b $dirB/a/c
+ set res [list [file isdirectory $dirA/b] [file isdirectory $dirB/a/c]]
+ file delete -force $dirA
+ file delete -force $dirB
+ set res
+} {1 1}
+
# mtime
set file [makeFile "data" touch.me]
test cmdAH-24.1 {Tcl_FileObjCmd: mtime} {
list [catch {file mtime a b c} msg] $msg
} {1 {wrong # args: should be "file mtime name ?time?"}}
+# Check (allowing for clock-skew and OS interrupts as best we can)
+# that the change in mtime on a file being written is the time elapsed
+# between writes. Note that this can still fail on very busy systems
+# if there are long preemptions between the writes and the reading of
+# the clock, but there's not much you can do about that other than the
+# completely horrible "keep on trying to write until you managed to do
+# it all in less than a second." - DKF
test cmdAH-24.2 {Tcl_FileObjCmd: mtime} {
- set old [file mtime gorp.file]
+ set f [open $gorpfile w]
+ puts $f "More text"
+ set localOld [clock seconds]
+ close $f
+ set old [file mtime $gorpfile]
after 2000
- set f [open gorp.file w]
+ set f [open $gorpfile w]
puts $f "More text"
+ set localNew [clock seconds]
close $f
- set new [file mtime gorp.file]
- expr {($new > $old) && ($new <= ($old+5))}
+ set new [file mtime $gorpfile]
+ expr {
+ ($new > $old) && ($localNew > $localOld) &&
+ (abs(($new-$old) - ($localNew-$localOld)) <= 1)
+ }
} {1}
test cmdAH-24.3 {Tcl_FileObjCmd: mtime} {
catch {unset stat}
- file stat gorp.file stat
- list [expr {[file mtime gorp.file] == $stat(mtime)}] \
- [expr {[file atime gorp.file] == $stat(atime)}]
+ file stat $gorpfile stat
+ list [expr {[file mtime $gorpfile] == $stat(mtime)}] \
+ [expr {[file atime $gorpfile] == $stat(atime)}]
} {1 1}
test cmdAH-24.4 {Tcl_FileObjCmd: mtime} {
string tolower [list [catch {file mtime _bogus_} msg] $msg \
# On other platforms, just use a file in the local directory.
if {[string equal $tcl_platform(platform) "unix"]} {
- set name /tmp/tcl.test
+ set name /tmp/tcl.test.[pid]
} else {
- set name tf
+ set name [file join [temporaryDirectory] tf]
}
# Make sure that a new file's time is correct. 10 seconds variance
set mtime [file mtime $file]
after 1100; # pause a sec to notice change in mtime
set newmtime [clock seconds]
- expr {$newmtime==[file mtime $file $newmtime]}
+ set modmtime [file mtime $file $newmtime]
+ expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
-
+removeFile touch.me
# owned
list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} {
- file owned gorp.file
+ file owned $gorpfile
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {
file owned /
list [catch {file readlink a b} msg] $msg
} {1 {wrong # args: should be "file readlink name"}}
test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} {
- file readlink link.file
-} gorp.file
+ file readlink $linkfile
+} $gorpfile
test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
- set oldsize [file size gorp.file]
- set f [open gorp.file a]
+ set oldsize [file size $gorpfile]
+ set f [open $gorpfile a]
fconfigure $f -translation lf -eofchar {}
puts $f "More text"
close $f
- expr {[file size gorp.file] - $oldsize}
+ expr {[file size $gorpfile] - $oldsize}
} {10}
test cmdAH-27.3 {Tcl_FileObjCmd: size} {
string tolower [list [catch {file size _bogus_} msg] $msg \
# stat
catch {testsetplatform $platform}
-makeFile "Test string" gorp.file
-catch {exec chmod 765 gorp.file}
+removeFile $gorpfile
+set gorpfile [makeFile "Test string" gorp.file]
+catch {file attributes $gorpfile -permissions 0765}
test cmdAH-28.1 {Tcl_FileObjCmd: stat} {
list [catch {file stat _bogus_} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.3 {Tcl_FileObjCmd: stat} {
catch {unset stat}
- file stat gorp.file stat
+ file stat $gorpfile stat
lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} {
catch {unset stat}
- file stat gorp.file stat
+ file stat $gorpfile stat
list $stat(nlink) $stat(size) $stat(type)
} {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {
catch {unset stat}
- file stat gorp.file stat
+ file stat $gorpfile stat
expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
test cmdAH-28.7 {Tcl_FileObjCmd: stat} {
catch {unset x}
set x 44
- list [catch {file stat gorp.file x} msg] $msg $errorCode
+ list [catch {file stat $gorpfile x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
test cmdAH-28.8 {Tcl_FileObjCmd: stat} {
# Sign extension of purported unsigned short to int.
- close [open foo.test w]
- file stat foo.test stat
+ set filename [makeFile "" foo.text]
+ file stat $filename stat
set x [expr {$stat(mode) > 0}]
- file delete foo.test
+ removeFile $filename
set x
} 1
test cmdAH-28.9 {Tcl_FileObjCmd: stat} {pcOnly} {
# stat(mode) with S_IFREG flag was returned as a negative number
# if mode_t was a short instead of an unsigned short.
- close [open foo.test w]
- file stat foo.test stat
- file delete foo.test
+ set filename [makeFile "" foo.test]
+ file stat $filename stat
+ removeFile $filename
expr {$stat(mode) > 0}
} 1
catch {unset stat}
# type
-file delete link.file
-
test cmdAH-29.1 {Tcl_FileObjCmd: type} {
list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-29.2 {Tcl_FileObjCmd: type} {
- file type dir.file
+ file type $dirfile
} directory
+test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {unixOnly nonPortable} {
+ set exists [list [file exists $linkfile] [file exists $gorpfile]]
+ file delete $linkfile
+ set exists2 [list [file exists $linkfile] [file exists $gorpfile]]
+ list $exists $exists2
+} {{1 1} {0 1}}
test cmdAH-29.3 {Tcl_FileObjCmd: type} {
- file type gorp.file
+ file type $gorpfile
} file
-test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly nonPortable} {
- exec ln -s a/b/c link.file
- set result [file type link.file]
- file delete link.file
+test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly} {
+ catch {file delete $linkfile}
+ # Unlike [exec ln -s], [file link] requires an existing target
+ file link -symbolic $linkfile $gorpfile
+ set result [file type $linkfile]
+ file delete $linkfile
+ set result
+} link
+if {[string equal $tcl_platform(platform) "windows"]} {
+ if {[string index $tcl_platform(osVersion) 0] >= 5 \
+ && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
+ tcltest::testConstraint linkDirectory 1
+ } else {
+ tcltest::testConstraint linkDirectory 0
+ }
+} else {
+ tcltest::testConstraint linkDirectory 1
+}
+test cmdAH-29.4.1 {Tcl_FileObjCmd: type} {linkDirectory} {
+ set tempdir [makeDirectory temp]
+ set linkdir [file join [temporaryDirectory] link.dir]
+ file link -symbolic $linkdir $tempdir
+ set result [file type $linkdir]
+ file delete $linkdir
+ removeDirectory $tempdir
set result
} link
test cmdAH-29.5 {Tcl_FileObjCmd: type} {
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
list [catch {file gorp x} msg] $msg
-} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
list [catch {file ex x} msg] $msg
-} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
list [catch {file is x} msg] $msg
-} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
list [catch {file z x} msg] $msg
-} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
list [catch {file read x} msg] $msg
-} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
list [catch {file s x} msg] $msg
-} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
list [catch {file t x} msg] $msg
-} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, lstat, mtime, mkdir, nativename, owned, pathtype, readable, readlink, rename, rootname, size, split, stat, tail, type, volumes, or writable}}
+} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
list [catch {file dirname ~woohgy} msg] $msg
} {1 {user "woohgy" doesn't exist}}
# channels
+# In testing 'file channels', we need to make sure that a channel
+# created in one interp isn't visible in another.
+
+interp create simpleInterp
+interp create -safe safeInterp
+interp c
+safeInterp expose file file
test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} {
list [catch {file channels a b} msg] $msg
} {1 {wrong # args: should be "file channels ?pattern?"}}
test cmdAH-31.2 {Tcl_FileObjCmd: channels, too many args} {
- file chan
-} {stderr stdout stdin}
-test cmdAH-31.3 {Tcl_FileObjCmd: channels, too many args} {
+ # Normal interps start out with only the standard channels
+ lsort [simpleInterp eval [list file chan]]
+} [lsort {stderr stdout stdin}]
+test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {
string equal [file channels] [file channels *]
} {1}
-test cmdAH-31.4 {Tcl_FileObjCmd: channels} {
- set old [file channels gorp.file]
- set f [open gorp.file w]
- set new [file channels file*]
- close $f
- string equal $f $new
+test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {
+ lsort [file channels std*]
+} [lsort {stdout stderr stdin}]
+
+set newFileId [open $gorpfile w]
+
+test cmdAH-31.5 {Tcl_FileObjCmd: channels} {
+ set res [file channels $newFileId]
+ string equal $newFileId $res
} {1}
+test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} {
+ # Safe interps start out with no channels
+ safeInterp eval [list file channels]
+} {}
+test cmdAH-31.7 {Tcl_FileObjCmd: channels in other interp} {
+ list [catch {safeInterp eval [list puts $newFileId "hello"]} msg] $msg
+} [list 1 "can not find channel named \"$newFileId\""]
+
+interp share {} $newFileId safeInterp
+interp share {} stdout safeInterp
+
+test cmdAH-31.8 {Tcl_FileObjCmd: channels in other interp} {
+ # $newFileId should now be visible in both interps
+ list [file channels $newFileId] \
+ [safeInterp eval [list file channels $newFileId]]
+} [list $newFileId $newFileId]
+test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} {
+ lsort [safeInterp eval [list file channels]]
+} [lsort [list stdout $newFileId]]
+test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} {
+ # we can now write to $newFileId from slave
+ safeInterp eval [list puts $newFileId "hello"]
+} {}
+
+interp transfer {} $newFileId safeInterp
+
+test cmdAH-31.11 {Tcl_FileObjCmd: channels in other interp} {
+ # $newFileId should now be visible only in safeInterp
+ list [file channels $newFileId] \
+ [safeInterp eval [list file channels $newFileId]]
+} [list {} $newFileId]
+test cmdAH-31.12 {Tcl_FileObjCmd: channels in other interp} {
+ lsort [safeInterp eval [list file channels]]
+} [lsort [list stdout $newFileId]]
+test cmdAH-31.13 {Tcl_FileObjCmd: channels in other interp} {
+ safeInterp eval [list close $newFileId]
+ safeInterp eval [list file channels]
+} {stdout}
+
+# This shouldn't work, but just in case a test above failed...
+catch {close $newFileId}
+
+interp delete safeInterp
+interp delete simpleInterp
# cleanup
catch {testsetplatform $platform}
# Tcl_ForObjCmd is tested in for.test
-catch {exec chmod 777 dir.file}
-file delete -force dir.file
-file delete gorp.file
-file delete link.file
+catch {file attributes $dirfile -permissions 0777}
+removeDirectory $dirfile
+removeFile $gorpfile
+# No idea how well [removeFile] copes with links...
+file delete $linkfile
cd $cmdAHwd
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
# lsort -unique should return the last unique item
lsort -unique -index 0 {{a b} {c b} {a c} {d a}}
} {{a c} {c b} {d a}}
+test cmdIL-1.24 {Tcl_LsortObjCmd procedure, order of -index and -command} {
+ catch {rename 1 ""}
+ proc testcmp {a b} {return [string compare $a $b]}
+ set l [list [list a b] [list c d]]
+ set result [list [catch {lsort -command testcmp -index 1 $l} msg] $msg]
+ rename testcmp ""
+ set result
+} [list 0 [list [list a b] [list c d]]]
+test cmdIL-1.25 {Tcl_LsortObjCmd procedure, order of -index and -command} {
+ catch {rename 1 ""}
+ proc testcmp {a b} {return [string compare $a $b]}
+ set l [list [list a b] [list c d]]
+ set result [list [catch {lsort -index 1 -command testcmp $l} msg] $msg]
+ rename testcmp ""
+ set result
+} [list 0 [list [list a b] [list c d]]]
+# Note that the required order only exists in the end-1'th element;
+# indexing using the end element or any fixed offset from the start
+# will not work...
+test cmdIL-1.26 {Tcl_LsortObjCmd procedure, offset indexing from end} {
+ lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
+} {{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}}
# Can't think of any good tests for the MergeSort and MergeLists
# procedures, except a bunch of random lists to sort.
# cleanup
::tcltest::cleanupTests
return
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
-if {[info commands testcmdinfo] == {}} {
- puts "This application hasn't been compiled with the \"testcmdinfo\""
- puts "command, so I can't test Tcl_GetCommandInfo etc."
- ::tcltest::cleanupTests
- return
-}
+::tcltest::testConstraint testcmdinfo \
+ [llength [info commands testcmdinfo]]
+::tcltest::testConstraint testcmdtoken \
+ [llength [info commands testcmdtoken]]
-test cmdinfo-1.1 {command procedure and clientData} {
+test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
-test cmdinfo-1.2 {command procedure and clientData} {
+test cmdinfo-1.2 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
x1
} {CmdProc1 original}
-test cmdinfo-1.3 {command procedure and clientData} {
+test cmdinfo-1.3 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo modify x1
testcmdinfo get x1
} {CmdProc2 new_command_data CmdDelProc2 new_delete_data :: stringProc}
-test cmdinfo-1.4 {command procedure and clientData} {
+test cmdinfo-1.4 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo modify x1
x1
} {CmdProc2 new_command_data}
-test cmdinfo-2.1 {command deletion callbacks} {
+test cmdinfo-2.1 {command deletion callbacks} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo delete x1
} {CmdDelProc1 original}
-test cmdinfo-2.2 {command deletion callbacks} {
+test cmdinfo-2.2 {command deletion callbacks} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo modify x1
testcmdinfo delete x1
} {CmdDelProc2 new_delete_data}
-test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} {
+test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} {testcmdinfo} {
testcmdinfo get non_existent
} {??}
-test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} {
+test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo modify x1
} 1
-test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} {
+test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} {testcmdinfo} {
testcmdinfo modify non_existent
} 0
-test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} {
+test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} \
+ {testcmdtoken} {
set x [testcmdtoken create x1]
rename x1 newName
set y [testcmdtoken name $x]
catch {rename newTestCmd {}}
catch {rename newTestCmd2 {}}
-test cmdinfo-5.1 {Names for commands created when inside namespaces} {
+test cmdinfo-5.1 {Names for commands created when inside namespaces} \
+ {testcmdtoken} {
# create namespace cmdInfoNs1
namespace eval cmdInfoNs1 {} ;# creates namespace cmdInfoNs1
# create namespace cmdInfoNs1::cmdInfoNs2 and execute a script in it
eval lappend y [testcmdtoken name $x]
} {testCmd ::testCmd newTestCmd ::newTestCmd}
-test cmdinfo-6.1 {Names for commands created when outside namespaces} {
+test cmdinfo-6.1 {Names for commands created when outside namespaces} \
+ {testcmdtoken} {
set x [testcmdtoken create cmdInfoNs1::cmdInfoNs2::testCmd]
set y [testcmdtoken name $x]
rename cmdInfoNs1::cmdInfoNs2::testCmd newTestCmd2
catch {rename x1 ""}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
package require tcltest
namespace import -force ::tcltest::*
}
+set tcltest::testConstraints(nonLinuxOnly) \
+ [expr {![string equal Linux $tcl_platform(os)]}]
# Tcl_PwdObjCmd
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
expr [string length pwd]>0
} 1
-test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly} {
- file delete -force foo
- file mkdir foo
+test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly nonLinuxOnly} {
+ # We don't want this test to run on Linux because they do a
+ # permissions caching trick which causes this to fail. The
+ # caching is incorrect, but we have no control over that.
+ set foodir [file join [temporaryDirectory] foo]
+ file delete -force $foodir
+ file mkdir $foodir
set cwd [pwd]
- cd foo
+ cd $foodir
file attr . -permissions 000
set result [list [catch {pwd} msg] $msg]
cd $cwd
- file delete -force foo
+ file delete -force $foodir
set result
} {1 {error getting working directory name: permission denied}}
} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.2 {Tcl_SourceObjCmd: error conditions} {macOnly} {
list [catch {source a b} msg] $msg
-} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
+} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source a b} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
-test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} {
- makeFile {
+test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
+ set file [makeFile {
set x 146
error "error in sourced file"
set y $x
- } source.file
- list [catch {source source.file} msg] $msg $errorInfo
-} {1 {error in sourced file} {error in sourced file
+ } source.file]
+ set result [list [catch {source $file} msg] $msg $errorInfo]
+ removeFile source.file
+ set result
+} -match glob -result {1 {error in sourced file} {error in sourced file
while executing
"error "error in sourced file""
- (file "source.file" line 3)
+ (file "*" line 3)
invoked from within
-"source source.file"}}
+"source $file"}}
test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} {
- makeFile {list result} source.file
- source source.file
+ set file [makeFile {list result} source.file]
+ set result [source $file]
+ removeFile source.file
+ set result
} result
# Tcl_SplitObjCmd
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
-# There are no tests for Tcl_TimeObjCmd
+
+test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} {
+ list [catch {time} msg] $msg
+} {1 {wrong # args: should be "time command ?count?"}}
+test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} {
+ list [catch {time a b c} msg] $msg
+} {1 {wrong # args: should be "time command ?count?"}}
+test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} {
+ list [catch {time a b} msg] $msg
+} {1 {expected integer but got "b"}}
+test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
+ time bogusCmd -12456
+} {0 microseconds per iteration}
+test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} {
+ regexp {^\d+ microseconds per iteration} [time {format 1}]
+} 1
+test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
+ expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
+} 1
+test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
+ list [catch {time {error foo}} msg] $msg $::errorInfo
+} {1 foo {foo
+ while executing
+"error foo"
+ invoked from within
+"time {error foo}"}}
+
# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test
# cleanup
::tcltest::cleanupTests
return
-
#
# This file contains the original set of tests for the compilation (and
# indirectly execution) of Tcl's expr command. A new set of tests covering
-# the new implementation are in the files "parseExpr.test and
+# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
catch {unset a b i x}
-test expr-1.1 {TclCompileExprCmd: no expression} {
+test compExpr-old-1.1 {TclCompileExprCmd: no expression} {
list [catch {expr } msg] $msg
} {1 {wrong # args: should be "expr arg ?arg ...?"}}
-test expr-1.2 {TclCompileExprCmd: one expression word} {
+test compExpr-old-1.2 {TclCompileExprCmd: one expression word} {
expr -25
} -25
-test expr-1.3 {TclCompileExprCmd: two expression words} {
+test compExpr-old-1.3 {TclCompileExprCmd: two expression words} {
expr -8.2 -6
} -14.2
-test expr-1.4 {TclCompileExprCmd: five expression words} {
+test compExpr-old-1.4 {TclCompileExprCmd: five expression words} {
expr 20 - 5 +10 -7
} 18
-test expr-1.5 {TclCompileExprCmd: quoted expression word} {
+test compExpr-old-1.5 {TclCompileExprCmd: quoted expression word} {
expr "0005"
} 5
-test expr-1.6 {TclCompileExprCmd: quoted expression word} {
+test compExpr-old-1.6 {TclCompileExprCmd: quoted expression word} {
catch {expr "0005"zxy} msg
set msg
} {extra characters after close-quote}
-test expr-1.7 {TclCompileExprCmd: expression word in braces} {
+test compExpr-old-1.7 {TclCompileExprCmd: expression word in braces} {
expr {-0005}
} -5
-test expr-1.8 {TclCompileExprCmd: expression word in braces} {
+test compExpr-old-1.8 {TclCompileExprCmd: expression word in braces} {
expr {{-0x1234}}
} -4660
-test expr-1.9 {TclCompileExprCmd: expression word in braces} {
+test compExpr-old-1.9 {TclCompileExprCmd: expression word in braces} {
catch {expr {-0005}foo} msg
set msg
} {extra characters after close-brace}
-test expr-1.10 {TclCompileExprCmd: other expression word in braces} {
+test compExpr-old-1.10 {TclCompileExprCmd: other expression word in braces} {
expr 4*[llength "6 2"]
} 8
-test expr-1.11 {TclCompileExprCmd: expression word terminated by ;} {
+test compExpr-old-1.11 {TclCompileExprCmd: expression word terminated by ;} {
expr 4*[llength "6 2"];
} 8
-test expr-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} {
+test compExpr-old-1.12 {TclCompileExprCmd: inlined expr (in "catch") inside other catch} {
set a xxx
catch {
# Might not be a number
set a [expr 10*$a]
}
} 1
-test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} {
+test compExpr-old-1.13 {TclCompileExprCmd: second level of substitutions in expr not in braces with single var reference} {
set a xxx
set x 27; set bool {$x}; if $bool {set a foo}
set a
} foo
-test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
+test compExpr-old-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
set a xxx
set x 2; set b {$x}; set a [expr $b == 2]
set a
} 1
-test expr-2.1 {TclCompileExpr: are builtin functions registered?} {
+test compExpr-old-2.1 {TclCompileExpr: are builtin functions registered?} {
expr double(5*[llength "6 2"])
} 10.0
-test expr-2.2 {TclCompileExpr: error in expr} {
+test compExpr-old-2.2 {TclCompileExpr: error in expr} {
catch {expr 2**3} msg
set msg
-} {syntax error in expression "2**3"}
-test expr-2.3 {TclCompileExpr: junk after legal expr} {
+} {syntax error in expression "2**3": unexpected operator *}
+test compExpr-old-2.3 {TclCompileExpr: junk after legal expr} {
catch {expr 7*[llength "a b"]foo} msg
set msg
-} {syntax error in expression "7*2foo"}
-test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
+} {syntax error in expression "7*2foo": extra tokens at end of expression}
+test compExpr-old-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
expr {0001}
} 1
-test expr-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
-test expr-3.2 {CompileCondExpr: error in lor expr} {
+test compExpr-old-3.1 {CompileCondExpr: just lor expr} {expr 3||0} 1
+test compExpr-old-3.2 {CompileCondExpr: error in lor expr} {
catch {expr x||3} msg
set msg
-} {syntax error in expression "x||3"}
-test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
-test expr-3.4 {CompileCondExpr: error compiling true arm} {
+} {syntax error in expression "x||3": variable references require preceding $}
+test compExpr-old-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
+test compExpr-old-3.4 {CompileCondExpr: error compiling true arm} {
catch {expr 3>2?2**3:66} msg
set msg
-} {syntax error in expression "3>2?2**3:66"}
-test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
-test expr-3.6 {CompileCondExpr: error compiling false arm} {
+} {syntax error in expression "3>2?2**3:66": unexpected operator *}
+test compExpr-old-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
+test compExpr-old-3.6 {CompileCondExpr: error compiling false arm} {
catch {expr 2>3?44:2**3} msg
set msg
-} {syntax error in expression "2>3?44:2**3"}
-test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} {
- puts "Note: doing test expr-3.7 which can take several minutes to run"
+} {syntax error in expression "2>3?44:2**3": unexpected operator *}
+test compExpr-old-3.7 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} {
+ puts "Note: doing test compExpr-old-3.7 which can take several minutes to run"
hello_world
} {Hello world}
catch {unset xxx}
-test expr-3.8 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} {
- puts "Note: doing test expr-3.8 which can take several minutes to run"
+test compExpr-old-3.8 {CompileCondExpr: long arms & nested cond exprs} {nonPortable} {
+ puts "Note: doing test compExpr-old-3.8 which can take several minutes to run"
do_twelve_days
} 2358
catch {unset xxx}
-test expr-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
-test expr-4.2 {CompileLorExpr: error in land expr} {
+test compExpr-old-4.1 {CompileLorExpr: just land expr} {expr 1.3&&3.3} 1
+test compExpr-old-4.2 {CompileLorExpr: error in land expr} {
catch {expr x&&3} msg
set msg
-} {syntax error in expression "x&&3"}
-test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
-test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
-test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
-test expr-4.6 {CompileLorExpr: error compiling lor arm} {
+} {syntax error in expression "x&&3": variable references require preceding $}
+test compExpr-old-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
+test compExpr-old-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
+test compExpr-old-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
+test compExpr-old-4.6 {CompileLorExpr: error compiling lor arm} {
catch {expr 2**3||4.0} msg
set msg
-} {syntax error in expression "2**3||4.0"}
-test expr-4.7 {CompileLorExpr: error compiling lor arm} {
+} {syntax error in expression "2**3||4.0": unexpected operator *}
+test compExpr-old-4.7 {CompileLorExpr: error compiling lor arm} {
catch {expr 1.3||2**3} msg
set msg
-} {syntax error in expression "1.3||2**3"}
-test expr-4.8 {CompileLorExpr: error compiling lor arms} {
+} {syntax error in expression "1.3||2**3": unexpected operator *}
+test compExpr-old-4.8 {CompileLorExpr: error compiling lor arms} {
list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
-test expr-4.9 {CompileLorExpr: long lor arm} {
+test compExpr-old-4.9 {CompileLorExpr: long lor arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
-test expr-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
-test expr-5.2 {CompileLandExpr: error in bitor expr} {
+test compExpr-old-5.1 {CompileLandExpr: just bitor expr} {expr 7|0x13} 23
+test compExpr-old-5.2 {CompileLandExpr: error in bitor expr} {
catch {expr x|3} msg
set msg
-} {syntax error in expression "x|3"}
-test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
-test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
-test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
-test expr-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
-test expr-5.7 {CompileLandExpr: error compiling land arm} {
+} {syntax error in expression "x|3": variable references require preceding $}
+test compExpr-old-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
+test compExpr-old-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
+test compExpr-old-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
+test compExpr-old-5.6 {CompileLandExpr: simple land exprs} {expr 1&&1&&2} 1
+test compExpr-old-5.7 {CompileLandExpr: error compiling land arm} {
catch {expr 2**3&&4.0} msg
set msg
-} {syntax error in expression "2**3&&4.0"}
-test expr-5.8 {CompileLandExpr: error compiling land arm} {
+} {syntax error in expression "2**3&&4.0": unexpected operator *}
+test compExpr-old-5.8 {CompileLandExpr: error compiling land arm} {
catch {expr 1.3&&2**3} msg
set msg
-} {syntax error in expression "1.3&&2**3"}
-test expr-5.9 {CompileLandExpr: error compiling land arm} {
+} {syntax error in expression "1.3&&2**3": unexpected operator *}
+test compExpr-old-5.9 {CompileLandExpr: error compiling land arm} {
list [catch {expr {"a"&&"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
-test expr-5.10 {CompileLandExpr: long land arms} {
+test compExpr-old-5.10 {CompileLandExpr: long land arms} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]] && [string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]^[string compare [format %c 103] [string index $a $i]]^[string compare [format %c 105] [string index $a $i]]}
} 1
-test expr-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
-test expr-6.2 {CompileBitXorExpr: error in bitand expr} {
+test compExpr-old-6.1 {CompileBitXorExpr: just bitand expr} {expr 7&0x13} 3
+test compExpr-old-6.2 {CompileBitXorExpr: error in bitand expr} {
catch {expr x|3} msg
set msg
-} {syntax error in expression "x|3"}
-test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
-test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
-test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
-test expr-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
-test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
+} {syntax error in expression "x|3": variable references require preceding $}
+test compExpr-old-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
+test compExpr-old-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
+test compExpr-old-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
+test compExpr-old-6.6 {CompileBitXorExpr: simple bitxor exprs} {expr -1^7} -8
+test compExpr-old-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2**3|6} msg
set msg
-} {syntax error in expression "2**3|6"}
-test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} {
+} {syntax error in expression "2**3|6": unexpected operator *}
+test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2^x} msg
set msg
-} {syntax error in expression "2^x"}
-test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
+} {syntax error in expression "2^x": variable references require preceding $}
+test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
-test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
+test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}
-test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
-test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
-test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
-test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
-test expr-7.5 {CompileBitAndExpr: error in equality expr} {
+test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
+test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
+test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
+test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
+test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} {
catch {expr x==3} msg
set msg
-} {syntax error in expression "x==3"}
-test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
-test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
-test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
-test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
-test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} {
+} {syntax error in expression "x==3": variable references require preceding $}
+test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
+test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
+test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
+test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
+test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2**3&6} msg
set msg
-} {syntax error in expression "2**3&6"}
-test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} {
+} {syntax error in expression "2**3&6": unexpected operator *}
+test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2&x} msg
set msg
-} {syntax error in expression "2&x"}
-test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
+} {syntax error in expression "2&x": variable references require preceding $}
+test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
-test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
+test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
-test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
-test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
-test expr-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
-test expr-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
-test expr-8.5 {CompileEqualityExpr: error in relational expr} {
+test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
+test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
+test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
+test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
+test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} {
catch {expr x>3} msg
set msg
-} {syntax error in expression "x>3"}
-test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
-test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
-test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
-test expr-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
-test expr-8.10 {CompileEqualityExpr: error compiling equality arm} {
+} {syntax error in expression "x>3": variable references require preceding $}
+test compExpr-old-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
+test compExpr-old-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
+test compExpr-old-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
+test compExpr-old-8.9 {CompileEqualityExpr: simple equality exprs} {expr -1!="abc"} 1
+test compExpr-old-8.10 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2**3==6} msg
set msg
-} {syntax error in expression "2**3==6"}
-test expr-8.11 {CompileEqualityExpr: error compiling equality arm} {
+} {syntax error in expression "2**3==6": unexpected operator *}
+test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2!=x} msg
set msg
-} {syntax error in expression "2!=x"}
+} {syntax error in expression "2!=x": variable references require preceding $}
-test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
-test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
-test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
-test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
+test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
+test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
+test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1
+test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8
# The following test is different for 32-bit versus 64-bit
# architectures because LONG_MIN is different
if {0x80000000 > 0} {
- test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
+ test compExpr-old-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
expr {1<<63}
} -9223372036854775808
} else {
- test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
+ test compExpr-old-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} {nonPortable} {
expr {1<<31}
} -2147483648
}
-test expr-9.6 {CompileRelationalExpr: error in shift expr} {
+test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} {
catch {expr x>>3} msg
set msg
-} {syntax error in expression "x>>3"}
-test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
-test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
-test expr-9.9 {CompileRelationalExpr: error compiling relational arm} {
+} {syntax error in expression "x>>3": variable references require preceding $}
+test compExpr-old-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
+test compExpr-old-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
+test compExpr-old-9.9 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2**3>6} msg
set msg
-} {syntax error in expression "2**3>6"}
-test expr-9.10 {CompileRelationalExpr: error compiling relational arm} {
+} {syntax error in expression "2**3>6": unexpected operator *}
+test compExpr-old-9.10 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2<x} msg
set msg
-} {syntax error in expression "2<x"}
+} {syntax error in expression "2<x": variable references require preceding $}
-test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
-test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
-test expr-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
-test expr-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82
-test expr-10.5 {CompileShiftExpr: error in add expr} {
+test compExpr-old-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
+test compExpr-old-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
+test compExpr-old-10.3 {CompileShiftExpr: just add expr} {expr -1--2} 1
+test compExpr-old-10.4 {CompileShiftExpr: just add expr} {expr 1-0123} -82
+test compExpr-old-10.5 {CompileShiftExpr: error in add expr} {
catch {expr x+3} msg
set msg
-} {syntax error in expression "x+3"}
-test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
-test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
-test expr-10.8 {CompileShiftExpr: error compiling shift arm} {
+} {syntax error in expression "x+3": variable references require preceding $}
+test compExpr-old-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
+test compExpr-old-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
+test compExpr-old-10.8 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2**3>>6} msg
set msg
-} {syntax error in expression "2**3>>6"}
-test expr-10.9 {CompileShiftExpr: error compiling shift arm} {
+} {syntax error in expression "2**3>>6": unexpected operator *}
+test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2<<x} msg
set msg
-} {syntax error in expression "2<<x"}
-test expr-10.10 {CompileShiftExpr: runtime error} {
+} {syntax error in expression "2<<x": variable references require preceding $}
+test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
-test expr-10.11 {CompileShiftExpr: runtime error} {
+test compExpr-old-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}
-test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
-test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
-test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
-test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6
-test expr-11.5 {CompileAddExpr: error in multiply expr} {
+test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
+test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
+test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
+test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0123} 6
+test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} {
catch {expr x*3} msg
set msg
-} {syntax error in expression "x*3"}
-test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
-test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
-test expr-11.8 {CompileAddExpr: error compiling add arm} {
+} {syntax error in expression "x*3": variable references require preceding $}
+test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
+test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
+test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} {
catch {expr 2**3+6} msg
set msg
-} {syntax error in expression "2**3+6"}
-test expr-11.9 {CompileAddExpr: error compiling add arm} {
+} {syntax error in expression "2**3+6": unexpected operator *}
+test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} {
catch {expr 2-x} msg
set msg
-} {syntax error in expression "2-x"}
-test expr-11.10 {CompileAddExpr: runtime error} {
+} {syntax error in expression "2-x": variable references require preceding $}
+test compExpr-old-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
-test expr-11.11 {CompileAddExpr: runtime error} {
+test compExpr-old-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
-test expr-11.12 {CompileAddExpr: runtime error} {
+test compExpr-old-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
-test expr-11.13 {CompileAddExpr: runtime error} {
+test compExpr-old-11.13 {CompileAddExpr: runtime error} {
list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}
-test expr-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
-test expr-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
-test expr-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
-test expr-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
-test expr-12.5 {CompileMultiplyExpr: error in unary expr} {
+test compExpr-old-12.1 {CompileMultiplyExpr: just unary expr} {expr ~4} -5
+test compExpr-old-12.2 {CompileMultiplyExpr: just unary expr} {expr --5} 5
+test compExpr-old-12.3 {CompileMultiplyExpr: just unary expr} {expr !27} 0
+test compExpr-old-12.4 {CompileMultiplyExpr: just unary expr} {expr ~0xff00ff} -16711936
+test compExpr-old-12.5 {CompileMultiplyExpr: error in unary expr} {
catch {expr ~x} msg
set msg
-} {syntax error in expression "~x"}
-test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
-test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
-test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
+} {syntax error in expression "~x": variable references require preceding $}
+test compExpr-old-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
+test compExpr-old-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
+test compExpr-old-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*3%%6} msg
set msg
-} {syntax error in expression "2*3%%6"}
-test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} {
+} {syntax error in expression "2*3%%6": unexpected operator %}
+test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*x} msg
set msg
-} {syntax error in expression "2*x"}
-test expr-12.10 {CompileMultiplyExpr: runtime error} {
+} {syntax error in expression "2*x": variable references require preceding $}
+test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
-test expr-12.11 {CompileMultiplyExpr: runtime error} {
+test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
-test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
-test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83
-test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
-test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
-test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
-test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
-test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
-test expr-13.8 {CompileUnaryExpr: error compiling unary expr} {
+test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
+test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +000123} 83
+test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
+test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
+test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
+test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
+test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
+test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} {
catch {expr ~x} msg
set msg
-} {syntax error in expression "~x"}
-test expr-13.9 {CompileUnaryExpr: error compiling unary expr} {
+} {syntax error in expression "~x": variable references require preceding $}
+test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} {
catch {expr !1.x} msg
set msg
-} {syntax error in expression "!1.x"}
-test expr-13.10 {CompileUnaryExpr: runtime error} {
+} {syntax error in expression "!1.x": extra tokens at end of expression}
+test compExpr-old-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
-test expr-13.11 {CompileUnaryExpr: runtime error} {
+test compExpr-old-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
} {1 {can't use floating-point value as operand of "~"}}
-test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
-test expr-13.13 {CompileUnaryExpr: just primary expr} {
+test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
+test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
expr $a
} 27
-test expr-13.14 {CompileUnaryExpr: just primary expr} {
+test compExpr-old-13.14 {CompileUnaryExpr: just primary expr} {
expr double(27)
} 27.0
-test expr-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123
-test expr-13.16 {CompileUnaryExpr: error in primary expr} {
+test compExpr-old-13.15 {CompileUnaryExpr: just primary expr} {expr "123"} 123
+test compExpr-old-13.16 {CompileUnaryExpr: error in primary expr} {
catch {expr [set]} msg
set msg
} {wrong # args: should be "set varName ?newValue?"}
-test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1
-test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123
-test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255
-test expr-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 8
-test expr-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0
-test expr-14.6 {CompilePrimaryExpr: literal primary} {
+test compExpr-old-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1
+test compExpr-old-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123
+test compExpr-old-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255
+test compExpr-old-14.4 {CompilePrimaryExpr: literal primary} {expr 00010} 8
+test compExpr-old-14.5 {CompilePrimaryExpr: literal primary} {expr 62.0} 62.0
+test compExpr-old-14.6 {CompilePrimaryExpr: literal primary} {
expr 3.1400000
} 3.14
-test expr-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1
-test expr-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\
+test compExpr-old-14.7 {CompilePrimaryExpr: literal primary} {expr {{abcde}<{abcdef}}} 1
+test compExpr-old-14.8 {CompilePrimaryExpr: literal primary} {expr {{abc\
def} < {abcdef}}} 1
-test expr-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0
-test expr-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123
-test expr-14.11 {CompilePrimaryExpr: var reference primary} {
+test compExpr-old-14.9 {CompilePrimaryExpr: literal primary} {expr {{abc\tde} > {abc\tdef}}} 0
+test compExpr-old-14.10 {CompilePrimaryExpr: literal primary} {expr {{123}}} 123
+test compExpr-old-14.11 {CompilePrimaryExpr: var reference primary} {
set i 789
list [expr {$i}] [expr $i]
} {789 789}
-test expr-14.12 {CompilePrimaryExpr: var reference primary} {
+test compExpr-old-14.12 {CompilePrimaryExpr: var reference primary} {
set i {789} ;# test expr's aggressive conversion to numeric semantics
list [expr {$i}] [expr $i]
} {789 789}
-test expr-14.13 {CompilePrimaryExpr: var reference primary} {
+test compExpr-old-14.13 {CompilePrimaryExpr: var reference primary} {
catch {unset a}
set a(foo) foo
set a(bar) bar
catch {unset a}
set result
} {123 1}
-test expr-14.14 {CompilePrimaryExpr: var reference primary} {
+test compExpr-old-14.14 {CompilePrimaryExpr: var reference primary} {
set i 123 ;# test "$var.0" floating point conversion hack
list [expr $i] [expr $i.0] [expr $i.0/12.0]
} {123 123.0 10.25}
-test expr-14.15 {CompilePrimaryExpr: var reference primary} {
+test compExpr-old-14.15 {CompilePrimaryExpr: var reference primary} {
set i 123
catch {expr $i.2} msg
set msg
} 123.2
-test expr-14.16 {CompilePrimaryExpr: error compiling var reference primary} {
+test compExpr-old-14.16 {CompilePrimaryExpr: error compiling var reference primary} {
catch {expr {$a(foo}} msg
set errorInfo
} {missing )
while compiling
"expr {$a(foo}"}
-test expr-14.17 {CompilePrimaryExpr: string primary that looks like var ref} {
+test compExpr-old-14.17 {CompilePrimaryExpr: string primary that looks like var ref} {
expr $
} $
-test expr-14.18 {CompilePrimaryExpr: quoted string primary} {
+test compExpr-old-14.18 {CompilePrimaryExpr: quoted string primary} {
expr "21"
} 21
-test expr-14.19 {CompilePrimaryExpr: quoted string primary} {
+test compExpr-old-14.19 {CompilePrimaryExpr: quoted string primary} {
set i 123
set x 456
expr "$i+$x"
} 579
-test expr-14.20 {CompilePrimaryExpr: quoted string primary} {
+test compExpr-old-14.20 {CompilePrimaryExpr: quoted string primary} {
set i 3
set x 6
expr 2+"$i.$x"
} 5.6
-test expr-14.21 {CompilePrimaryExpr: error in quoted string primary} {
+test compExpr-old-14.21 {CompilePrimaryExpr: error in quoted string primary} {
catch {expr "[set]"} msg
set msg
} {wrong # args: should be "set varName ?newValue?"}
-test expr-14.22 {CompilePrimaryExpr: subcommand primary} {
+test compExpr-old-14.22 {CompilePrimaryExpr: subcommand primary} {
expr {[set i 123; set i]}
} 123
-test expr-14.23 {CompilePrimaryExpr: error in subcommand primary} {
+test compExpr-old-14.23 {CompilePrimaryExpr: error in subcommand primary} {
catch {expr {[set]}} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
"set"
while compiling
"expr {[set]}"}
-test expr-14.24 {CompilePrimaryExpr: error in subcommand primary} {
+test compExpr-old-14.24 {CompilePrimaryExpr: error in subcommand primary} {
catch {expr {[set i}} msg
set errorInfo
} {missing close-bracket
while compiling
"expr {[set i}"}
-test expr-14.25 {CompilePrimaryExpr: math function primary} {
+test compExpr-old-14.25 {CompilePrimaryExpr: math function primary} {
format %.6g [expr exp(1.0)]
} 2.71828
-test expr-14.26 {CompilePrimaryExpr: math function primary} {
+test compExpr-old-14.26 {CompilePrimaryExpr: math function primary} {
format %.6g [expr pow(2.0+0.1,3.0+0.1)]
} 9.97424
-test expr-14.27 {CompilePrimaryExpr: error in math function primary} {
+test compExpr-old-14.27 {CompilePrimaryExpr: error in math function primary} {
catch {expr sinh::(2.0)} msg
set errorInfo
-} {syntax error in expression "sinh::(2.0)"
+} {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments
while compiling
"expr sinh::(2.0)"}
-test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
+test compExpr-old-14.28 {CompilePrimaryExpr: subexpression primary} {
expr 2+(3*4)
} 14
-test expr-14.29 {CompilePrimaryExpr: error in subexpression primary} {
+test compExpr-old-14.29 {CompilePrimaryExpr: error in subexpression primary} {
catch {expr 2+(3*[set])} msg
set errorInfo
} {wrong # args: should be "set varName ?newValue?"
"set"
while compiling
"expr 2+(3*[set])"}
-test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
+test compExpr-old-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
catch {expr 2+(3*(4+5)} msg
set errorInfo
-} {syntax error in expression "2+(3*(4+5)"
+} {syntax error in expression "2+(3*(4+5)": looking for close parenthesis
while compiling
"expr 2+(3*(4+5)"}
-test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
+test compExpr-old-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
set i "5+10"
list "[expr $i] == 15" "[expr ($i)] == 15" "[eval expr ($i)] == 15"
} {{15 == 15} {15 == 15} {15 == 15}}
-test expr-14.32 {CompilePrimaryExpr: unexpected token} {
+test compExpr-old-14.32 {CompilePrimaryExpr: unexpected token} {
catch {expr @} msg
set errorInfo
-} {syntax error in expression "@"
+} {syntax error in expression "@": character not legal in expressions
while compiling
"expr @"}
-test expr-15.1 {CompileMathFuncCall: missing parenthesis} {
+test compExpr-old-15.1 {CompileMathFuncCall: missing parenthesis} {
catch {expr sinh2.0)} msg
set errorInfo
-} {syntax error in expression "sinh2.0)"
+} {syntax error in expression "sinh2.0)": variable references require preceding $
while compiling
"expr sinh2.0)"}
-test expr-15.2 {CompileMathFuncCall: unknown math function} {
+test compExpr-old-15.2 {CompileMathFuncCall: unknown math function} {
catch {expr whazzathuh(1)} msg
set errorInfo
} {unknown math function "whazzathuh"
while compiling
"expr whazzathuh(1)"}
-test expr-15.3 {CompileMathFuncCall: too many arguments} {
+test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} {
catch {expr sin(1,2,3)} msg
set errorInfo
} {too many arguments for math function
while compiling
"expr sin(1,2,3)"}
-test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} {
+test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} {
catch {expr sin()} msg
set errorInfo
} {too few arguments for math function
while compiling
"expr sin()"}
-test expr-15.5 {CompileMathFuncCall: too few arguments} {
+test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} {
catch {expr pow(1)} msg
set errorInfo
} {too few arguments for math function
while compiling
"expr pow(1)"}
-test expr-15.6 {CompileMathFuncCall: missing ')'} {
+test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} {
catch {expr sin(1} msg
set errorInfo
-} {syntax error in expression "sin(1"
+} {syntax error in expression "sin(1": missing close parenthesis at end of function call
while compiling
"expr sin(1"}
if $gotT1 {
- test expr-15.7 {CompileMathFuncCall: call registered math function} {
+ test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} {
expr 2*T1()
} 246
- test expr-15.8 {CompileMathFuncCall: call registered math function} {
+ test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} {
expr T2()*3
} 1035
- test expr-15.9 {CompileMathFuncCall: call registered math function} {
+ test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} {
expr T3(21, 37)
} 37
- test expr-15.10 {CompileMathFuncCall: call registered math function} {
+ test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} {
expr T3(21.2, 37)
} 37.0
- test expr-15.11 {CompileMathFuncCall: call registered math function} {
+ test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} {
expr T3(-21.2, -17.5)
} -17.5
}
-test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
+test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
}
set i
} {}
-test expr-16.2 {GetToken: check for string literal in braces} {
+test compExpr-old-16.2 {GetToken: check for string literal in braces} {
expr {{1}}
} {1}
# Check "expr" and computed command names.
-test expr-17.1 {expr and computed command names} {
+test compExpr-old-17.1 {expr and computed command names} {
set i 0
set z expr
$z 1+2
# an integer, convert to integer. Otherwise, if the string looks like a
# double, convert to double.
-test expr-18.1 {expr and conversion of operands to numbers} {
+test compExpr-old-18.1 {expr and conversion of operands to numbers} {
set x [lindex 11 0]
catch {expr int($x)}
expr {$x}
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
-test expr-19.1 {expr and interpreter result object resetting} {
+test compExpr-old-19.1 {expr and interpreter result object resetting} {
proc p {} {
set t 10.0
set x 2.0
}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
} 3
test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} {
list [catch {expr 1+2+} msg] $msg
-} {1 {syntax error in expression "1+2+"}}
+} {1 {syntax error in expression "1+2+": premature end of expression}}
test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} {
list [catch {expr "foo(123)"} msg] $msg
} {1 {unknown math function "foo"}}
} 0
test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} {
list [catch {expr {"00[expr 1+]" + 17}} msg] $msg
-} {1 {syntax error in expression "1+"}}
+} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.3 {CompileSubExpr procedure, TCL_TOKEN_TEXT parse token} {
expr {{12345}}
} 12345
catch {unset a}
set a 15
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
-} {1 {syntax error in expression "1+"}}
+} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} {
expr {5*6}
} 30
} 2
test compExpr-2.35 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} {
list [catch {expr {+[expr 1+]}} msg] $msg
-} {1 {syntax error in expression "1+"}}
+} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.36 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
expr {4+2}
} 6
test compExpr-2.37 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} {
list [catch {expr {[expr 1+]+5}} msg] $msg
-} {1 {syntax error in expression "1+"}}
+} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.38 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, error in special operator} {
list [catch {expr {5+[expr 1+]}} msg] $msg
-} {1 {syntax error in expression "1+"}}
+} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
expr {-2}
} -2
catch {unset a}
set a 15
list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg
-} {1 {syntax error in expression "1+"}}
+} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} {
catch {unset a}
set a false
catch {unset a}
set a 15
list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg
-} {1 {syntax error in expression "1+"}}
+} {1 {syntax error in expression "1+": premature end of expression}}
test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} {
catch {unset a}
} 0
test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} {
list [catch {expr {[expr *2]||0}} msg] $msg
-} {1 {syntax error in expression "*2"}}
+} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} {
catch {unset a}
catch {unset b}
} 0
test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} {
list [catch {expr {0||[expr %2]}} msg] $msg
-} {1 {syntax error in expression "%2"}}
+} {1 {syntax error in expression "%2": unexpected operator %}}
test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} {
set a "abcdefghijkl"
set i 7
} -54
test compExpr-4.3 {CompileCondExpr procedure, error in test} {
list [catch {expr {[expr *2]? +1 : -1}} msg] $msg
-} {1 {syntax error in expression "*2"}}
+} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} {
catch {unset a}
set a no
} no
test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} {
list [catch {expr {1? [expr *2] : -127}} msg] $msg
-} {1 {syntax error in expression "*2"}}
+} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} {
catch {unset a}
set a no
} 83
test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} {
list [catch {expr {1? 15 : [expr *2]}} msg] $msg
-} {1 {syntax error in expression "*2"}}
+} {1 {syntax error in expression "*2": unexpected operator *}}
test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
format %.6g [expr atan2(1.0, 2.0)]
} 9.97424
test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} {
list [catch {expr {sinh(2.*)}} msg] $msg
-} {1 {syntax error in expression "sinh(2.*)"}}
+} {1 {syntax error in expression "sinh(2.*)": unexpected close parenthesis}}
test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} {
list [catch {expr {sinh(2.0, 3.0)}} msg] $msg
} {1 {too many arguments for math function}}
test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
list [catch {expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3} msg] $msg
-} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}
+} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": extra tokens at end of expression}}
# cleanup
catch {unset a}
catch {unset b}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-# This file contains tests for the file tclCompile.c.
+# This file contains tests for the files tclCompile.c, tclCompCmds.c
+# and tclLiteral.c
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
# The following tests are very incomplete, although the rest of the
# test suite covers this file fairly well.
test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
-} {1 {no value given for parameter "x" to "p"}}
-
+} {1 {wrong # args: should be "p x"}}
test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} {
catch {unset x}
set x 123
}
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}
+test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} {
+ catch {unset a}
+ proc p {} {
+ global a
+ set a(1) 1
+ return ${a(1)}$::a(1)$a(1)
+ }
+ list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
+} {111 1 1}
test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
catch {unset a}
catch-test
set ::foo
} 3
+test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} {
+ proc catch-test {str} {
+ catch [eval $str GOOD]
+ error BAD
+ }
+ catch {catch-test error} ::foo
+ set ::foo
+} {GOOD}
+test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} {
+ proc foo {} {
+ set fail [catch {
+ return 1
+ }] ; # {}
+ return 2
+ }
+ foo
+} {2}
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
}
} {}
+test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} {
+ # shared object - Interp result && Var 'r'
+ set r [list foobar]
+ # command that will add error to result
+ lindex a bogus
+ }
+ list [catch {p} msg] $msg
+} {1 {bad index "bogus": must be integer or end?-integer?}}
+test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; string index a bogus }
+ list [catch {p} msg] $msg
+} {1 {bad index "bogus": must be integer or end?-integer?}}
+test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; string index a 09 }
+ list [catch {p} msg] $msg
+} {1 {bad index "09": must be integer or end?-integer? (looks like invalid octal number)}}
+test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; array set var {one two many} }
+ list [catch {p} msg] $msg
+} {1 {list must have an even number of elements}}
+test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; incr foo }
+ list [catch {p} msg] $msg
+} {1 {can't read "foo": no such variable}}
+test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; incr foo bogus }
+ list [catch {p} msg] $msg
+} {1 {expected integer but got "bogus"}}
+test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; expr !a }
+ list [catch {p} msg] $msg
+} {1 {syntax error in expression "!a": variable references require preceding $}}
+test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; expr {!a} }
+ list [catch {p} msg] $msg
+} {1 {syntax error in expression "!a": variable references require preceding $}}
+test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
+ proc p {} { set r [list foobar] ; llength "\{" }
+ list [catch {p} msg] $msg
+} {1 {unmatched open brace in list}}
+
+#
+# Special section for tests of tclLiteral.c
+# The following tests check for incorrect memory handling in
+# TclReleaseLiteral. They are only effective when tcl is compiled
+# with TCL_MEM_DEBUG
+#
+# Special test for leak on interp delete [Bug 467523].
+::tcltest::testConstraint exec [llength [info commands exec]]
+::tcltest::testConstraint memDebug [llength [info commands memory]]
+
+test compile-12.1 {testing literal leak on interp delete} {memDebug} {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex [lindex $lines 3] 3
+ }
+
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ interp create foo
+ foo eval {
+ namespace eval bar {}
+ }
+ interp delete foo
+ set tmp $end
+ set end [getbytes]
+ }
+ rename getbytes {}
+ set leak [expr {$end - $tmp}]
+} 0
+# Special test for a memory error in a preliminary fix of [Bug 467523].
+# It requires executing a helpfile. Presumably the child process is
+# used because when this test fails, it crashes.
+test compile-12.2 {testing error on literal deletion} {memDebug exec} {
+ makeFile {
+ for {set i 0} {$i < 5} {incr i} {
+ namespace eval bar {}
+ namespace delete bar
+ }
+ puts 0
+ } source.file
+ set res [catch {
+ exec [interpreter] source.file
+ }]
+ catch {removeFile source.file}
+ set res
+} 0
+# Test to catch buffer overrun in TclCompileTokens from buf 530320
+test compile-12.3 {check for a buffer overrun} {
+ proc crash {} {
+ puts $array([expr {a+2}])
+ }
+ list [catch crash msg] $msg
+} {1 {syntax error in expression "a+2": variable references require preceding $}}
+
+# Special test for underestimating the maxStackSize required for a
+# compiled command. A failure will cause a segfault in the child
+# process.
+test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
+ set body {set x [list}
+ for {set i 0} {$i < 3000} {incr i} {
+ append body " $i"
+ }
+ append body {]; puts OK}
+ regsub BODY {proc crash {} {BODY}; crash} $body script
+ list [catch {exec [interpreter] << $script} msg] $msg
+} {0 OK}
+
+# Special test for compiling tokens from a copy of the source
+# string [Bug #599788]
+test compile-14.1 {testing errors in element name; segfault?} {} {
+ catch {set a([error])} msg1
+ catch {set bubba([join $abba $jubba]) $vol} msg2
+ list $msg1 $msg2
+} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
+
+
# cleanup
catch {unset a}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+++ /dev/null
-# This file contains support code for the Tcl test suite. It is
-# normally sourced by the individual files in the test suite before
-# they run their tests. This improved approach to testing was designed
-# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
-#
-# Copyright (c) 1990-1994 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id$
-
-if ![info exists srcdir] {
- set srcdir .
-}
-
-if ![info exists VERBOSE] {
- set VERBOSE 0
-}
-if ![info exists TESTS] {
- set TESTS {}
-}
-
-# If tests are being run as root, issue a warning message and set a
-# variable to prevent some tests from running at all.
-
-set user {}
-if {$tcl_platform(platform) == "unix"} {
- catch {set user [exec whoami]}
- if {$user == ""} {
- catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
- }
- if {$user == ""} {set user root}
- if {$user == "root"} {
- puts stdout "Warning: you're executing as root. I'll have to"
- puts stdout "skip some of the tests, since they'll fail as root."
- set testConfig(root) 1
- }
-}
-
-# Some of the tests don't work on some system configurations due to
-# differences in word length, file system configuration, etc. In order
-# to prevent false alarms, these tests are generally only run in the
-# master development directory for Tcl. The presence of a file
-# "doAllTests" in this directory is used to indicate that the non-portable
-# tests should be run.
-
-# If there is no "memory" command (because memory debugging isn't
-# enabled), generate a dummy command that does nothing.
-
-if {[info commands memory] == ""} {
- proc memory args {}
-}
-
-# Check configuration information that will determine which tests
-# to run. To do this, create an array testConfig. Each element
-# has a 0 or 1 value, and the following elements are defined:
-# unixOnly - 1 means this is a UNIX platform, so it's OK
-# to run tests that only work under UNIX.
-# macOnly - 1 means this is a Mac platform, so it's OK
-# to run tests that only work on Macs.
-# pcOnly - 1 means this is a PC platform, so it's OK to
-# run tests that only work on PCs.
-# unixOrPc - 1 means this is a UNIX or PC platform.
-# macOrPc - 1 means this is a Mac or PC platform.
-# macOrUnix - 1 means this is a Mac or UNIX platform.
-# nonPortable - 1 means this the tests are being running in
-# the master Tcl/Tk development environment;
-# Some tests are inherently non-portable because
-# they depend on things like word length, file system
-# configuration, window manager, etc. These tests
-# are only run in the main Tcl development directory
-# where the configuration is well known. The presence
-# of the file "doAllTests" in this directory indicates
-# that it is safe to run non-portable tests.
-# knownBug - The test is known to fail and the bug is not yet
-# fixed. The test will be run only if the file
-# "doBuggyTests" exists (intended for Tcl dev. group
-# internal use only).
-# tempNotPc - The inverse of pcOnly. This flag is used to
-# temporarily disable a test.
-# tempNotMac - The inverse of macOnly. This flag is used to
-# temporarily disable a test.
-# nonBlockFiles - 1 means this platform supports setting files into
-# nonblocking mode.
-# asyncPipeClose- 1 means this platform supports async flush and
-# async close on a pipe.
-# unixExecs - 1 means this machine has commands such as 'cat',
-# 'echo' etc available.
-# notIfCompiled - 1 means this that it is safe to run tests that
-# might fail if the bytecode compiler is used. This
-# element is set 1 if the file "doAllTests" exists in
-# this directory. Normally, this element is 0 so that
-# tests that fail with the bytecode compiler are
-# skipped. As of 11/2/96 these are the history tests
-# since they depend on accurate source location
-# information.
-
-catch {unset testConfig}
-if {$tcl_platform(platform) == "unix"} {
- set testConfig(unixOnly) 1
- set testConfig(tempNotPc) 1
- set testConfig(tempNotMac) 1
-} else {
- set testConfig(unixOnly) 0
-}
-if {$tcl_platform(platform) == "macintosh"} {
- set testConfig(tempNotPc) 1
- set testConfig(macOnly) 1
-} else {
- set testConfig(macOnly) 0
-}
-if {$tcl_platform(platform) == "windows"} {
- set testConfig(tempNotMac) 1
- set testConfig(pcOnly) 1
-} else {
- set testConfig(pcOnly) 0
-}
-set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
-set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
-set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
-set testConfig(nonPortable) [expr [file exists doAllTests] || [file exists doAllTe]]
-set testConfig(knownBug) [expr [file exists doBuggyTests] || [file exists doBuggyT]]
-set testConfig(notIfCompiled) [file exists doAllCompilerTests]
-
-set testConfig(unix) $testConfig(unixOnly)
-set testConfig(mac) $testConfig(macOnly)
-set testConfig(pc) $testConfig(pcOnly)
-
-set testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
-set testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
-set testConfig(win32s) [expr {$tcl_platform(os) == "Win32s"}]
-
-# The following config switches are used to mark tests that crash on
-# certain platforms, so that they can be reactivated again when the
-# underlying problem is fixed.
-
-set testConfig(pcCrash) $testConfig(macOrUnix)
-set testConfig(macCrash) $testConfig(unixOrPc)
-set testConfig(unixCrash) $testConfig(macOrPc)
-
-if {[catch {set f [open $srcdir/defs r]}]} {
- set testConfig(nonBlockFiles) 1
-} else {
- if {[expr [catch {fconfigure $f -blocking off}]] == 0} {
- set testConfig(nonBlockFiles) 1
- } else {
- set testConfig(nonBlockFiles) 0
- }
- close $f
-}
-
-trace variable testConfig r safeFetch
-
-proc safeFetch {n1 n2 op} {
- global testConfig
-
- if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
- set testConfig($n2) 0
- }
-}
-
-# Test for SCO Unix - cannot run async flushing tests because a potential
-# problem with select is apparently interfering. (Mark Diekhans).
-
-if {$tcl_platform(platform) == "unix"} {
- if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
- set testConfig(asyncPipeClose) 0
- } else {
- set testConfig(asyncPipeClose) 1
- }
-} else {
- set testConfig(asyncPipeClose) 1
-}
-
-# Test to see if we have a broken version of sprintf with respect to the
-# "e" format of floating-point numbers.
-
-set testConfig(eformat) 1
-if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
- set testConfig(eformat) 0
- puts "(will skip tests that depend on the \"e\" format of floating-point numbers)"
-}
-# Test to see if execed commands such as cat, echo, rm and so forth are
-# present on this machine.
-
-set testConfig(unixExecs) 1
-if {$tcl_platform(platform) == "macintosh"} {
- set testConfig(unixExecs) 0
-}
-if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} {
- if {[catch {exec cat $srcdir/defs}] == 1} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec sh -c echo hello}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec wc $srcdir/defs}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {$testConfig(unixExecs) == 1} {
- exec echo hello > removeMe
- if {[catch {exec rm removeMe}] == 1} {
- set testConfig(unixExecs) 0
- }
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec fgrep unixExecs $srcdir/defs}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} {
- set testConfig(unixExecs) 0
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec echo abc > removeMe}] == 0) && \
- ([catch {exec chmod 644 removeMe}] == 1) && \
- ([catch {exec rm removeMe}] == 0)} {
- set testConfig(unixExecs) 0
- } else {
- catch {exec rm -f removeMe}
- }
- if {($testConfig(unixExecs) == 1) && \
- ([catch {exec mkdir removeMe}] == 1)} {
- set testConfig(unixExecs) 0
- } else {
- catch {exec rm -r removeMe}
- }
- if {$testConfig(unixExecs) == 0} {
- puts stdout "Warning: Unix-style executables are not available, so"
- puts stdout "some tests will be skipped."
- }
-}
-
-proc print_verbose {name description constraints script code answer} {
- puts stdout "\n"
- if {[string length $constraints]} {
- puts stdout "==== $name $description\t--- ($constraints) ---"
- } else {
- puts stdout "==== $name $description"
- }
- puts stdout "==== Contents of test case:"
- puts stdout "$script"
- if {$code != 0} {
- if {$code == 1} {
- puts stdout "==== Test generated error:"
- puts stdout $answer
- } elseif {$code == 2} {
- puts stdout "==== Test generated return exception; result was:"
- puts stdout $answer
- } elseif {$code == 3} {
- puts stdout "==== Test generated break exception"
- } elseif {$code == 4} {
- puts stdout "==== Test generated continue exception"
- } else {
- puts stdout "==== Test generated exception $code; message was:"
- puts stdout $answer
- }
- } else {
- puts stdout "==== Result was:"
- puts stdout "$answer"
- }
-}
-
-# test --
-# This procedure runs a test and prints an error message if the
-# test fails. If VERBOSE has been set, it also prints a message
-# even if the test succeeds. The test will be skipped if it
-# doesn't match the TESTS variable, or if one of the elements
-# of "constraints" turns out not to be true.
-#
-# Arguments:
-# name - Name of test, in the form foo-1.2.
-# description - Short textual description of the test, to
-# help humans understand what it does.
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "testConfig". If any of these
-# elements is zero, the test is skipped.
-# This argument may be omitted.
-# script - Script to run to carry out the test. It must
-# return a result that can be checked for
-# correctness.
-# answer - Expected result from script.
-
-proc test {name description script answer args} {
- global VERBOSE TESTS testConfig
- if {[string compare $TESTS ""] != 0} then {
- set ok 0
- foreach test $TESTS {
- if [string match $test $name] then {
- set ok 1
- break
- }
- }
- if !$ok then return
- }
- set i [llength $args]
- if {$i == 0} {
- set constraints {}
- } elseif {$i == 1} {
- # "constraints" argument exists; shuffle arguments down, then
- # make sure that the constraints are satisfied.
-
- set constraints $script
- set script $answer
- set answer [lindex $args 0]
- set doTest 0
- if {[string match {*[$\[]*} $constraints] != 0} {
- # full expression, e.g. {$foo > [info tclversion]}
-
- catch {set doTest [uplevel #0 expr [list $constraints]]} msg
- } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
- # something like {a || b} should be turned into
- # $testConfig(a) || $testConfig(b).
-
- regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c
- catch {set doTest [eval expr $c]}
- } else {
- # just simple constraints such as {unixOnly fonts}.
-
- set doTest 1
- foreach constraint $constraints {
- if {![info exists testConfig($constraint)]
- || !$testConfig($constraint)} {
- set doTest 0
- break
- }
- }
- }
- if {$doTest == 0} {
- if $VERBOSE then {
- puts stdout "++++ $name SKIPPED: $constraints"
- }
- return
- }
- } else {
- error "wrong # args: must be \"test name description ?constraints? script answer\""
- }
- memory tag $name
- set code [catch {uplevel $script} result]
- if {$code != 0} {
- print_verbose $name $description $constraints $script \
- $code $result
- } elseif {[string compare $result $answer] == 0} then {
- if $VERBOSE then {
- if {$VERBOSE > 0} {
- print_verbose $name $description $constraints $script \
- $code $result
- }
- if {$VERBOSE != -2} {
- puts stdout "++++ $name PASSED"
- }
- }
- } else {
- print_verbose $name $description $constraints $script \
- $code $result
- puts stdout "---- Result should have been:"
- puts stdout "$answer"
- puts stdout "---- $name FAILED"
- }
-}
-
-proc dotests {file args} {
- global TESTS
- set savedTests $TESTS
- set TESTS $args
- source $file
- set TESTS $savedTests
-}
-
-proc normalizeMsg {msg} {
- regsub "\n$" [string tolower $msg] "" msg
- regsub -all "\n\n" $msg "\n" msg
- regsub -all "\n\}" $msg "\}" msg
- return $msg
-}
-
-proc makeFile {contents name} {
- set fd [open $name w]
- fconfigure $fd -translation lf
- if {[string index $contents [expr [string length $contents] - 1]] == "\n"} {
- puts -nonewline $fd $contents
- } else {
- puts $fd $contents
- }
- close $fd
-}
-
-proc removeFile {name} {
- file delete $name
-}
-
-proc makeDirectory {name} {
- file mkdir $name
-}
-
-proc removeDirectory {name} {
- file delete -force $name
-}
-
-proc viewFile {name} {
- global tcl_platform testConfig
- if {($tcl_platform(platform) == "macintosh") || \
- ($testConfig(unixExecs) == 0)} {
- set f [open $name]
- set data [read -nonewline $f]
- close $f
- return $data
- } else {
- exec cat $name
- }
-}
-
-# Locate tcltest executable
-
-set tcltest [info nameofexecutable]
-
-if {$tcltest == "{}"} {
- set tcltest {}
- puts "Unable to find tcltest executable, multiple process tests will fail."
-}
-
-if {$tcl_platform(os) != "Win32s"} {
- # Don't even try running another copy of tcltest under win32s, or you
- # get an error dialog about multiple instances.
-
- catch {
- file delete -force tmp
- set f [open tmp w]
- puts $f {
- exit
- }
- close $f
- set f [open "|[list $tcltest tmp]" r]
- close $f
- set testConfig(stdio) 1
- }
- catch {file delete -force tmp}
-}
-
-if {($tcl_platform(platform) == "windows") && ($testConfig(stdio) == 0)} {
- puts "(will skip tests that redirect stdio of exec'd 32-bit applications)"
-}
-
-catch {socket} msg
-set testConfig(socket) [expr {$msg != "sockets are not available on this system"}]
-
-if {$testConfig(socket) == 0} {
- puts "(will skip tests that use sockets)"
-}
-
-
+++ /dev/null
-# defs.tcl --
-#
-# This file contains support code for the Tcl/Tk test suite.It is
-# It is normally sourced by the individual files in the test suite
-# before they run their tests. This improved approach to testing
-# was designed and initially implemented by Mary Ann May-Pumphrey
-# of Sun Microsystems.
-#
-# Copyright (c) 1990-1994 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-# Initialize wish shell
-
-if {[info exists tk_version]} {
- tk appname tktest
- wm title . tktest
-} else {
-
- # Ensure that we have a minimal auto_path so we don't pick up extra junk.
-
- set auto_path [list [info library]]
-}
-
-# create the "tcltest" namespace for all testing variables and procedures
-
-namespace eval tcltest {
- set procList [list test cleanupTests dotests saveState restoreState \
- normalizeMsg makeFile removeFile makeDirectory removeDirectory \
- viewFile bytestring set_iso8859_1_locale restore_locale \
- safeFetch threadReap]
- if {[info exists tk_version]} {
- lappend procList setupbg dobg bgReady cleanupbg fixfocus
- }
- foreach proc $procList {
- namespace export $proc
- }
-
- # ::tcltest::verbose defaults to "b"
-
- variable verbose "b"
-
- # match defaults to the empty list
-
- variable match {}
-
- # skip defaults to the empty list
-
- variable skip {}
-
- # Tests should not rely on the current working directory.
- # Files that are part of the test suite should be accessed relative to
- # ::tcltest::testsDir.
-
- set originalDir [pwd]
- set tDir [file join $originalDir [file dirname [info script]]]
- cd $tDir
- variable testsDir [pwd]
- cd $originalDir
-
- # Count the number of files tested (0 if all.tcl wasn't called).
- # The all.tcl file will set testSingleFile to false, so stats will
- # not be printed until all.tcl calls the cleanupTests proc.
- # The currentFailure var stores the boolean value of whether the
- # current test file has had any failures. The failFiles list
- # stores the names of test files that had failures.
-
- variable numTestFiles 0
- variable testSingleFile true
- variable currentFailure false
- variable failFiles {}
-
- # Tests should remove all files they create. The test suite will
- # check the current working dir for files created by the tests.
- # ::tcltest::filesMade keeps track of such files created using the
- # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
- # ::tcltest::filesExisted stores the names of pre-existing files.
-
- variable filesMade {}
- variable filesExisted {}
-
- # ::tcltest::numTests will store test files as indices and the list
- # of files (that should not have been) left behind by the test files.
-
- array set ::tcltest::createdNewFiles {}
-
- # initialize ::tcltest::numTests array to keep track fo the number of
- # tests that pass, fial, and are skipped.
-
- array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
-
- # initialize ::tcltest::skippedBecause array to keep track of
- # constraints that kept tests from running
-
- array set ::tcltest::skippedBecause {}
-
- # tests that use thread need to know which is the main thread
-
- variable ::tcltest::mainThread 1
- if {[info commands testthread] != {}} {
- set ::tcltest::mainThread [testthread names]
- }
-}
-
-# If there is no "memory" command (because memory debugging isn't
-# enabled), generate a dummy command that does nothing.
-
-if {[info commands memory] == ""} {
- proc memory args {}
-}
-
-# ::tcltest::initConfig --
-#
-# Check configuration information that will determine which tests
-# to run. To do this, create an array ::tcltest::testConfig. Each
-# element has a 0 or 1 value. If the element is "true" then tests
-# with that constraint will be run, otherwise tests with that constraint
-# will be skipped. See the README file for the list of built-in
-# constraints defined in this procedure.
-#
-# Arguments:
-# none
-#
-# Results:
-# The ::tcltest::testConfig array is reset to have an index for
-# each built-in test constraint.
-
-proc ::tcltest::initConfig {} {
-
- global tcl_platform tcl_interactive tk_version
-
- catch {unset ::tcltest::testConfig}
-
- # The following trace procedure makes it so that we can safely refer to
- # non-existent members of the ::tcltest::testConfig array without causing an
- # error. Instead, reading a non-existent member will return 0. This is
- # necessary because tests are allowed to use constraint "X" without ensuring
- # that ::tcltest::testConfig("X") is defined.
-
- trace variable ::tcltest::testConfig r ::tcltest::safeFetch
-
- proc ::tcltest::safeFetch {n1 n2 op} {
- if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} {
- set ::tcltest::testConfig($n2) 0
- }
- }
-
- set ::tcltest::testConfig(unixOnly) \
- [expr {$tcl_platform(platform) == "unix"}]
- set ::tcltest::testConfig(macOnly) \
- [expr {$tcl_platform(platform) == "macintosh"}]
- set ::tcltest::testConfig(pcOnly) \
- [expr {$tcl_platform(platform) == "windows"}]
-
- set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly)
- set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly)
- set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly)
-
- set ::tcltest::testConfig(unixOrPc) \
- [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}]
- set ::tcltest::testConfig(macOrPc) \
- [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}]
- set ::tcltest::testConfig(macOrUnix) \
- [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}]
-
- set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
- set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
-
- # The following config switches are used to mark tests that should work,
- # but have been temporarily disabled on certain platforms because they don't
- # and we haven't gotten around to fixing the underlying problem.
-
- set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}]
- set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}]
- set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}]
-
- # The following config switches are used to mark tests that crash on
- # certain platforms, so that they can be reactivated again when the
- # underlying problem is fixed.
-
- set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}]
- set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}]
- set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}]
-
- # Set the "fonts" constraint for wish apps
-
- if {[info exists tk_version]} {
- set ::tcltest::testConfig(fonts) 1
- catch {destroy .e}
- entry .e -width 0 -font {Helvetica -12} -bd 1
- .e insert end "a.bcd"
- if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
- set ::tcltest::testConfig(fonts) 0
- }
- destroy .e
- catch {destroy .t}
- text .t -width 80 -height 20 -font {Times -14} -bd 1
- pack .t
- .t insert end "This is\na dot."
- update
- set x [list [.t bbox 1.3] [.t bbox 2.5]]
- destroy .t
- if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
- set ::tcltest::testConfig(fonts) 0
- }
- }
-
- # Skip empty tests
-
- set ::tcltest::testConfig(emptyTest) 0
-
- # By default, tests that expost known bugs are skipped.
-
- set ::tcltest::testConfig(knownBug) 0
-
- # By default, non-portable tests are skipped.
-
- set ::tcltest::testConfig(nonPortable) 0
-
- # Some tests require user interaction.
-
- set ::tcltest::testConfig(userInteraction) 0
-
- # Some tests must be skipped if the interpreter is not in interactive mode
-
- set ::tcltest::testConfig(interactive) $tcl_interactive
-
- # Some tests must be skipped if you are running as root on Unix.
- # Other tests can only be run if you are running as root on Unix.
-
- set ::tcltest::testConfig(root) 0
- set ::tcltest::testConfig(notRoot) 1
- set user {}
- if {$tcl_platform(platform) == "unix"} {
- catch {set user [exec whoami]}
- if {$user == ""} {
- catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
- }
- if {($user == "root") || ($user == "")} {
- set ::tcltest::testConfig(root) 1
- set ::tcltest::testConfig(notRoot) 0
- }
- }
-
- # Set nonBlockFiles constraint: 1 means this platform supports
- # setting files into nonblocking mode.
-
- if {[catch {set f [open defs r]}]} {
- set ::tcltest::testConfig(nonBlockFiles) 1
- } else {
- if {[catch {fconfigure $f -blocking off}] == 0} {
- set ::tcltest::testConfig(nonBlockFiles) 1
- } else {
- set ::tcltest::testConfig(nonBlockFiles) 0
- }
- close $f
- }
-
- # Set asyncPipeClose constraint: 1 means this platform supports
- # async flush and async close on a pipe.
- #
- # Test for SCO Unix - cannot run async flushing tests because a
- # potential problem with select is apparently interfering.
- # (Mark Diekhans).
-
- if {$tcl_platform(platform) == "unix"} {
- if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
- set ::tcltest::testConfig(asyncPipeClose) 0
- } else {
- set ::tcltest::testConfig(asyncPipeClose) 1
- }
- } else {
- set ::tcltest::testConfig(asyncPipeClose) 1
- }
-
- # Test to see if we have a broken version of sprintf with respect
- # to the "e" format of floating-point numbers.
-
- set ::tcltest::testConfig(eformat) 1
- if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
- set ::tcltest::testConfig(eformat) 0
- }
-
- # Test to see if execed commands such as cat, echo, rm and so forth are
- # present on this machine.
-
- set ::tcltest::testConfig(unixExecs) 1
- if {$tcl_platform(platform) == "macintosh"} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ($tcl_platform(platform) == "windows")} {
- if {[catch {exec cat defs}] == 1} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec echo hello}] == 1)} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec sh -c echo hello}] == 1)} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec wc defs}] == 1)} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {$::tcltest::testConfig(unixExecs) == 1} {
- exec echo hello > removeMe
- if {[catch {exec rm removeMe}] == 1} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec sleep 1}] == 1)} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec fgrep unixExecs defs}] == 1)} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec ps}] == 1)} {
- set ::tcltest::testConfig(unixExecs) 0
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec echo abc > removeMe}] == 0) && \
- ([catch {exec chmod 644 removeMe}] == 1) && \
- ([catch {exec rm removeMe}] == 0)} {
- set ::tcltest::testConfig(unixExecs) 0
- } else {
- catch {exec rm -f removeMe}
- }
- if {($::tcltest::testConfig(unixExecs) == 1) && \
- ([catch {exec mkdir removeMe}] == 1)} {
- set ::tcltest::testConfig(unixExecs) 0
- } else {
- catch {exec rm -r removeMe}
- }
- }
-}
-
-::tcltest::initConfig
-
-
-# ::tcltest::processCmdLineArgs --
-#
-# Use command line args to set the verbose, skip, and
-# match variables. This procedure must be run after
-# constraints are initialized, because some constraints can be
-# overridden.
-#
-# Arguments:
-# none
-#
-# Results:
-# ::tcltest::verbose is set to <value>
-
-proc ::tcltest::processCmdLineArgs {} {
- global argv
-
- # The "argv" var doesn't exist in some cases, so use {}
- # The "argv" var doesn't exist in some cases.
-
- if {(![info exists argv]) || ([llength $argv] < 2)} {
- set flagArray {}
- } else {
- set flagArray $argv
- }
-
- if {[catch {array set flag $flagArray}]} {
- puts stderr "Error: odd number of command line args specified:"
- puts stderr " $argv"
- exit
- }
-
- # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
- # Note that -verbose cannot be abbreviated to -v in wish because it
- # conflicts with the wish option -visual.
-
- foreach arg {-verbose -match -skip -constraints} {
- set abbrev [string range $arg 0 1]
- if {([info exists flag($abbrev)]) && \
- ([lsearch -exact $flagArray $arg] < \
- [lsearch -exact $flagArray $abbrev])} {
- set flag($arg) $flag($abbrev)
- }
- }
-
- # Set ::tcltest::workingDir to [pwd].
- # Save the names of files that already exist in ::tcltest::workingDir.
-
- set ::tcltest::workingDir [pwd]
- foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
- lappend ::tcltest::filesExisted [file tail $file]
- }
-
- # Set ::tcltest::verbose to the arg of the -verbose flag, if given
-
- if {[info exists flag(-verbose)]} {
- set ::tcltest::verbose $flag(-verbose)
- }
-
- # Set ::tcltest::match to the arg of the -match flag, if given
-
- if {[info exists flag(-match)]} {
- set ::tcltest::match $flag(-match)
- }
-
- # Set ::tcltest::skip to the arg of the -skip flag, if given
-
- if {[info exists flag(-skip)]} {
- set ::tcltest::skip $flag(-skip)
- }
-
- # Use the -constraints flag, if given, to turn on constraints that are
- # turned off by default: userInteractive knownBug nonPortable. This
- # code fragment must be run after constraints are initialized.
-
- if {[info exists flag(-constraints)]} {
- foreach elt $flag(-constraints) {
- set ::tcltest::testConfig($elt) 1
- }
- }
-}
-
-::tcltest::processCmdLineArgs
-
-
-# ::tcltest::cleanupTests --
-#
-# Remove files and dirs created using the makeFile and makeDirectory
-# commands since the last time this proc was invoked.
-#
-# Print the names of the files created without the makeFile command
-# since the tests were invoked.
-#
-# Print the number tests (total, passed, failed, and skipped) since the
-# tests were invoked.
-#
-
-proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
- set tail [file tail [info script]]
-
- # Remove files and directories created by the :tcltest::makeFile and
- # ::tcltest::makeDirectory procedures.
- # Record the names of files in ::tcltest::workingDir that were not
- # pre-existing, and associate them with the test file that created them.
-
- if {!$calledFromAllFile} {
-
- foreach file $::tcltest::filesMade {
- if {[file exists $file]} {
- catch {file delete -force $file}
- }
- }
- set currentFiles {}
- foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
- lappend currentFiles [file tail $file]
- }
- set newFiles {}
- foreach file $currentFiles {
- if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
- lappend newFiles $file
- }
- }
- set ::tcltest::filesExisted $currentFiles
- if {[llength $newFiles] > 0} {
- set ::tcltest::createdNewFiles($tail) $newFiles
- }
- }
-
- if {$calledFromAllFile || $::tcltest::testSingleFile} {
-
- # print stats
-
- puts -nonewline stdout "$tail:"
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
- }
- puts stdout ""
-
- # print number test files sourced
- # print names of files that ran tests which failed
-
- if {$calledFromAllFile} {
- puts stdout "Sourced $::tcltest::numTestFiles Test Files."
- set ::tcltest::numTestFiles 0
- if {[llength $::tcltest::failFiles] > 0} {
- puts stdout "Files with failing tests: $::tcltest::failFiles"
- set ::tcltest::failFiles {}
- }
- }
-
- # if any tests were skipped, print the constraints that kept them
- # from running.
-
- set constraintList [array names ::tcltest::skippedBecause]
- if {[llength $constraintList] > 0} {
- puts stdout "Number of tests skipped for each constraint:"
- foreach constraint [lsort $constraintList] {
- puts stdout \
- "\t$::tcltest::skippedBecause($constraint)\t$constraint"
- unset ::tcltest::skippedBecause($constraint)
- }
- }
-
- # report the names of test files in ::tcltest::createdNewFiles, and
- # reset the array to be empty.
-
- set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
- if {[llength $testFilesThatTurded] > 0} {
- puts stdout "Warning: test files left files behind:"
- foreach testFile $testFilesThatTurded {
- puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
- unset ::tcltest::createdNewFiles($testFile)
- }
- }
-
- # reset filesMade, filesExisted, and numTests
-
- set ::tcltest::filesMade {}
- foreach index [list "Total" "Passed" "Skipped" "Failed"] {
- set ::tcltest::numTests($index) 0
- }
-
- # exit only if running Tk in non-interactive mode
-
- global tk_version tcl_interactive
- if {[info exists tk_version] && !$tcl_interactive} {
- exit
- }
- } else {
-
- # if we're deferring stat-reporting until all files are sourced,
- # then add current file to failFile list if any tests in this file
- # failed
-
- incr ::tcltest::numTestFiles
- if {($::tcltest::currentFailure) && \
- ([lsearch -exact $::tcltest::failFiles $tail] == -1)} {
- lappend ::tcltest::failFiles $tail
- }
- set ::tcltest::currentFailure false
- }
-}
-
-
-# test --
-#
-# This procedure runs a test and prints an error message if the test fails.
-# If ::tcltest::verbose has been set, it also prints a message even if the
-# test succeeds. The test will be skipped if it doesn't match the
-# ::tcltest::match variable, if it matches an element in
-# ::tcltest::skip, or if one of the elements of "constraints" turns
-# out not to be true.
-#
-# Arguments:
-# name - Name of test, in the form foo-1.2.
-# description - Short textual description of the test, to
-# help humans understand what it does.
-# constraints - A list of one or more keywords, each of
-# which must be the name of an element in
-# the array "::tcltest::testConfig". If any of these
-# elements is zero, the test is skipped.
-# This argument may be omitted.
-# script - Script to run to carry out the test. It must
-# return a result that can be checked for
-# correctness.
-# expectedAnswer - Expected result from script.
-
-proc ::tcltest::test {name description script expectedAnswer args} {
- incr ::tcltest::numTests(Total)
-
- # skip the test if it's name matches an element of skip
-
- foreach pattern $::tcltest::skip {
- if {[string match $pattern $name]} {
- incr ::tcltest::numTests(Skipped)
- return
- }
- }
- # skip the test if it's name doesn't match any element of match
-
- if {[llength $::tcltest::match] > 0} {
- set ok 0
- foreach pattern $::tcltest::match {
- if {[string match $pattern $name]} {
- set ok 1
- break
- }
- }
- if {!$ok} {
- incr ::tcltest::numTests(Skipped)
- return
- }
- }
- set i [llength $args]
- if {$i == 0} {
- set constraints {}
- } elseif {$i == 1} {
-
- # "constraints" argument exists; shuffle arguments down, then
- # make sure that the constraints are satisfied.
-
- set constraints $script
- set script $expectedAnswer
- set expectedAnswer [lindex $args 0]
- set doTest 0
- if {[string match {*[$\[]*} $constraints] != 0} {
-
- # full expression, e.g. {$foo > [info tclversion]}
-
- catch {set doTest [uplevel #0 expr $constraints]}
-
- } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
-
- # something like {a || b} should be turned into
- # $::tcltest::testConfig(a) || $::tcltest::testConfig(b).
-
- regsub -all {[.a-zA-Z0-9]+} $constraints \
- {$::tcltest::testConfig(&)} c
- catch {set doTest [eval expr $c]}
- } else {
-
- # just simple constraints such as {unixOnly fonts}.
-
- set doTest 1
- foreach constraint $constraints {
- if {![info exists ::tcltest::testConfig($constraint)]
- || !$::tcltest::testConfig($constraint)} {
- set doTest 0
-
- # store the constraint that kept the test from running
-
- set constraints $constraint
- break
- }
- }
- }
- if {$doTest == 0} {
- incr ::tcltest::numTests(Skipped)
- if {[string first s $::tcltest::verbose] != -1} {
- puts stdout "++++ $name SKIPPED: $constraints"
- }
-
- # add the constraint to the list of constraints the kept tests
- # from running
-
- if {[info exists ::tcltest::skippedBecause($constraints)]} {
- incr ::tcltest::skippedBecause($constraints)
- } else {
- set ::tcltest::skippedBecause($constraints) 1
- }
- return
- }
- } else {
- error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
- }
- memory tag $name
- set code [catch {uplevel $script} actualAnswer]
- if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
- incr ::tcltest::numTests(Failed)
- set ::tcltest::currentFailure true
- if {[string first b $::tcltest::verbose] == -1} {
- set script ""
- }
- puts stdout "\n==== $name $description FAILED"
- if {$script != ""} {
- puts stdout "==== Contents of test case:"
- puts stdout $script
- }
- if {$code != 0} {
- if {$code == 1} {
- puts stdout "==== Test generated error:"
- puts stdout $actualAnswer
- } elseif {$code == 2} {
- puts stdout "==== Test generated return exception; result was:"
- puts stdout $actualAnswer
- } elseif {$code == 3} {
- puts stdout "==== Test generated break exception"
- } elseif {$code == 4} {
- puts stdout "==== Test generated continue exception"
- } else {
- puts stdout "==== Test generated exception $code; message was:"
- puts stdout $actualAnswer
- }
- } else {
- puts stdout "---- Result was:\n$actualAnswer"
- }
- puts stdout "---- Result should have been:\n$expectedAnswer"
- puts stdout "==== $name FAILED\n"
- } else {
- incr ::tcltest::numTests(Passed)
- if {[string first p $::tcltest::verbose] != -1} {
- puts stdout "++++ $name PASSED"
- }
- }
-}
-
-# ::tcltest::dotests --
-#
-# takes two arguments--the name of the test file (such
-# as "parse.test"), and a pattern selecting the tests you want to
-# execute. It sets ::tcltest::matching to the second argument, calls
-# "source" on the file specified in the first argument, and restores
-# ::tcltest::matching to its pre-call value at the end.
-#
-# Arguments:
-# file name of tests file to source
-# args pattern selecting the tests you want to execute
-#
-# Results:
-# none
-
-proc ::tcltest::dotests {file args} {
- set savedTests $::tcltest::match
- set ::tcltest::match $args
- source $file
- set ::tcltest::match $savedTests
-}
-
-proc ::tcltest::openfiles {} {
- if {[catch {testchannel open} result]} {
- return {}
- }
- return $result
-}
-
-proc ::tcltest::leakfiles {old} {
- if {[catch {testchannel open} new]} {
- return {}
- }
- set leak {}
- foreach p $new {
- if {[lsearch $old $p] < 0} {
- lappend leak $p
- }
- }
- return $leak
-}
-
-set ::tcltest::saveState {}
-
-proc ::tcltest::saveState {} {
- uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
-}
-
-proc ::tcltest::restoreState {} {
- foreach p [info procs] {
- if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} {
- rename $p {}
- }
- }
- foreach p [uplevel #0 {info vars}] {
- if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
- uplevel #0 "unset $p"
- }
- }
-}
-
-proc ::tcltest::normalizeMsg {msg} {
- regsub "\n$" [string tolower $msg] "" msg
- regsub -all "\n\n" $msg "\n" msg
- regsub -all "\n\}" $msg "\}" msg
- return $msg
-}
-
-# makeFile --
-#
-# Create a new file with the name <name>, and write <contents> to it.
-#
-# If this file hasn't been created via makeFile since the last time
-# cleanupTests was called, add it to the $filesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-proc ::tcltest::makeFile {contents name} {
- set fd [open $name w]
- fconfigure $fd -translation lf
- if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
- puts -nonewline $fd $contents
- } else {
- puts $fd $contents
- }
- close $fd
-
- set fullName [file join [pwd] $name]
- if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
- lappend ::tcltest::filesMade $fullName
- }
-}
-
-proc ::tcltest::removeFile {name} {
- file delete $name
-}
-
-# makeDirectory --
-#
-# Create a new dir with the name <name>.
-#
-# If this dir hasn't been created via makeDirectory since the last time
-# cleanupTests was called, add it to the $directoriesMade list, so it will
-# be removed by the next call to cleanupTests.
-#
-proc ::tcltest::makeDirectory {name} {
- file mkdir $name
-
- set fullName [file join [pwd] $name]
- if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
- lappend ::tcltest::filesMade $fullName
- }
-}
-
-proc ::tcltest::removeDirectory {name} {
- file delete -force $name
-}
-
-proc ::tcltest::viewFile {name} {
- global tcl_platform
- if {($tcl_platform(platform) == "macintosh") || \
- ($::tcltest::testConfig(unixExecs) == 0)} {
- set f [open $name]
- set data [read -nonewline $f]
- close $f
- return $data
- } else {
- exec cat $name
- }
-}
-
-#
-# Construct a string that consists of the requested sequence of bytes,
-# as opposed to a string of properly formed UTF-8 characters.
-# This allows the tester to
-# 1. Create denormalized or improperly formed strings to pass to C procedures
-# that are supposed to accept strings with embedded NULL bytes.
-# 2. Confirm that a string result has a certain pattern of bytes, for instance
-# to confirm that "\xe0\0" in a Tcl script is stored internally in
-# UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
-#
-# Generally, it's a bad idea to examine the bytes in a Tcl string or to
-# construct improperly formed strings in this manner, because it involves
-# exposing that Tcl uses UTF-8 internally.
-
-proc ::tcltest::bytestring {string} {
- encoding convertfrom identity $string
-}
-
-# Locate tcltest executable
-
-if {![info exists tk_version]} {
- set tcltest [info nameofexecutable]
-
- if {$tcltest == "{}"} {
- set tcltest {}
- }
-}
-
-set ::tcltest::testConfig(stdio) 0
-catch {
- catch {file delete -force tmp}
- set f [open tmp w]
- puts $f {
- exit
- }
- close $f
-
- set f [open "|[list $tcltest tmp]" r]
- close $f
-
- set ::tcltest::testConfig(stdio) 1
-}
-catch {file delete -force tmp}
-
-# Deliberately call the socket with the wrong number of arguments. The error
-# message you get will indicate whether sockets are available on this system.
-
-catch {socket} msg
-set ::tcltest::testConfig(socket) \
- [expr {$msg != "sockets are not available on this system"}]
-
-#
-# Internationalization / ISO support procs -- dl
-#
-
-if {[info commands testlocale]==""} {
-
- # No testlocale command, no tests...
- # (it could be that we are a sub interp and we could just load
- # the Tcltest package but that would interfere with tests
- # that tests packages/loading in slaves...)
-
- set ::tcltest::testConfig(hasIsoLocale) 0
-} else {
- proc ::tcltest::set_iso8859_1_locale {} {
- set ::tcltest::previousLocale [testlocale ctype]
- testlocale ctype $::tcltest::isoLocale
- }
-
- proc ::tcltest::restore_locale {} {
- testlocale ctype $::tcltest::previousLocale
- }
-
- if {![info exists ::tcltest::isoLocale]} {
- set ::tcltest::isoLocale fr
- switch $tcl_platform(platform) {
- "unix" {
-
- # Try some 'known' values for some platforms:
-
- switch -exact -- $tcl_platform(os) {
- "FreeBSD" {
- set ::tcltest::isoLocale fr_FR.ISO_8859-1
- }
- HP-UX {
- set ::tcltest::isoLocale fr_FR.iso88591
- }
- Linux -
- IRIX {
- set ::tcltest::isoLocale fr
- }
- default {
-
- # Works on SunOS 4 and Solaris, and maybe others...
- # define it to something else on your system
- #if you want to test those.
-
- set ::tcltest::isoLocale iso_8859_1
- }
- }
- }
- "windows" {
- set ::tcltest::isoLocale French
- }
- }
- }
-
- set ::tcltest::testConfig(hasIsoLocale) \
- [string length [::tcltest::set_iso8859_1_locale]]
- ::tcltest::restore_locale
-}
-
-#
-# procedures that are Tk specific
-#
-
-if {[info exists tk_version]} {
-
- # If the main window isn't already mapped (e.g. because the tests are
- # being run automatically) , specify a precise size for it so that the
- # user won't have to position it manually.
-
- if {![winfo ismapped .]} {
- wm geometry . +0+0
- update
- }
-
- # The following code can be used to perform tests involving a second
- # process running in the background.
-
- # Locate the tktest executable
-
- set ::tcltest::tktest [info nameofexecutable]
- if {$::tcltest::tktest == "{}"} {
- set ::tcltest::tktest {}
- puts stdout \
- "Unable to find tktest executable, skipping multiple process tests."
- }
-
- # Create background process
-
- proc ::tcltest::setupbg args {
- if {$::tcltest::tktest == ""} {
- error "you're not running tktest so setupbg should not have been called"
- }
- if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} {
- cleanupbg
- }
-
- # The following code segment cannot be run on Windows in Tk8.1b2
- # This bug is logged as a pipe bug (bugID 1495).
-
- global tcl_platform
- if {$tcl_platform(platform) != "windows"} {
- set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+]
- puts $::tcltest::fd "puts foo; flush stdout"
- flush $::tcltest::fd
- if {[gets $::tcltest::fd data] < 0} {
- error "unexpected EOF from \"$::tcltest::tktest\""
- }
- if {[string compare $data foo]} {
- error "unexpected output from background process \"$data\""
- }
- fileevent $::tcltest::fd readable bgReady
- }
- }
-
- # Send a command to the background process, catching errors and
- # flushing I/O channels
-
- proc ::tcltest::dobg {command} {
- puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
- flush $::tcltest::fd
- set ::tcltest::bgDone 0
- set ::tcltest::bgData {}
- tkwait variable ::tcltest::bgDone
- set ::tcltest::bgData
- }
-
- # Data arrived from background process. Check for special marker
- # indicating end of data for this command, and make data available
- # to dobg procedure.
-
- proc ::tcltest::bgReady {} {
- set x [gets $::tcltest::fd]
- if {[eof $::tcltest::fd]} {
- fileevent $::tcltest::fd readable {}
- set ::tcltest::bgDone 1
- } elseif {$x == "**DONE**"} {
- set ::tcltest::bgDone 1
- } else {
- append ::tcltest::bgData $x
- }
- }
-
- # Exit the background process, and close the pipes
-
- proc ::tcltest::cleanupbg {} {
- catch {
- puts $::tcltest::fd "exit"
- close $::tcltest::fd
- }
- set ::tcltest::fd ""
- }
-
- # Clean up focus after using generate event, which
- # can leave the window manager with the wrong impression
- # about who thinks they have the focus. (BW)
-
- proc ::tcltest::fixfocus {} {
- catch {destroy .focus}
- toplevel .focus
- wm geometry .focus +0+0
- entry .focus.e
- .focus.e insert 0 "fixfocus"
- pack .focus.e
- update
- focus -force .focus.e
- destroy .focus
- }
-}
-
-# threadReap --
-#
-# Kill all threads except for the main thread.
-# Do nothing if testthread is not defined.
-#
-# Arguments:
-# none.
-#
-# Results:
-# Returns the number of existing threads.
-
-if {[info commands testthread] != {}} {
- proc ::tcltest::threadReap {} {
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != $::tcltest::mainThread} {
- catch {testthread send -async $tid {testthread exit}}
- update
- }
- }
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- }
-} else {
- proc ::tcltest::threadReap {} {
- return 1
- }
-}
-
-# Need to catch the import because it fails if defs.tcl is sourced
-# more than once.
-
-catch {namespace import ::tcltest::*}
-return
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
proc toutf {args} {
global x
}
# Some tests require the testencoding command
-
-set ::tcltest::testConstraints(testencoding) \
- [expr {[info commands testencoding] != {}}]
-
+testConstraint testencoding [llength [info commands testencoding]]
+testConstraint exec [llength [info commands exec]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
} {jis0208}
test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
- file mkdir tmp/encoding
- close [open tmp/encoding/junk.enc w]
- close [open tmp/encoding/junk2.enc w]
- cd tmp
+ cd [makeDirectory tmp]
+ makeDirectory [file join tmp encoding]
+ makeFile {} [file join tmp encoding junk.enc]
+ makeFile {} [file join tmp encoding junk2.enc]
set path [testencoding path]
testencoding path {}
catch {unset encodings}
}
}
testencoding path $path
- cd ..
- file delete -force tmp
+ cd [workingDirectory]
+ removeFile [file join tmp encoding junk2.enc]
+ removeFile [file join tmp encoding junk.enc]
+ removeDirectory [file join tmp encoding]
+ removeDirectory tmp
lsort $x
} {junk junk2}
} "512 \u4e4e"
test encoding-8.1 {Tcl_ExternalToUtf} {
- set f [open dummy w]
+ set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary -encoding iso8859-1
puts -nonewline $f "ab\x8c\xc1g"
close $f
- set f [open dummy r]
+ set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -encoding shiftjis
set x [read $f]
close $f
- file delete dummy
+ file delete [file join [temporaryDirectory] dummy]
set x
} "ab\u4e4eg"
} "1024 8C"
test encoding-10.1 {Tcl_UtfToExternal} {
- set f [open dummy w]
+ set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary -encoding shiftjis
puts -nonewline $f "ab\u4e4eg"
close $f
- set f [open dummy r]
+ set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -encoding iso8859-1
set x [read $f]
close $f
- file delete dummy
+ file delete [file join [temporaryDirectory] dummy]
set x
} "ab\x8c\xc1g"
+proc viewable {str} {
+ set res ""
+ foreach c [split $str {}] {
+ if {[string is print $c] && [string is ascii $c]} {
+ append res $c
+ } else {
+ append res "\\u[format %4.4x [scan $c %c]]"
+ }
+ }
+ return "$str ($res)"
+}
+
test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} {
set system [encoding system]
set path [testencoding path]
encoding convertfrom shiftjis \x8c\xc1
} "\u4e4e"
test encoding-11.5 {LoadEncodingFile: escape file} {
- encoding convertto iso2022 \u4e4e
-} "\x1b(B\x1b$@8C"
+ viewable [encoding convertto iso2022 \u4e4e]
+} [viewable "\x1b\$B8C\x1b(B"]
+test encoding-11.5.1 {LoadEncodingFile: escape file} {
+ viewable [encoding convertto iso2022-jp \u4e4e]
+} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
set system [encoding system]
set path [testencoding path]
encoding system identity
+ cd [temporaryDirectory]
testencoding path tmp
- file mkdir tmp/encoding
- set f [open tmp/encoding/splat.enc w]
+ makeDirectory tmp
+ makeDirectory [file join tmp encoding]
+ set f [open [file join tmp encoding splat.enc] w]
fconfigure $f -translation binary
puts $f "abcdefghijklmnop"
close $f
set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]
- file delete -force tmp
- catch {file delete encoding}
+ file delete [file join [temporaryDirectory] tmp encoding splat.enc]
+ removeDirectory [file join tmp encoding]
+ removeDirectory tmp
+ cd [workingDirectory]
testencoding path $path
encoding system $system
set x
} "\x67\x67\u3b3"
test encoding-13.1 {LoadEscapeTable} {
- set x [encoding convertto iso2022 ab\u4e4e\u68d9g]
-} "\x1b(Bab\x1b$@8C\x1b$\(DD%\x1b(Bg"
+ viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
+} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]
test encoding-14.1 {BinaryProc} {
encoding convertto identity \x12\x34\x56\xff\x69
test encoding-22.1 {EscapeFromUtfProc} {
} {}
+set ::iso2022encData "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B
+\u001b\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\u001b(B
+\u001b\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\u001b(B
+casino_japanese@___.com \u001b\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\u001b(B
+\u001b\$B\$7\$g\$&\$+!)\u001b(B"
+
+set ::iso2022uniData [encoding convertfrom iso2022-jp $::iso2022encData]
+set ::iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
+\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
+\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
+\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
+\u3057\u3087\u3046\u304b\uff1f"
+
+cd [temporaryDirectory]
+set fid [open iso2022.txt w]
+fconfigure $fid -encoding binary
+puts -nonewline $fid $::iso2022encData
+close $fid
+
+test encoding-23.2 {iso2022-jp escape encoding test} {
+ string equal $::iso2022uniData $::iso2022uniData2
+} 1
+test encoding-23.2 {iso2022-jp escape encoding test} {
+ # This checks that 'gets' isn't resetting the encoding inappropriately.
+ # [Bug #523988]
+ set fid [open iso2022.txt r]
+ fconfigure $fid -encoding iso2022-jp
+ set out ""
+ set count 0
+ while {[set num [gets $fid line]] >= 0} {
+ if {$count} {
+ incr count 1 ; # account for newline
+ append out \n
+ }
+ append out $line
+ incr count $num
+ }
+ close $fid
+ if {[string compare $::iso2022uniData $out]} {
+ return -code error "iso2022-jp read in doesn't match original"
+ }
+ list $count $out
+} [list [string length $::iso2022uniData] $::iso2022uniData]
+test encoding-23.3 {iso2022-jp escape encoding test} {
+ # read $fis <size> reads size in chars, not raw bytes.
+ set fid [open iso2022.txt r]
+ fconfigure $fid -encoding iso2022-jp
+ set data [read $fid 50]
+ close $fid
+ set data
+} [string range $::iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
+cd [workingDirectory]
+
+test encoding-24.1 {EscapeFreeProc on open channels} -constraints {
+ exec
+} -setup {
+ # Bug #524674 input
+ set file [makeFile {
+ set f [open [file join [file dirname [info script]] iso2022.txt]]
+ fconfigure $f -encoding iso2022-jp
+ gets $f
+ } iso2022.tcl]
+} -body {
+ exec [interpreter] $file
+} -cleanup {
+ removeFile iso2022.tcl
+} -result {}
+
+test encoding-24.2 {EscapeFreeProc on open channels} -constraints {
+ exec
+} -setup {
+ # Bug #524674 output
+ set file [makeFile {
+ fconfigure stdout -encoding iso2022-jp
+ puts ab\u4e4e\u68d9g
+ exit
+ } iso2022.tcl]
+} -body {
+ viewable [exec [interpreter] $file]
+} -cleanup {
+ removeFile iso2022.tcl
+} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
+
+test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
+ # Bug #219314 - if we don't free escape encodings correctly on
+ # channel closure, we go boom
+ set file [makeFile {
+ encoding system iso2022-jp
+ set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
+ puts $a
+ } iso2022.tcl]
+ set f [open "|[list [interpreter] $file]"]
+ fconfigure $f -encoding iso2022-jp
+ set count [gets $f line]
+ close $f
+ removeFile iso2022.tcl
+ list $count [viewable $line]
+} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"]
+
+file delete [file join [temporaryDirectory] iso2022.txt]
+
# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
#
# These tests will run on any platform (and indeed crashed
# Some tests require the "exec" command.
# Skip them if exec is not defined.
-set ::tcltest::testConstraints(execCommandExists) [expr {[info commands exec] != ""}]
+testConstraint exec [llength [info commands exec]]
-set f [open printenv w]
-puts $f {
+set printenvScript [makeFile {
proc lrem {listname name} {
upvar $listname list
set i [lsearch $list $name]
puts "$p=$env($p)"
}
exit
-}
-close $f
+} printenv]
+# [exec] is required here to see the actual environment received
+# by child processes.
proc getenv {} {
- global printenv tcltest
- catch {exec $::tcltest::tcltest printenv} out
+ global printenvScript tcltest
+ catch {exec [interpreter] $printenvScript} out
if {$out == "child process exited abnormally"} {
set out {}
}
}
}
-test env-2.1 {adding environment variables} {execCommandExists} {
+test env-2.1 {adding environment variables} {exec} {
getenv
} {}
set env(NAME1) "test string"
-test env-2.2 {adding environment variables} {execCommandExists} {
+test env-2.2 {adding environment variables} {exec} {
getenv
} {NAME1=test string}
set env(NAME2) "more"
-test env-2.3 {adding environment variables} {execCommandExists} {
+test env-2.3 {adding environment variables} {exec} {
getenv
} {NAME1=test string
NAME2=more}
set env(XYZZY) "garbage"
-test env-2.4 {adding environment variables} {execCommandExists} {
+test env-2.4 {adding environment variables} {exec} {
getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}
set env(NAME2) "new value"
-test env-3.1 {changing environment variables} {execCommandExists} {
+test env-3.1 {changing environment variables} {exec} {
set result [getenv]
unset env(NAME2)
set result
NAME2=new value
XYZZY=garbage}
-test env-4.1 {unsetting environment variables} {execCommandExists} {
+test env-4.1 {unsetting environment variables} {exec} {
set result [getenv]
unset env(NAME1)
set result
} {NAME1=test string
XYZZY=garbage}
-test env-4.2 {unsetting environment variables} {execCommandExists} {
+test env-4.2 {unsetting environment variables} {exec} {
set result [getenv]
unset env(XYZZY)
set result
} {XYZZY=garbage}
-test env-4.3 {setting international environment variables} {execCommandExists} {
+test env-4.3 {setting international environment variables} {exec} {
set env(\ua7) \ub6
getenv
} "\ua7=\ub6"
-test env-4.4 {changing international environment variables} {execCommandExists} {
+test env-4.4 {changing international environment variables} {exec} {
set env(\ua7) \ua7
getenv
} "\ua7=\ua7"
-test env-4.5 {unsetting international environment variables} {execCommandExists} {
+test env-4.5 {unsetting international environment variables} {exec} {
set env(\ub6) \ua7
unset env(\ua7)
set result [getenv]
interp create i
i eval { unset env }
i eval { set env(THIS_SHOULDNT_EXIST) a}
- set result [info exist env(THIS_SHOULDNT_EXIST)]
+ set result [info exists env(THIS_SHOULDNT_EXIST)]
interp delete i
set result
} {0}
set result
} {a 1}
test env-5.4 {corner cases - unset the env array} {} {
- # The info exist command should be in synch with the env array.
+ # The info exists command should be in synch with the env array.
# Know Bug: 1737
interp create i
}
# cleanup
-file delete printenv
+removeFile $printenvScript
::tcltest::cleanupTests
return
-
test error-1.3 {simple errors from commands} {
catch {format [string index]} b
set errorInfo
+ # this used to return '... while executing ...', but
+ # string index is fully compiled as of 8.4a3
} {wrong # args: should be "string index string charIndex"
while executing
"string index"}
catch {rename p ""}
::tcltest::cleanupTests
return
-
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
-set ::tcltest::testConstraints(testfilehandler) \
- [expr {[info commands testfilehandler] != {}}]
-set ::tcltest::testConstraints(testexithandler) \
- [expr {[info commands testexithandler] != {}}]
-set ::tcltest::testConstraints(testfilewait) \
- [expr {[info commands testfilewait] != {}}]
+testConstraint testfilehandler [llength [info commands testfilehandler]]
+testConstraint testexithandler [llength [info commands testexithandler]]
+testConstraint testfilewait [llength [info commands testfilewait]]
test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {
testfilehandler close
set x {}
update idletasks
rename bgerror {}
+ regsub -all [file join {} non_existent] $x "non_existent" x
set x
} {{{a simple error} {a simple error
while executing
test event-6.1 {BgErrorDeleteProc procedure} {
catch {interp delete foo}
interp create foo
+ set erroutfile [makeFile Unmodified err.out]
+ foo eval [list set erroutfile $erroutfile]
foo eval {
proc bgerror args {
- global errorInfo
- set f [open err.out r+]
+ global errorInfo erroutfile
+ set f [open $erroutfile r+]
seek $f 0 end
puts $f "$args $errorInfo"
close $f
after 100 {error "first error"}
after 100 {error "second error"}
}
- makeFile Unmodified err.out
after 100 {interp delete foo}
after 200
update
- set f [open err.out r]
+ set f [open $erroutfile r]
set result [read $f]
close $f
- removeFile err.out
+ removeFile $erroutfile
set result
} {Unmodified
}
set errRes
} bg:err1
+testConstraint exec [llength [info commands exec]]
+
+test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {
+ set script {
+ after 1000 error hello
+ after 2000 set a 0
+ vwait a
+ }
+
+ list [catch {exec [interpreter] << $script} errMsg] $errMsg
+} {1 {hello
+ while executing
+"error hello"
+ ("after" script)}}
+
+
# someday : add a test checking that
# when there is no bgerror, an error msg goes to stderr
# ideally one would use sub interp and transfer a fake stderr
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
- set child [open |[list [info nameofexecutable]] r+]
+ set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
- set child [open |[list [info nameofexecutable]] r+]
+ set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
- set child [open |[list [info nameofexecutable]] r+]
+ set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
- set child [open |[list [info nameofexecutable]] r+]
+ set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
- set child [open |[list [info nameofexecutable]] r+]
+ set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
}
test event-10.1 {Tcl_Exit procedure} {stdio} {
- set child [open |[list [info nameofexecutable]] r+]
+ set child [open |[list [interpreter]] r+]
puts $child "exit 3"
list [catch {close $child} msg] $msg [lindex $errorCode 0] \
[lindex $errorCode 2]
}
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
- set f1 [open test1 w]
+ set test1file [makeFile "" test1]
+ set f1 [open $test1file w]
proc accept {s args} {
puts $s foobar
close $s
}
- catch {set s1 [socket -server accept 5001]}
+ catch {set s1 [socket -server accept 0]}
after 1000
- catch {set s2 [socket 127.0.0.1 5001]}
+ catch {set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]}
close $s1
set x 0
set y 0
set z 0
- fileevent $s2 readable { incr z }
+ fileevent $s2 readable {incr z}
vwait z
- fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
- fileevent $s2 readable { incr y; if { $x == 3 } { set z done } }
+ fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
+ fileevent $s2 readable {incr y; if {$x == 3} {set z done}}
vwait z
close $f1
close $s2
- file delete test1 test2
+ removeFile $test1file
list $x $y $z
} {3 3 done}
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
- file delete test1 test2
- set f1 [open test1 w]
- set f2 [open test2 w]
+ set test1file [makeFile "" test1]
+ set test2file [makeFile "" test2]
+ set f1 [open $test1file w]
+ set f2 [open $test2file w]
set x 0
set y 0
set z 0
update
- fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
- fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
+ fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
+ fileevent $f2 writable {incr y; if {$x == 3} {set z done}}
vwait z
close $f1
close $f2
- file delete test1 test2
+ removeFile $test1file
+ removeFile $test2file
list $x $y $z
} {3 3 done}
}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
# All tests require the "exec" command.
# Skip them if exec is not defined.
-set ::tcltest::testConstraints(execCommandExists) [expr {[info commands exec] != ""}]
+testConstraint exec [llength [info commands exec]]
-set f [open echo w]
-puts $f {
+set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
}
puts {}
exit
-}
-close $f
+} echo]
-set f [open cat w]
-puts $f {
+set path(cat) [makeFile {
if {$argv == {}} {
set argv -
}
}
}
exit
-}
-close $f
+} cat]
-set f [open wc w]
-puts $f {
+set path(wc) [makeFile {
set data [read stdin]
set lines [regsub -all "\n" $data {} dummy]
set words [regsub -all "\[^ \t\n]+" $data {} dummy]
set chars [string length $data]
puts [format "%8.d%8.d%8.d" $lines $words $chars]
exit
-}
-close $f
+} wc]
-set f [open sh w]
-puts $f {
+set path(sh) [makeFile {
if {[lindex $argv 0] != "-c"} {
error "sh: unexpected arguments $argv"
}
lappend newcmd $arg
}
exit
-}
-close $f
+} sh]
-set f [open sleep w]
-puts $f {
+set path(sleep) [makeFile {
after [expr $argv*1000]
exit
-}
-close $f
+} sleep]
-set f [open exit w]
-puts $f {
+set path(exit) [makeFile {
exit $argv
-}
-close $f
+} exit]
# Basic operations.
-test exec-1.1 {basic exec operation} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo a b c
+test exec-1.1 {basic exec operation} {exec} {
+ exec [interpreter] $path(echo) a b c
} "a b c"
-test exec-1.2 {pipelining} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo a b c d | $::tcltest::tcltest cat | $::tcltest::tcltest cat
+test exec-1.2 {pipelining} {exec stdio} {
+ exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(cat)
} "a b c d"
-test exec-1.3 {pipelining} {execCommandExists stdio} {
- set a [exec $::tcltest::tcltest echo a b c d | $::tcltest::tcltest cat | $::tcltest::tcltest wc]
+test exec-1.3 {pipelining} {exec stdio} {
+ set a [exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(wc)]
list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
-test exec-1.4 {long command lines} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo $arg
+test exec-1.4 {long command lines} {exec} {
+ exec [interpreter] $path(echo) $arg
} $arg
set arg {}
# I/O redirection: input from Tcl command.
-test exec-2.1 {redirecting input from immediate source} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat << "Sample text"
+test exec-2.1 {redirecting input from immediate source} {exec stdio} {
+ exec [interpreter] $path(cat) << "Sample text"
} {Sample text}
-test exec-2.2 {redirecting input from immediate source} {execCommandExists stdio} {
- exec << "Sample text" $::tcltest::tcltest cat | $::tcltest::tcltest cat
+test exec-2.2 {redirecting input from immediate source} {exec stdio} {
+ exec << "Sample text" [interpreter] $path(cat) | [interpreter] $path(cat)
} {Sample text}
-test exec-2.3 {redirecting input from immediate source} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat << "Sample text" | $::tcltest::tcltest cat
+test exec-2.3 {redirecting input from immediate source} {exec stdio} {
+ exec [interpreter] $path(cat) << "Sample text" | [interpreter] $path(cat)
} {Sample text}
-test exec-2.4 {redirecting input from immediate source} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat | $::tcltest::tcltest cat << "Sample text"
+test exec-2.4 {redirecting input from immediate source} {exec stdio} {
+ exec [interpreter] $path(cat) | [interpreter] $path(cat) << "Sample text"
} {Sample text}
-test exec-2.5 {redirecting input from immediate source} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat "<<Joined to arrows"
+test exec-2.5 {redirecting input from immediate source} {exec} {
+ exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
-test exec-2.6 {redirecting input from immediate source, with UTF} {execCommandExists stdio} {
+test exec-2.6 {redirecting input from immediate source, with UTF} {exec} {
# If this fails, it may give back:
# "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
# If it does, this means that the UTF -> external conversion did not
# occur before writing out the temp file.
- exec $::tcltest::tcltest cat << "\uE9\uE0\uFC\uF1"
+ exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"
} "\uE9\uE0\uFC\uF1"
# I/O redirection: output to file.
-file delete gorp.file
-test exec-3.1 {redirecting output to file} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "Some simple words" > gorp.file
- exec $::tcltest::tcltest cat gorp.file
+set path(gorp.file) [makeFile {} gorp.file]
+removeFile gorp.file
+
+test exec-3.1 {redirecting output to file} {exec} {
+ exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file)
+ exec [interpreter] $path(cat) $path(gorp.file)
} "Some simple words"
-test exec-3.2 {redirecting output to file} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "More simple words" | >gorp.file $::tcltest::tcltest cat | $::tcltest::tcltest cat
- exec $::tcltest::tcltest cat gorp.file
+test exec-3.2 {redirecting output to file} {exec stdio} {
+ exec [interpreter] $path(echo) "More simple words" | >$path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
+ exec [interpreter] $path(cat) $path(gorp.file)
} "More simple words"
-test exec-3.3 {redirecting output to file} {execCommandExists stdio} {
- exec > gorp.file $::tcltest::tcltest echo "Different simple words" | $::tcltest::tcltest cat | $::tcltest::tcltest cat
- exec $::tcltest::tcltest cat gorp.file
+test exec-3.3 {redirecting output to file} {exec stdio} {
+ exec > $path(gorp.file) [interpreter] $path(echo) "Different simple words" | [interpreter] $path(cat) | [interpreter] $path(cat)
+ exec [interpreter] $path(cat) $path(gorp.file)
} "Different simple words"
-test exec-3.4 {redirecting output to file} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "Some simple words" >gorp.file
- exec $::tcltest::tcltest cat gorp.file
+test exec-3.4 {redirecting output to file} {exec} {
+ exec [interpreter] $path(echo) "Some simple words" >$path(gorp.file)
+ exec [interpreter] $path(cat) $path(gorp.file)
} "Some simple words"
-test exec-3.5 {redirecting output to file} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "First line" >gorp.file
- exec $::tcltest::tcltest echo "Second line" >> gorp.file
- exec $::tcltest::tcltest cat gorp.file
+test exec-3.5 {redirecting output to file} {exec} {
+ exec [interpreter] $path(echo) "First line" >$path(gorp.file)
+ exec [interpreter] $path(echo) "Second line" >> $path(gorp.file)
+ exec [interpreter] $path(cat) $path(gorp.file)
} "First line\nSecond line"
-test exec-3.6 {redirecting output to file} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "First line" >gorp.file
- exec $::tcltest::tcltest echo "Second line" >>gorp.file
- exec $::tcltest::tcltest cat gorp.file
+test exec-3.6 {redirecting output to file} {exec} {
+ exec [interpreter] $path(echo) "First line" >$path(gorp.file)
+ exec [interpreter] $path(echo) "Second line" >>$path(gorp.file)
+ exec [interpreter] $path(cat) $path(gorp.file)
} "First line\nSecond line"
-test exec-3.7 {redirecting output to file} {execCommandExists stdio} {
- set f [open gorp.file w]
+test exec-3.7 {redirecting output to file} {exec} {
+ set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
- exec $::tcltest::tcltest echo "More text" >@ $f
- exec $::tcltest::tcltest echo >@$f "Even more"
+ exec [interpreter] $path(echo) "More text" >@ $f
+ exec [interpreter] $path(echo) >@$f "Even more"
puts $f "Line 3"
close $f
- exec $::tcltest::tcltest cat gorp.file
+ exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nMore text\nEven more\nLine 3"
# I/O redirection: output and stderr to file.
-file delete gorp.file
-test exec-4.1 {redirecting output and stderr to file} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "test output" >& gorp.file
- exec $::tcltest::tcltest cat gorp.file
+removeFile gorp.file
+
+test exec-4.1 {redirecting output and stderr to file} {exec} {
+ exec [interpreter] $path(echo) "test output" >& $path(gorp.file)
+ exec [interpreter] $path(cat) $path(gorp.file)
} "test output"
-test exec-4.2 {redirecting output and stderr to file} {execCommandExists stdio} {
- list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" >&gorp.file] \
- [exec $::tcltest::tcltest cat gorp.file]
+test exec-4.2 {redirecting output and stderr to file} {exec} {
+ list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" >&$path(gorp.file)] \
+ [exec [interpreter] $path(cat) $path(gorp.file)]
} {{} {foo bar}}
-test exec-4.3 {redirecting output and stderr to file} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "first line" > gorp.file
- list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" >>&gorp.file] \
- [exec $::tcltest::tcltest cat gorp.file]
+test exec-4.3 {redirecting output and stderr to file} {exec} {
+ exec [interpreter] $path(echo) "first line" > $path(gorp.file)
+ list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" >>&$path(gorp.file)] \
+ [exec [interpreter] $path(cat) $path(gorp.file)]
} "{} {first line\nfoo bar}"
-test exec-4.4 {redirecting output and stderr to file} {execCommandExists stdio} {
- set f [open gorp.file w]
+test exec-4.4 {redirecting output and stderr to file} {exec} {
+ set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
- exec $::tcltest::tcltest echo "More text" >&@ $f
- exec $::tcltest::tcltest echo >&@$f "Even more"
+ exec [interpreter] $path(echo) "More text" >&@ $f
+ exec [interpreter] $path(echo) >&@$f "Even more"
puts $f "Line 3"
close $f
- exec $::tcltest::tcltest cat gorp.file
+ exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nMore text\nEven more\nLine 3"
-test exec-4.5 {redirecting output and stderr to file} {execCommandExists stdio} {
- set f [open gorp.file w]
+test exec-4.5 {redirecting output and stderr to file} {exec} {
+ set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
- exec >&@ $f $::tcltest::tcltest sh -c "echo foo bar 1>&2"
- exec >&@$f $::tcltest::tcltest sh -c "echo xyzzy 1>&2"
+ exec >&@ $f [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2"
+ exec >&@$f [interpreter] $path(sh) -c "$path(echo) xyzzy 1>&2"
puts $f "Line 3"
close $f
- exec $::tcltest::tcltest cat gorp.file
+ exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nfoo bar\nxyzzy\nLine 3"
# I/O redirection: input from file.
-exec $::tcltest::tcltest echo "Just a few thoughts" > gorp.file
-test exec-5.1 {redirecting input from file} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat < gorp.file
+if { [set ::tcltest::testConstraints(exec)] } {
+exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file)
+}
+test exec-5.1 {redirecting input from file} {exec} {
+ exec [interpreter] $path(cat) < $path(gorp.file)
} {Just a few thoughts}
-test exec-5.2 {redirecting input from file} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat | $::tcltest::tcltest cat < gorp.file
+test exec-5.2 {redirecting input from file} {exec stdio} {
+ exec [interpreter] $path(cat) | [interpreter] $path(cat) < $path(gorp.file)
} {Just a few thoughts}
-test exec-5.3 {redirecting input from file} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat < gorp.file | $::tcltest::tcltest cat
+test exec-5.3 {redirecting input from file} {exec stdio} {
+ exec [interpreter] $path(cat) < $path(gorp.file) | [interpreter] $path(cat)
} {Just a few thoughts}
-test exec-5.4 {redirecting input from file} {execCommandExists stdio} {
- exec < gorp.file $::tcltest::tcltest cat | $::tcltest::tcltest cat
+test exec-5.4 {redirecting input from file} {exec stdio} {
+ exec < $path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
} {Just a few thoughts}
-test exec-5.5 {redirecting input from file} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat <gorp.file
+test exec-5.5 {redirecting input from file} {exec} {
+ exec [interpreter] $path(cat) <$path(gorp.file)
} {Just a few thoughts}
-test exec-5.6 {redirecting input from file} {execCommandExists stdio} {
- set f [open gorp.file r]
- set result [exec $::tcltest::tcltest cat <@ $f]
+test exec-5.6 {redirecting input from file} {exec} {
+ set f [open $path(gorp.file) r]
+ set result [exec [interpreter] $path(cat) <@ $f]
close $f
set result
} {Just a few thoughts}
-test exec-5.7 {redirecting input from file} {execCommandExists stdio} {
- set f [open gorp.file r]
- set result [exec <@$f $::tcltest::tcltest cat]
+test exec-5.7 {redirecting input from file} {exec} {
+ set f [open $path(gorp.file) r]
+ set result [exec <@$f [interpreter] $path(cat)]
close $f
set result
} {Just a few thoughts}
# I/O redirection: standard error through a pipeline.
-test exec-6.1 {redirecting stderr through a pipeline} {execCommandExists stdio} {
- exec $::tcltest::tcltest sh -c "echo foo bar" |& $::tcltest::tcltest cat
+test exec-6.1 {redirecting stderr through a pipeline} {exec stdio} {
+ exec [interpreter] $path(sh) -c "$path(echo) foo bar" |& [interpreter] $path(cat)
} "foo bar"
-test exec-6.2 {redirecting stderr through a pipeline} {execCommandExists stdio} {
- exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" |& $::tcltest::tcltest cat
+test exec-6.2 {redirecting stderr through a pipeline} {exec stdio} {
+ exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" |& [interpreter] $path(cat)
} "foo bar"
-test exec-6.3 {redirecting stderr through a pipeline} {execCommandExists stdio} {
- exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" \
- |& $::tcltest::tcltest sh -c "echo second msg 1>&2 ; cat" |& $::tcltest::tcltest cat
+test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
+ exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
+ |& [interpreter] $path(sh) -c "$path(echo) second msg 1>&2 ; $path(cat)" |& [interpreter] $path(cat)
} "second msg\nfoo bar"
# I/O redirection: combinations.
-file delete gorp.file2
-test exec-7.1 {multiple I/O redirections} {execCommandExists stdio} {
- exec << "command input" > gorp.file2 $::tcltest::tcltest cat < gorp.file
- exec $::tcltest::tcltest cat gorp.file2
+set path(gorp.file2) [makeFile {} gorp.file2]
+removeFile gorp.file2
+
+test exec-7.1 {multiple I/O redirections} {exec} {
+ exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
+ exec [interpreter] $path(cat) $path(gorp.file2)
} {Just a few thoughts}
-test exec-7.2 {multiple I/O redirections} {execCommandExists stdio} {
- exec < gorp.file << "command input" $::tcltest::tcltest cat
+test exec-7.2 {multiple I/O redirections} {exec} {
+ exec < $path(gorp.file) << "command input" [interpreter] $path(cat)
} {command input}
# Long input to command and output from command.
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
-test exec-8.1 {long input and output} {execCommandExists stdio} {
- exec $::tcltest::tcltest cat << $a
+test exec-8.1 {long input and output} {exec} {
+ exec [interpreter] $path(cat) << $a
} $a
# More than 20 arguments to exec.
-test exec-8.1 {long input and output} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
+test exec-8.2 {long input and output} {exec} {
+ exec [interpreter] $path(echo) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
# Commands that return errors.
-test exec-9.1 {commands returning errors} {execCommandExists stdio} {
+test exec-9.1 {commands returning errors} {exec} {
set x [catch {exec gorp456} msg]
list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
-test exec-9.2 {commands returning errors} {execCommandExists stdio} {
- string tolower [list [catch {exec $::tcltest::tcltest echo foo | foo123} msg] $msg $errorCode]
+test exec-9.2 {commands returning errors} {exec} {
+ string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
-test exec-9.3 {commands returning errors} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest sleep 1 | $::tcltest::tcltest exit 43 | $::tcltest::tcltest sleep 1} msg] $msg
+test exec-9.3 {commands returning errors} {exec stdio} {
+ list [catch {exec [interpreter] $path(sleep) 1 | [interpreter] $path(exit) 43 | [interpreter] $path(sleep) 1} msg] $msg
} {1 {child process exited abnormally}}
-test exec-9.4 {commands returning errors} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest exit 43 | $::tcltest::tcltest echo "foo bar"} msg] $msg
+test exec-9.4 {commands returning errors} {exec stdio} {
+ list [catch {exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
-test exec-9.5 {commands returning errors} {execCommandExists stdio} {
- list [catch {exec gorp456 | $::tcltest::tcltest echo a b c} msg] [string tolower $msg]
+test exec-9.5 {commands returning errors} {exec stdio} {
+ list [catch {exec gorp456 | [interpreter] echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
-test exec-9.6 {commands returning errors} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest sh -c "echo error msg 1>&2"} msg] $msg
+test exec-9.6 {commands returning errors} {exec} {
+ list [catch {exec [interpreter] $path(sh) -c "$path(echo) error msg 1>&2"} msg] $msg
} {1 {error msg}}
-test exec-9.7 {commands returning errors} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest sh -c "echo error msg 1>&2" \
- | $::tcltest::tcltest sh -c "echo error msg 1>&2"} msg] $msg
+test exec-9.7 {commands returning errors} {exec stdio} {
+ list [catch {exec [interpreter] $path(sh) -c "$path(echo) error msg 1>&2" \
+ | [interpreter] $path(sh) -c "$path(echo) error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}
-test exec-9.8 {commands returning errors} {execCommandExists stdio} {
- set f [open err w]
+
+set path(err) [makeFile {} err]
+
+test exec-9.8 {commands returning errors} {exec} {
+ set f [open $path(err) w]
puts $f {
puts stdout out
puts stderr err
}
close $f
- list [catch {exec $::tcltest::tcltest err} msg] $msg
+ list [catch {exec [interpreter] $path(err)} msg] $msg
} {1 {out
err}}
# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.
-test exec-10.1 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.1 {errors in exec invocation} {exec} {
list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
-test exec-10.2 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.2 {errors in exec invocation} {exec} {
list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
-test exec-10.3 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.3 {errors in exec invocation} {exec} {
list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
-test exec-10.4 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.4 {errors in exec invocation} {exec} {
list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
-test exec-10.5 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.5 {errors in exec invocation} {exec} {
list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
-test exec-10.6 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.6 {errors in exec invocation} {exec} {
list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
-test exec-10.7 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.7 {errors in exec invocation} {exec} {
list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
-test exec-10.8 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.8 {errors in exec invocation} {exec} {
list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
-test exec-10.9 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.9 {errors in exec invocation} {exec} {
list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
-test exec-10.10 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.10 {errors in exec invocation} {exec} {
list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
-test exec-10.11 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.11 {errors in exec invocation} {exec} {
list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
-test exec-10.12 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.12 {errors in exec invocation} {exec} {
list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
-test exec-10.13 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.13 {errors in exec invocation} {exec} {
list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
-test exec-10.14 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.14 {errors in exec invocation} {exec} {
list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
-test exec-10.15 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.15 {errors in exec invocation} {exec} {
list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
-test exec-10.16 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.16 {errors in exec invocation} {exec} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
-test exec-10.17 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.17 {errors in exec invocation} {exec} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
-set f [open gorp.file w]
-test exec-10.18 {errors in exec invocation} {execCommandExists stdio} {
+set f [open $path(gorp.file) w]
+test exec-10.18 {errors in exec invocation} {exec} {
list [catch {exec cat <@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for reading}"
close $f
-set f [open gorp.file r]
-test exec-10.19 {errors in exec invocation} {execCommandExists stdio} {
+set f [open $path(gorp.file) r]
+test exec-10.19 {errors in exec invocation} {exec} {
list [catch {exec cat >@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for writing}"
close $f
-test exec-10.20 {errors in exec invocation} {execCommandExists stdio} {
+test exec-10.20 {errors in exec invocation} {exec} {
list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
-test exec-10.21 {errors in exec invocation} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest true | ~xyzzy_bad_user/x | false} msg] $msg
+test exec-10.21 {errors in exec invocation} {exec} {
+ list [catch {exec [interpreter] true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}
# Commands in background.
-test exec-11.1 {commands in background} {execCommandExists stdio} {
- set x [lindex [time {exec $::tcltest::tcltest sleep 2 &}] 0]
+test exec-11.1 {commands in background} {exec} {
+ set x [lindex [time {exec [interpreter] $path(sleep) 2 &}] 0]
expr $x<1000000
} 1
-test exec-11.2 {commands in background} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest echo a &b} msg] $msg
+test exec-11.2 {commands in background} {exec} {
+ list [catch {exec [interpreter] $path(echo) a &b} msg] $msg
} {0 {a &b}}
-test exec-11.3 {commands in background} {execCommandExists stdio} {
- llength [exec $::tcltest::tcltest sleep 1 &]
+test exec-11.3 {commands in background} {exec} {
+ llength [exec [interpreter] $path(sleep) 1 &]
} 1
-test exec-11.4 {commands in background} {execCommandExists stdio} {
- llength [exec $::tcltest::tcltest sleep 1 | $::tcltest::tcltest sleep 1 | $::tcltest::tcltest sleep 1 &]
+test exec-11.4 {commands in background} {exec stdio} {
+ llength [exec [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 &]
} 3
-test exec-11.5 {commands in background} {execCommandExists stdio} {
- set f [open gorp.file w]
- puts $f { catch { exec [info nameofexecutable] echo foo & } }
+test exec-11.5 {commands in background} {exec} {
+ set f [open $path(gorp.file) w]
+ puts $f [format { catch { exec [info nameofexecutable] %s foo & } } $path(echo)]
close $f
- string compare "foo" [exec $::tcltest::tcltest gorp.file]
+ string compare "foo" [exec [interpreter] $path(gorp.file)]
} 0
# Make sure that background commands are properly reaped when
# they eventually die.
-exec $::tcltest::tcltest sleep 3
+if { [set ::tcltest::testConstraints(exec)] } {
+exec [interpreter] $path(sleep) 3
+}
test exec-12.1 {reaping background processes} \
- {execCommandExists stdio unixOnly nonPortable} {
+ {exec unixOnly nonPortable} {
for {set i 0} {$i < 20} {incr i} {
exec echo foo > /dev/null &
}
lindex $msg 0
} 0
test exec-12.2 {reaping background processes} \
- {execCommandExists stdio unixOnly nonPortable} {
+ {exec unixOnly nonPortable} {
exec sleep 2 | sleep 2 | sleep 2 &
catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
set x [lindex $msg 0]
list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} \
- {execCommandExists stdio unixOnly nonPortable} {
+ {exec unixOnly nonPortable} {
exec sleep 1000 &
exec sleep 1000 &
set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
# Make sure "errorCode" is set correctly.
-test exec-13.1 {setting errorCode variable} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest cat < a/b/c} msg] [string tolower $errorCode]
+test exec-13.1 {setting errorCode variable} {exec} {
+ list [catch {exec [interpreter] $path(cat) < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
-test exec-13.2 {setting errorCode variable} {execCommandExists stdio} {
- list [catch {exec $::tcltest::tcltest cat > a/b/c} msg] [string tolower $errorCode]
+test exec-13.2 {setting errorCode variable} {exec} {
+ list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
-test exec-13.3 {setting errorCode variable} {execCommandExists stdio} {
+test exec-13.3 {setting errorCode variable} {exec} {
set x [catch {exec _weird_cmd_} msg]
list $x [string tolower $msg] [lindex $errorCode 0] \
[string tolower [lrange $errorCode 2 end]]
# Switches before the first argument
-test exec-14.1 {-keepnewline switch} {execCommandExists stdio} {
- exec -keepnewline $::tcltest::tcltest echo foo
+test exec-14.1 {-keepnewline switch} {exec} {
+ exec -keepnewline [interpreter] $path(echo) foo
} "foo\n"
-test exec-14.2 {-keepnewline switch} {execCommandExists stdio} {
+test exec-14.2 {-keepnewline switch} {exec} {
list [catch {exec -keepnewline} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
-test exec-14.3 {unknown switch} {execCommandExists stdio} {
+test exec-14.3 {unknown switch} {exec} {
list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
-test exec-14.4 {-- switch} {execCommandExists stdio} {
+test exec-14.4 {-- switch} {exec} {
list [catch {exec -- -gorp} msg] [string tolower $msg]
} {1 {couldn't execute "-gorp": no such file or directory}}
# Redirecting standard error separately from standard output
-test exec-15.1 {standard error redirection} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "First line" > gorp.file
- list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" 2> gorp.file] \
- [exec $::tcltest::tcltest cat gorp.file]
+test exec-15.1 {standard error redirection} {exec} {
+ exec [interpreter] $path(echo) "First line" > $path(gorp.file)
+ list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2> $path(gorp.file)] \
+ [exec [interpreter] $path(cat) $path(gorp.file)]
} {{} {foo bar}}
-test exec-15.2 {standard error redirection} {execCommandExists stdio} {
- list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" \
- | $::tcltest::tcltest echo biz baz >gorp.file 2> gorp.file2] \
- [exec $::tcltest::tcltest cat gorp.file] \
- [exec $::tcltest::tcltest cat gorp.file2]
+test exec-15.2 {standard error redirection} {exec stdio} {
+ list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
+ | [interpreter] $path(echo) biz baz >$path(gorp.file) 2> $path(gorp.file2)] \
+ [exec [interpreter] $path(cat) $path(gorp.file)] \
+ [exec [interpreter] $path(cat) $path(gorp.file2)]
} {{} {biz baz} {foo bar}}
-test exec-15.3 {standard error redirection} {execCommandExists stdio} {
- list [exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" \
- | $::tcltest::tcltest echo biz baz 2>gorp.file > gorp.file2] \
- [exec $::tcltest::tcltest cat gorp.file] \
- [exec $::tcltest::tcltest cat gorp.file2]
+test exec-15.3 {standard error redirection} {exec stdio} {
+ list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
+ | [interpreter] $path(echo) biz baz 2>$path(gorp.file) > $path(gorp.file2)] \
+ [exec [interpreter] $path(cat) $path(gorp.file)] \
+ [exec [interpreter] $path(cat) $path(gorp.file2)]
} {{} {foo bar} {biz baz}}
-test exec-15.4 {standard error redirection} {execCommandExists stdio} {
- set f [open gorp.file w]
+test exec-15.4 {standard error redirection} {exec} {
+ set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
- exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" 2>@ $f
+ exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2>@ $f
puts $f "Line 3"
close $f
- exec $::tcltest::tcltest cat gorp.file
+ exec [interpreter] $path(cat) $path(gorp.file)
} {Line 1
foo bar
Line 3}
-test exec-15.5 {standard error redirection} {execCommandExists stdio} {
- exec $::tcltest::tcltest echo "First line" > gorp.file
- exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" 2>> gorp.file
- exec $::tcltest::tcltest cat gorp.file
+test exec-15.5 {standard error redirection} {exec} {
+ exec [interpreter] $path(echo) "First line" > $path(gorp.file)
+ exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2>> $path(gorp.file)
+ exec [interpreter] $path(cat) $path(gorp.file)
} {First line
foo bar}
-test exec-15.6 {standard error redirection} {execCommandExists stdio} {
- exec $::tcltest::tcltest sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \
- >& gorp.file 2> gorp.file2 | $::tcltest::tcltest echo biz baz
- list [exec $::tcltest::tcltest cat gorp.file] [exec $::tcltest::tcltest cat gorp.file2]
+test exec-15.6 {standard error redirection} {exec stdio} {
+ exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" > $path(gorp.file2) 2> $path(gorp.file) \
+ >& $path(gorp.file) 2> $path(gorp.file2) | [interpreter] $path(echo) biz baz
+ list [exec [interpreter] $path(cat) $path(gorp.file)] [exec [interpreter] $path(cat) $path(gorp.file2)]
} {{biz baz} {foo bar}}
-test exec-16.1 {flush output before exec} {execCommandExists stdio} {
- set f [open gorp.file w]
+test exec-16.1 {flush output before exec} {exec} {
+ set f [open $path(gorp.file) w]
puts $f "First line"
- exec $::tcltest::tcltest echo "Second line" >@ $f
+ exec [interpreter] $path(echo) "Second line" >@ $f
puts $f "Third line"
close $f
- exec $::tcltest::tcltest cat gorp.file
+ exec [interpreter] $path(cat) $path(gorp.file)
} {First line
Second line
Third line}
-test exec-16.2 {flush output before exec} {execCommandExists stdio} {
- set f [open gorp.file w]
+test exec-16.2 {flush output before exec} {exec} {
+ set f [open $path(gorp.file) w]
puts $f "First line"
- exec $::tcltest::tcltest << {puts stderr {Second line}} >&@ $f > gorp.file2
+ exec [interpreter] << {puts stderr {Second line}} >&@ $f > $path(gorp.file2)
puts $f "Third line"
close $f
- exec $::tcltest::tcltest cat gorp.file
+ exec [interpreter] $path(cat) $path(gorp.file)
} {First line
Second line
Third line}
-test exec-17.1 { inheriting standard I/O } {execCommandExists stdio} {
- set f [open script w]
- puts $f {close stdout
- set f [open gorp.file w]
- catch {exec [info nameofexecutable] echo foobar &}
- exec [info nameofexecutable] sleep 2
+set path(script) [makeFile {} script]
+
+test exec-17.1 { inheriting standard I/O } {exec} {
+ set f [open $path(script) w]
+ puts $f [format {close stdout
+ set f [open %s w]
+ catch {exec [info nameofexecutable] %s foobar &}
+ exec [info nameofexecutable] %s 2
close $f
- }
+ } $path(gorp.file) $path(echo) $path(sleep)]
close $f
- catch {exec $::tcltest::tcltest script} result
- set f [open gorp.file r]
+ catch {exec [interpreter] $path(script)} result
+ set f [open $path(gorp.file) r]
lappend result [read $f]
close $f
set result
} {{foobar
}}
-# cleanup
-file delete script gorp.file gorp.file2
-file delete echo cat wc sh sleep exit
-file delete err
-::tcltest::cleanupTests
-return
-
-
-
-
-
-
-
-
-
-
+test exec-18.1 { exec cat deals with weird file names} {exec unixOnly} {
+ # This is cross-platform, but the cat isn't predictably correct on
+ # Windows.
+ set f "foo\[\{blah"
+ set path(fooblah) [makeFile {} $f]
+ set fout [open $path(fooblah) w]
+ puts $fout "contents"
+ close $fout
+ set res [list [catch {exec cat $path(fooblah)} msg] $msg]
+ removeFile $f
+ set res
+} {0 contents}
+# cleanup
+foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} {
+ removeFile $file
+}
+::tcltest::cleanupTests
+return
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset y}
catch {unset msg}
-set ::tcltest::testConstraints(testobj) \
+::tcltest::testConstraint testobj \
[expr {[info commands testobj] != {} \
&& [info commands testdoubleobj] != {} \
&& [info commands teststringobj] != {} \
&& [info commands testobj] != {}}]
+::tcltest::testConstraint longIs32bit \
+ [expr {int(0x80000000) < 0}]
+
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
p
} {}
+test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} {
+ set w {3*5}
+ proc a {obj} {expr $obj}
+ set res "[a $w]:[a $w]"
+} {15:15}
+
+test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} {
+ set x 0x100000000
+ expr {$x && 1}
+} 1
+test execute-7.1 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} {
+ expr {0x100000000 && 1}
+} 1
+test execute-7.2 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} {
+ expr {1 && 0x100000000}
+} 1
+test execute-7.3 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} {
+ expr {wide(0x100000000) && 1}
+} 1
+test execute-7.4 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} {
+ expr {1 && wide(0x100000000)}
+} 1
+test execute-7.5 {Wide int handling in INST_EQ} {longIs32bit} {
+ expr {4 == (wide(1)+wide(3))}
+} 1
+test execute-7.6 {Wide int handling in INST_EQ and [incr]} {longIs32bit} {
+ set x 399999999999
+ expr {400000000000 == [incr x]}
+} 1
+# wide ints have more bits of precision than doubles, but we convert anyway
+test execute-7.7 {Wide int handling in INST_EQ and [incr]} {longIs32bit} {
+ set x [expr {wide(1)<<62}]
+ set y [expr {$x+1}]
+ expr {double($x) == double($y)}
+} 1
+test execute-7.8 {Wide int conversions can change sign} {longIs32bit} {
+ set x 0x80000000
+ expr {int($x) < wide($x)}
+} 1
+test execute-7.9 {Wide int handling in INST_MOD} {longIs32bit} {
+ expr {(wide(1)<<60) % ((wide(47)<<45)-1)}
+} 316659348800185
+test execute-7.10 {Wide int handling in INST_MOD} {longIs32bit} {
+ expr {((wide(1)<<60)-1) % 0x400000000}
+} 17179869183
+test execute-7.11 {Wide int handling in INST_LSHIFT} {longIs32bit} {
+ expr wide(42)<<30
+} 45097156608
+test execute-7.12 {Wide int handling in INST_LSHIFT} {longIs32bit} {
+ expr 12345678901<<3
+} 98765431208
+test execute-7.13 {Wide int handling in INST_RSHIFT} {longIs32bit} {
+ expr 0x543210febcda9876>>7
+} 47397893236700464
+test execute-7.14 {Wide int handling in INST_RSHIFT} {longIs32bit} {
+ expr 0x9876543210febcda>>7
+} -58286587177206407
+test execute-7.15 {Wide int handling in INST_BITOR} {longIs32bit} {
+ expr 0x9876543210febcda | 0x543210febcda9876
+} -2560765885044310786
+test execute-7.16 {Wide int handling in INST_BITXOR} {longIs32bit} {
+ expr 0x9876543210febcda ^ 0x543210febcda9876
+} -3727778945703861076
+test execute-7.17 {Wide int handling in INST_BITAND} {longIs32bit} {
+ expr 0x9876543210febcda & 0x543210febcda9876
+} 1167013060659550290
+test execute-7.18 {Wide int handling in INST_ADD} {longIs32bit} {
+ expr wide(0x7fffffff)+wide(0x7fffffff)
+} 4294967294
+test execute-7.19 {Wide int handling in INST_ADD} {longIs32bit} {
+ expr 0x7fffffff+wide(0x7fffffff)
+} 4294967294
+test execute-7.20 {Wide int handling in INST_ADD} {longIs32bit} {
+ expr wide(0x7fffffff)+0x7fffffff
+} 4294967294
+test execute-7.21 {Wide int handling in INST_ADD} {longIs32bit} {
+ expr double(0x7fffffff)+wide(0x7fffffff)
+} 4294967294.0
+test execute-7.22 {Wide int handling in INST_ADD} {longIs32bit} {
+ expr wide(0x7fffffff)+double(0x7fffffff)
+} 4294967294.0
+test execute-7.23 {Wide int handling in INST_SUB} {longIs32bit} {
+ expr 0x123456789a-0x20406080a
+} 69530054800
+test execute-7.24 {Wide int handling in INST_MULT} {longIs32bit} {
+ expr 0x123456789a*193
+} 15090186251290
+test execute-7.25 {Wide int handling in INST_DIV} {longIs32bit} {
+ expr 0x123456789a/193
+} 405116546
+test execute-7.26 {Wide int handling in INST_UPLUS} {longIs32bit} {
+ set x 0x123456871234568
+ expr {+ $x}
+} 81985533099853160
+test execute-7.27 {Wide int handling in INST_UMINUS} {longIs32bit} {
+ set x 0x123456871234568
+ expr {- $x}
+} -81985533099853160
+test execute-7.28 {Wide int handling in INST_LNOT} {longIs32bit} {
+ set x 0x123456871234568
+ expr {! $x}
+} 0
+test execute-7.29 {Wide int handling in INST_BITNOT} {longIs32bit} {
+ set x 0x123456871234568
+ expr {~ $x}
+} -81985533099853161
+test execute-7.30 {Wide int handling in function call} {longIs32bit} {
+ set x 0x12345687123456
+ incr x
+ expr {sin($x) == sin(double($x))}
+} 1
+test execute-7.31 {Wide int handling in abs()} {longIs32bit} {
+ set x 0xa23456871234568
+ incr x
+ set y 0x123456871234568
+ concat [expr {abs($x)}] [expr {abs($y)}]
+} {730503879441204585 81985533099853160}
+test execute-7.32 {Wide int handling} {longIs32bit} {
+ expr {1024 * 1024 * 1024 * 1024}
+} 0
+test execute-7.33 {Wide int handling} {longIs32bit} {
+ expr {0x1 * 1024 * 1024 * 1024 * 1024}
+} 0
+test execute-7.34 {Wide int handling} {longIs32bit} {
+ expr {wide(0x1) * 1024 * 1024 * 1024 * 1024}
+} 1099511627776
+
# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset msg}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
#
# This file contains the original set of tests for Tcl's expr command.
# Since the expr command is now compiled, a new set of tests covering
-# the new implementation are in the files "parseExpr.test and
+# the new implementation are in the files "parseExpr.test" and
# "compExpr.test". Sourcing this file into Tcl runs the tests and generates
# output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2.1
namespace import -force ::tcltest::*
}
test expr-old-4.16 {string operators} {expr {"abd" != "abd"}} 0
test expr-old-4.17 {string operators} {expr {"0y" < "0x12"}} 0
test expr-old-4.18 {string operators} {expr {"." < " "}} 0
+test expr-old-4.19 {string operators} {expr {"abc" eq "abd"}} 0
+test expr-old-4.20 {string operators} {expr {"abd" eq "abd"}} 1
+test expr-old-4.21 {string operators} {expr {"abc" ne "abd"}} 1
+test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0
+test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0
+test expr-old-4.24 {string operators} {expr {"" eq ""}} 1
+test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1
+test expr-old-4.26 {string operators} {expr {"" ne ""}} 0
+test expr-old-4.26 {string operators} {expr {"longerstring" eq "shorter"}} 0
+test expr-old-4.26 {string operators} {expr {"longerstring" ne "shorter"}} 1
# The following tests are non-portable because on some systems "+"
# and "-" can be parsed as numbers.
test expr-old-14.6 {precedence checks} {expr 0!=4>=3} 1
test expr-old-14.7 {precedence checks} {expr 1==3<=4} 1
test expr-old-14.8 {precedence checks} {expr 0!=3<=4} 1
+test expr-old-14.9 {precedence checks} {expr 1eq4>3} 1
+test expr-old-14.10 {precedence checks} {expr 0ne4>3} 1
+test expr-old-14.11 {precedence checks} {expr 1eq3<4} 1
+test expr-old-14.12 {precedence checks} {expr 0ne3<4} 1
+test expr-old-14.13 {precedence checks} {expr 1eq4>=3} 1
+test expr-old-14.14 {precedence checks} {expr 0ne4>=3} 1
+test expr-old-14.15 {precedence checks} {expr 1eq3<=4} 1
+test expr-old-14.16 {precedence checks} {expr 0ne3<=4} 1
test expr-old-15.1 {precedence checks} {expr 1==3==3} 0
test expr-old-15.2 {precedence checks} {expr 3==3!=2} 1
test expr-old-15.3 {precedence checks} {expr 2!=3==3} 0
test expr-old-15.4 {precedence checks} {expr 2!=1!=1} 0
+test expr-old-15.5 {precedence checks} {expr 1eq3eq3} 0
+test expr-old-15.6 {precedence checks} {expr 3eq3ne2} 1
+test expr-old-15.7 {precedence checks} {expr 2ne3eq3} 0
+test expr-old-15.8 {precedence checks} {expr 2ne1ne1} 0
-test expr-old-16.1 {precedence checks} {expr 2&3==2} 0
-test expr-old-16.2 {precedence checks} {expr 1&3!=3} 0
+test expr-old-16.1 {precedence checks} {expr 2&3eq2} 0
+test expr-old-16.2 {precedence checks} {expr 1&3ne3} 0
+test expr-old-16.3 {precedence checks} {expr 2&3eq2} 0
+test expr-old-16.4 {precedence checks} {expr 1&3ne3} 0
test expr-old-17.1 {precedence checks} {expr 7&3^0x10} 19
test expr-old-17.2 {precedence checks} {expr 7^0x10&3} 7
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.2 {error conditions} {
list [catch {expr 2+4*} msg] $msg
-} {1 {syntax error in expression "2+4*"}}
+} {1 {syntax error in expression "2+4*": premature end of expression}}
test expr-old-26.3 {error conditions} {
list [catch {expr 2+4*(} msg] $msg
-} {1 {syntax error in expression "2+4*("}}
+} {1 {syntax error in expression "2+4*(": premature end of expression}}
catch {unset _non_existent_}
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.7 {error conditions} {
list [catch {expr {2+(4}} msg] $msg
-} {1 {syntax error in expression "2+(4"}}
+} {1 {syntax error in expression "2+(4": looking for close parenthesis}}
test expr-old-26.8 {error conditions} {
list [catch {expr 2/0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.11 {error conditions} {
list [catch {expr 2#} msg] $msg
-} {1 {syntax error in expression "2#"}}
+} {1 {syntax error in expression "2#": extra tokens at end of expression}}
test expr-old-26.12 {error conditions} {
list [catch {expr a.b} msg] $msg
-} {1 {syntax error in expression "a.b"}}
+} {1 {syntax error in expression "a.b": variable references require preceding $}}
test expr-old-26.13 {error conditions} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-old-26.14 {error conditions} {
list [catch {expr 2:3} msg] $msg
-} {1 {syntax error in expression "2:3"}}
+} {1 {syntax error in expression "2:3": extra tokens at end of expression}}
test expr-old-26.15 {error conditions} {
list [catch {expr a@b} msg] $msg
-} {1 {syntax error in expression "a@b"}}
+} {1 {syntax error in expression "a@b": variable references require preceding $}}
test expr-old-26.16 {error conditions} {
list [catch {expr a[b} msg] $msg
} {1 {missing close-bracket}}
test expr-old-26.17 {error conditions} {
list [catch {expr a`b} msg] $msg
-} {1 {syntax error in expression "a`b"}}
+} {1 {syntax error in expression "a`b": variable references require preceding $}}
test expr-old-26.18 {error conditions} {
list [catch {expr \"a\"\{b} msg] $msg
-} {1 syntax\ error\ in\ expression\ \"\"a\"\{b\"}
+} {1 syntax\ error\ in\ expression\ \"\"a\"\{b\":\ extra\ tokens\ at\ end\ of\ expression}
test expr-old-26.19 {error conditions} {
list [catch {expr a} msg] $msg
-} {1 {syntax error in expression "a"}}
+} {1 {syntax error in expression "a": variable references require preceding $}}
test expr-old-26.20 {error conditions} {
list [catch expr msg] $msg
} {1 {wrong # args: should be "expr arg ?arg ...?"}}
} {0 0}
test expr-old-27.11 {cancelled evaluation} {
list [catch {expr {0 && foo}} msg] $msg
-} {1 {syntax error in expression "0 && foo"}}
+} {1 {syntax error in expression "0 && foo": variable references require preceding $}}
test expr-old-27.12 {cancelled evaluation} {
list [catch {expr {0 ? 1 : foo}} msg] $msg
-} {1 {syntax error in expression "0 ? 1 : foo"}}
+} {1 {syntax error in expression "0 ? 1 : foo": variable references require preceding $}}
# Tcl_ExprBool as used in "if" statements
} 73
test expr-old-31.2 {multiple arguments to expr command} {
list [catch {expr 2 + (3 + 4} msg] $msg
-} {1 {syntax error in expression "2 + (3 + 4"}}
+} {1 {syntax error in expression "2 + (3 + 4": looking for close parenthesis}}
test expr-old-31.3 {multiple arguments to expr command} {
list [catch {expr 2 + 3 +} msg] $msg
-} {1 {syntax error in expression "2 + 3 +"}}
+} {1 {syntax error in expression "2 + 3 +": premature end of expression}}
test expr-old-31.4 {multiple arguments to expr command} {
list [catch {expr 2 + 3 )} msg] $msg
-} {1 {syntax error in expression "2 + 3 )"}}
+} {1 {syntax error in expression "2 + 3 )": extra tokens at end of expression}}
# Math functions
test expr-old-32.51 {math functions in expressions} {
list [catch {expr {srand([lindex "6ty" 0])}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
+test expr-old-32.52 {math functions in expressions} {
+ expr {srand(1<<37) < 1}
+} {1}
+test expr-old-32.53 {math functions in expressions} {
+ expr {srand((1<<31) - 1) > 0}
+} {1}
test expr-old-33.1 {conversions and fancy args to math functions} {
expr hypot ( 3 , 4 )
} {1 {unknown math function "func_2"}}
test expr-old-34.2 {errors in math functions} {
list [catch {expr func|(1.0)} msg] $msg
-} {1 {syntax error in expression "func|(1.0)"}}
+} {1 {syntax error in expression "func|(1.0)": variable references require preceding $}}
test expr-old-34.3 {errors in math functions} {
list [catch {expr {hypot("a b", 2.0)}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-34.4 {errors in math functions} {
list [catch {expr hypot(1.0 2.0)} msg] $msg
-} {1 {syntax error in expression "hypot(1.0 2.0)"}}
+} {1 {syntax error in expression "hypot(1.0 2.0)": missing close parenthesis at end of function call}}
test expr-old-34.5 {errors in math functions} {
list [catch {expr hypot(1.0, 2.0} msg] $msg
-} {1 {syntax error in expression "hypot(1.0, 2.0"}}
+} {1 {syntax error in expression "hypot(1.0, 2.0": missing close parenthesis at end of function call}}
test expr-old-34.6 {errors in math functions} {
list [catch {expr hypot(1.0 ,} msg] $msg
-} {1 {syntax error in expression "hypot(1.0 ,"}}
+} {1 {syntax error in expression "hypot(1.0 ,": premature end of expression}}
test expr-old-34.7 {errors in math functions} {
list [catch {expr hypot(1.0)} msg] $msg
} {1 {too few arguments for math function}}
} {1 {too many arguments for math function}}
}
-test expr-old-36.1 {ExprLooksLikeInt procedure} {
- list [catch {expr 0289} msg] $msg
-} {1 {"0289" is an invalid octal number}}
+test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
+ expr 0289
+} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0289
list [catch {expr {$x+1}} msg] $msg
list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}
+# test for [Bug #542588]
+test expr-old-36.11 {ExprLooksLikeInt procedure} {
+ # define a "too large integer"; this one works also for 64bit arith
+ set x 665802003400000000000000
+ list [catch {expr {$x+1}} msg] $msg
+} {1 {can't use integer value too large to represent as operand of "+"}}
+
+# tests for [Bug #587140]
+test expr-old-36.12 {ExprLooksLikeInt procedure} {
+ set x "10;"
+ list [catch {expr {$x+1}} msg] $msg
+} {1 {can't use non-numeric string as operand of "+"}}
+test expr-old-36.13 {ExprLooksLikeInt procedure} {
+ set x " +"
+ list [catch {expr {$x+1}} msg] $msg
+} {1 {can't use non-numeric string as operand of "+"}}
+test expr-old-36.14 {ExprLooksLikeInt procedure} {
+ set x "123456789012345678901234567890 "
+ list [catch {expr {$x+1}} msg] $msg
+} {1 {can't use integer value too large to represent as operand of "+"}}
+test expr-old-36.15 {ExprLooksLikeInt procedure} {
+ set x "099 "
+ list [catch {expr {$x+1}} msg] $msg
+} {1 {can't use invalid octal number as operand of "+"}}
+test expr-old-36.16 {ExprLooksLikeInt procedure} {
+ set x " 0xffffffffffffffffffffffffffffffffffffff "
+ list [catch {expr {$x+1}} msg] $msg
+} {1 {can't use integer value too large to represent as operand of "+"}}
+
if {[info commands testexprlong] == {}} {
puts "This application hasn't been compiled with the \"testexprlong\""
puts "command, so I can't test Tcl_ExprLong etc."
test expr-old-38.1 {Verify Tcl_ExprString's basic operation} {
list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
[catch {testexprstring "1+"} msg] $msg
-} {5 10.2 1 {syntax error in expression "1+"}}
+} {5 10.2 1 {syntax error in expression "1+": premature end of expression}}
}
# Special test for Pentium arithmetic bug of 1994:
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace import -force ::tcltest::*
}
-if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
- set gotT1 0
- puts "This application hasn't been compiled with the \"T1\" and"
- puts "\"T2\" math functions, so I'll skip some of the expr tests."
-} else {
- set gotT1 1
-}
+testConstraint registeredMathFuncs [expr {
+ ([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"})
+}]
# procedures used below
set x 2; set b {$x}; set a [expr $b == 2]
set a
} 1
+test expr-1.15 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} {
+ set a xxx
+ set x 2; set b {$x}; set a [expr $b eq 2]
+ set a
+} 1
test expr-2.1 {TclCompileExpr: are builtin functions registered?} {
expr double(5*[llength "6 2"])
test expr-2.2 {TclCompileExpr: error in expr} {
catch {expr 2**3} msg
set msg
-} {syntax error in expression "2**3"}
+} {syntax error in expression "2**3": unexpected operator *}
test expr-2.3 {TclCompileExpr: junk after legal expr} {
catch {expr 7*[llength "a b"]foo} msg
set msg
-} {syntax error in expression "7*2foo"}
+} {syntax error in expression "7*2foo": extra tokens at end of expression}
test expr-2.4 {TclCompileExpr: numeric expr string rep == formatted int rep} {
expr {0001}
} 1
test expr-3.2 {CompileCondExpr: error in lor expr} {
catch {expr x||3} msg
set msg
-} {syntax error in expression "x||3"}
+} {syntax error in expression "x||3": variable references require preceding $}
test expr-3.3 {CompileCondExpr: test true arm} {expr 3>2?44:66} 44
test expr-3.4 {CompileCondExpr: error compiling true arm} {
catch {expr 3>2?2**3:66} msg
set msg
-} {syntax error in expression "3>2?2**3:66"}
+} {syntax error in expression "3>2?2**3:66": unexpected operator *}
test expr-3.5 {CompileCondExpr: test false arm} {expr 2>3?44:66} 66
test expr-3.6 {CompileCondExpr: error compiling false arm} {
catch {expr 2>3?44:2**3} msg
set msg
-} {syntax error in expression "2>3?44:2**3"}
+} {syntax error in expression "2>3?44:2**3": unexpected operator *}
test expr-3.7 {CompileCondExpr: long arms & nested cond exprs} {unixOnly nonPortable} {
puts "Note: doing test expr-3.7 which can take several minutes to run"
hello_world
test expr-4.2 {CompileLorExpr: error in land expr} {
catch {expr x&&3} msg
set msg
-} {syntax error in expression "x&&3"}
+} {syntax error in expression "x&&3": variable references require preceding $}
test expr-4.3 {CompileLorExpr: simple lor exprs} {expr 0||1.0} 1
test expr-4.4 {CompileLorExpr: simple lor exprs} {expr 3.0||0.0} 1
test expr-4.5 {CompileLorExpr: simple lor exprs} {expr 0||0||1} 1
test expr-4.6 {CompileLorExpr: error compiling lor arm} {
catch {expr 2**3||4.0} msg
set msg
-} {syntax error in expression "2**3||4.0"}
+} {syntax error in expression "2**3||4.0": unexpected operator *}
test expr-4.7 {CompileLorExpr: error compiling lor arm} {
catch {expr 1.3||2**3} msg
set msg
-} {syntax error in expression "1.3||2**3"}
+} {syntax error in expression "1.3||2**3": unexpected operator *}
test expr-4.8 {CompileLorExpr: error compiling lor arms} {
list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-5.2 {CompileLandExpr: error in bitor expr} {
catch {expr x|3} msg
set msg
-} {syntax error in expression "x|3"}
+} {syntax error in expression "x|3": variable references require preceding $}
test expr-5.3 {CompileLandExpr: simple land exprs} {expr 0&&1.0} 0
test expr-5.4 {CompileLandExpr: simple land exprs} {expr 0&&0} 0
test expr-5.5 {CompileLandExpr: simple land exprs} {expr 3.0&&1.2} 1
test expr-5.7 {CompileLandExpr: error compiling land arm} {
catch {expr 2**3&&4.0} msg
set msg
-} {syntax error in expression "2**3&&4.0"}
+} {syntax error in expression "2**3&&4.0": unexpected operator *}
test expr-5.8 {CompileLandExpr: error compiling land arm} {
catch {expr 1.3&&2**3} msg
set msg
-} {syntax error in expression "1.3&&2**3"}
+} {syntax error in expression "1.3&&2**3": unexpected operator *}
test expr-5.9 {CompileLandExpr: error compiling land arm} {
list [catch {expr {"a"&&"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-6.2 {CompileBitXorExpr: error in bitand expr} {
catch {expr x|3} msg
set msg
-} {syntax error in expression "x|3"}
+} {syntax error in expression "x|3": variable references require preceding $}
test expr-6.3 {CompileBitXorExpr: simple bitxor exprs} {expr 7^0x13} 20
test expr-6.4 {CompileBitXorExpr: simple bitxor exprs} {expr 3^0x10} 19
test expr-6.5 {CompileBitXorExpr: simple bitxor exprs} {expr 0^7} 7
test expr-6.7 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2**3|6} msg
set msg
-} {syntax error in expression "2**3|6"}
+} {syntax error in expression "2**3|6": unexpected operator *}
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} {
catch {expr 2^x} msg
set msg
-} {syntax error in expression "2^x"}
+} {syntax error in expression "2^x": variable references require preceding $}
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test expr-7.5 {CompileBitAndExpr: error in equality expr} {
catch {expr x==3} msg
set msg
-} {syntax error in expression "x==3"}
+} {syntax error in expression "x==3": variable references require preceding $}
test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2**3&6} msg
set msg
-} {syntax error in expression "2**3&6"}
+} {syntax error in expression "2**3&6": unexpected operator *}
test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} {
catch {expr 2&x} msg
set msg
-} {syntax error in expression "2&x"}
+} {syntax error in expression "2&x": variable references require preceding $}
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
+test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
+test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
+test expr-7.20 {CompileBitAndExpr: error in equality expr} {
+ catch {expr xne3} msg
+ set msg
+} {syntax error in expression "xne3": variable references require preceding $}
test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test expr-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test expr-8.5 {CompileEqualityExpr: error in relational expr} {
catch {expr x>3} msg
set msg
-} {syntax error in expression "x>3"}
+} {syntax error in expression "x>3": variable references require preceding $}
test expr-8.6 {CompileEqualityExpr: simple equality exprs} {expr 7==0x13} 0
test expr-8.7 {CompileEqualityExpr: simple equality exprs} {expr -0xf2!=0x53} 1
test expr-8.8 {CompileEqualityExpr: simple equality exprs} {expr {"12398712938788234-1298379" != ""}} 1
test expr-8.10 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2**3==6} msg
set msg
-} {syntax error in expression "2**3==6"}
+} {syntax error in expression "2**3==6": unexpected operator *}
test expr-8.11 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2!=x} msg
set msg
-} {syntax error in expression "2!=x"}
-
+} {syntax error in expression "2!=x": variable references require preceding $}
+test expr-8.14 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1
+test expr-8.14 {CompileBitAndExpr: equality expr} {expr {"\374" eq "ü"}} 1
+test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
+test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0
+test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1
+test expr-8.17 {CompileBitAndExpr: equality expr} {expr 01eq1} 0
+test expr-8.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
+test expr-8.19 {CompileBitAndExpr: equality expr} {expr {"abc" ne "abd"}} 1
+test expr-8.20 {CompileBitAndExpr: error in equality expr} {
+ catch {expr x ne3} msg
+ set msg
+} {syntax error in expression "x ne3": variable references require preceding $}
+test expr-8.21 {CompileBitAndExpr: error in equality expr} {
+ # These should be ""ed to avoid the error
+ catch {expr a eq b} msg
+ set msg
+} {syntax error in expression "a eq b": variable references require preceding $}
test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12
test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63
test expr-9.6 {CompileRelationalExpr: error in shift expr} {
catch {expr x>>3} msg
set msg
-} {syntax error in expression "x>>3"}
+} {syntax error in expression "x>>3": variable references require preceding $}
test expr-9.7 {CompileRelationalExpr: simple relational exprs} {expr 0xff>=+0x3} 1
test expr-9.8 {CompileRelationalExpr: simple relational exprs} {expr -0xf2<0x3} 1
test expr-9.9 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2**3>6} msg
set msg
-} {syntax error in expression "2**3>6"}
+} {syntax error in expression "2**3>6": unexpected operator *}
test expr-9.10 {CompileRelationalExpr: error compiling relational arm} {
catch {expr 2<x} msg
set msg
-} {syntax error in expression "2<x"}
+} {syntax error in expression "2<x": variable references require preceding $}
test expr-10.1 {CompileShiftExpr: just add expr} {expr 4+-2} 2
test expr-10.2 {CompileShiftExpr: just add expr} {expr 0xff-2} 253
test expr-10.5 {CompileShiftExpr: error in add expr} {
catch {expr x+3} msg
set msg
-} {syntax error in expression "x+3"}
+} {syntax error in expression "x+3": variable references require preceding $}
test expr-10.6 {CompileShiftExpr: simple shift exprs} {expr 0xff>>0x3} 31
test expr-10.7 {CompileShiftExpr: simple shift exprs} {expr -0xf2<<0x3} -1936
test expr-10.8 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2**3>>6} msg
set msg
-} {syntax error in expression "2**3>>6"}
+} {syntax error in expression "2**3>>6": unexpected operator *}
test expr-10.9 {CompileShiftExpr: error compiling shift arm} {
catch {expr 2<<x} msg
set msg
-} {syntax error in expression "2<<x"}
+} {syntax error in expression "2<<x": variable references require preceding $}
test expr-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-11.5 {CompileAddExpr: error in multiply expr} {
catch {expr x*3} msg
set msg
-} {syntax error in expression "x*3"}
+} {syntax error in expression "x*3": variable references require preceding $}
test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test expr-11.8 {CompileAddExpr: error compiling add arm} {
catch {expr 2**3+6} msg
set msg
-} {syntax error in expression "2**3+6"}
+} {syntax error in expression "2**3+6": unexpected operator *}
test expr-11.9 {CompileAddExpr: error compiling add arm} {
catch {expr 2-x} msg
set msg
-} {syntax error in expression "2-x"}
+} {syntax error in expression "2-x": variable references require preceding $}
test expr-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-12.5 {CompileMultiplyExpr: error in unary expr} {
catch {expr ~x} msg
set msg
-} {syntax error in expression "~x"}
+} {syntax error in expression "~x": variable references require preceding $}
test expr-12.6 {CompileMultiplyExpr: simple multiply exprs} {expr 0xff*0x3} 765
test expr-12.7 {CompileMultiplyExpr: simple multiply exprs} {expr -0xf2%-0x3} -2
test expr-12.8 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*3%%6} msg
set msg
-} {syntax error in expression "2*3%%6"}
+} {syntax error in expression "2*3%%6": unexpected operator %}
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} {
catch {expr 2*x} msg
set msg
-} {syntax error in expression "2*x"}
+} {syntax error in expression "2*x": variable references require preceding $}
test expr-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test expr-13.8 {CompileUnaryExpr: error compiling unary expr} {
catch {expr ~x} msg
set msg
-} {syntax error in expression "~x"}
+} {syntax error in expression "~x": variable references require preceding $}
test expr-13.9 {CompileUnaryExpr: error compiling unary expr} {
catch {expr !1.x} msg
set msg
-} {syntax error in expression "!1.x"}
+} {syntax error in expression "!1.x": extra tokens at end of expression}
test expr-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
catch {expr [set]} msg
set msg
} {wrong # args: should be "set varName ?newValue?"}
+test expr-13.17 {CompileUnaryExpr: negating non-numeric boolean literals} {
+ set a1 yes; set a0 no; set b1 true; set b0 false
+ list [expr {!$a1}] [expr {!$a0}] [expr {!$b1}] [expr {!$b0}]
+} {0 1 0 1}
+
test expr-14.1 {CompilePrimaryExpr: literal primary} {expr 1} 1
test expr-14.2 {CompilePrimaryExpr: literal primary} {expr 123} 123
test expr-14.3 {CompilePrimaryExpr: literal primary} {expr 0xff} 255
test expr-14.27 {CompilePrimaryExpr: error in math function primary} {
catch {expr sinh::(2.0)} msg
set errorInfo
-} {syntax error in expression "sinh::(2.0)"
+} {syntax error in expression "sinh::(2.0)": expected parenthesis enclosing function arguments
while compiling
"expr sinh::(2.0)"}
test expr-14.28 {CompilePrimaryExpr: subexpression primary} {
test expr-14.30 {CompilePrimaryExpr: missing paren in subexpression primary} {
catch {expr 2+(3*(4+5)} msg
set errorInfo
-} {syntax error in expression "2+(3*(4+5)"
+} {syntax error in expression "2+(3*(4+5)": looking for close parenthesis
while compiling
"expr 2+(3*(4+5)"}
test expr-14.31 {CompilePrimaryExpr: just var ref in subexpression primary} {
test expr-14.32 {CompilePrimaryExpr: unexpected token} {
catch {expr @} msg
set errorInfo
-} {syntax error in expression "@"
+} {syntax error in expression "@": character not legal in expressions
while compiling
"expr @"}
test expr-15.1 {CompileMathFuncCall: missing parenthesis} {
catch {expr sinh2.0)} msg
set errorInfo
-} {syntax error in expression "sinh2.0)"
+} {syntax error in expression "sinh2.0)": variable references require preceding $
while compiling
"expr sinh2.0)"}
test expr-15.2 {CompileMathFuncCall: unknown math function} {
test expr-15.6 {CompileMathFuncCall: missing ')'} {
catch {expr sin(1} msg
set errorInfo
-} {syntax error in expression "sin(1"
+} {syntax error in expression "sin(1": missing close parenthesis at end of function call
while compiling
"expr sin(1"}
-if $gotT1 {
- test expr-15.7 {CompileMathFuncCall: call registered math function} {
- expr 2*T1()
- } 246
- test expr-15.8 {CompileMathFuncCall: call registered math function} {
- expr T2()*3
- } 1035
-
- test expr-15.9 {CompileMathFuncCall: call registered math function} {
- expr T3(21, 37)
- } 37
- test expr-15.10 {CompileMathFuncCall: call registered math function} {
- expr T3(21.2, 37)
- } 37.0
- test expr-15.11 {CompileMathFuncCall: call registered math function} {
- expr T3(-21.2, -17.5)
- } -17.5
-}
+test expr-15.7 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
+ expr 2*T1()
+} 246
+test expr-15.8 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
+ expr T2()*3
+} 1035
+test expr-15.9 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
+ expr T3(21, 37)
+} 37
+test expr-15.10 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
+ expr T3(21.2, 37)
+} 37.0
+test expr-15.11 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
+ expr T3(-21.2, -17.5)
+} -17.5
+test expr-15.12 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
+ expr T3(21, wide(37))
+} 37
+test expr=15.13 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
+ expr T3(wide(21), 37)
+} 37
+test expr=15.14 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
+ expr T3(wide(21), wide(37))
+} 37
+test expr-15.15 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
+ expr T3(21.0, wide(37))
+} 37.0
+test expr=15.16 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
+ expr T3(wide(21), 37.0)
+} 37.0
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
list [catch {expr "$exprtracevar + 20"} a] $a \
[catch {expr "$exprtracevar + 20"} b] $b \
[unset exprtracevar exprtracecounter]
-} {1 {syntax error in expression "1 oops 10 + 20"} 0 32 {}}
+} {1 {syntax error in expression "1 oops 10 + 20": extra tokens at end of expression} 0 32 {}}
test expr-20.3 {broken substitution of integer digits} {
# fails with 8.0.x, but not 8.1b2
list [set a 000; expr 0x1$a] [set a 1; expr ${a}000]
list [catch {expr + {[error foo]}} msg] $msg
} {1 foo}
+# Test for non-numeric boolean literal handling
+test expr-21.1 {non-numeric boolean literals} {expr false } false
+test expr-21.2 {non-numeric boolean literals} {expr true } true
+test expr-21.3 {non-numeric boolean literals} {expr off } off
+test expr-21.4 {non-numeric boolean literals} {expr on } on
+test expr-21.5 {non-numeric boolean literals} {expr no } no
+test expr-21.6 {non-numeric boolean literals} {expr yes } yes
+test expr-21.7 {non-numeric boolean literals} {expr !false} 1
+test expr-21.8 {non-numeric boolean literals} {expr !true } 0
+test expr-21.9 {non-numeric boolean literals} {expr !off } 1
+test expr-21.10 {non-numeric boolean literals} {expr !on } 0
+test expr-21.11 {non-numeric boolean literals} {expr !no } 1
+test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
+
+# Test for non-numeric float handling.
+#
+# These are non-portable because strtod()-support for "Inf" and "NaN"
+# is so wildly variable. This sucks...
+test expr-22.1 {non-numeric floats} nonPortable {
+ list [catch {expr {NaN + 1}} msg] $msg
+} {1 {can't use non-numeric floating-point value as operand of "+"}}
+test expr-22.2 {non-numeric floats} nonPortable {
+ list [catch {expr {Inf + 1}} msg] $msg
+} {1 {can't use infinite floating-point value as operand of "+"}}
+test expr-22.3 {non-numeric floats} nonPortable {
+ set nan NaN
+ list [catch {expr {$nan + 1}} msg] $msg
+} {1 {can't use non-numeric floating-point value as operand of "+"}}
+test expr-22.4 {non-numeric floats} nonPortable {
+ set inf Inf
+ list [catch {expr {$inf + 1}} msg] $msg
+} {1 {can't use infinite floating-point value as operand of "+"}}
+test expr-22.5 {non-numeric floats} nonPortable {
+ list [catch {expr NaN} msg] $msg
+} {1 {domain error: argument not in valid range}}
+test expr-22.6 {non-numeric floats} nonPortable {
+ list [catch {expr Inf} msg] $msg
+} {1 {floating-point value too large to represent}}
+test expr-22.7 {non-numeric floats} nonPortable {
+ list [catch {expr {1 / NaN}} msg] $msg
+} {1 {can't use non-numeric floating-point value as operand of "/"}}
+test expr-22.8 {non-numeric floats} nonPortable {
+ list [catch {expr {1 / Inf}} msg] $msg
+} {1 {can't use infinite floating-point value as operand of "/"}}
+
# cleanup
if {[info exists a]} {
unset a
}
::tcltest::cleanupTests
return
-
#
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
-if {[string compare testgetplatform [info commands testgetplatform]] != 0} {
- puts "This application hasn't been compiled with the \"testgetplatform\""
- puts "command, therefore I am skipping all of these tests."
- ::tcltest::cleanupTests
- return
-}
-
-set platform [testgetplatform]
-
-if {"[info commands testchmod]" != "testchmod"} {
- puts "Skipping fCmd tests. This application does not seem to have the"
- puts "testchmod command that is needed to run these tests."
- ::tcltest::cleanupTests
- return
-}
+tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
+tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]
# Several tests require need to match results against the unix username
set user {}
testchmod 777 $path
if {[file isdirectory $path]} {
catch {
- foreach p [glob [file join $path *]] {
+ foreach p [glob -directory $path *] {
openup $p
}
}
}
proc cleanup {args} {
- foreach p ". $args" {
+ if {$::tcl_platform(platform) == "macintosh"} {
+ set wd [list :]
+ } else {
+ set wd [list .]
+ }
+ foreach p [concat $wd $args] {
set x ""
catch {
- set x [glob [file join $p tf*] [file join $p td*]]
+ set x [glob -directory $p tf* td*]
}
foreach file $x {
if {[catch {file delete -force -- $file}]} {
test fCmd-4.8 {TclFileMakeDirsCmd: already exist: lstat(target) == 0} {notRoot} {
cleanup
file mkdir td1
- set x [file exist td1]
+ set x [file exists td1]
file mkdir td1
- list $x [file exist td1]
+ list $x [file exists td1]
} {1 1}
test fCmd-4.9 {TclFileMakeDirsCmd: exists, not dir} {notRoot} {
cleanup
test fCmd-4.10 {TclFileMakeDirsCmd: exists, is dir} {notRoot} {
cleanup
file mkdir td1
- set x [file exist td1]
+ set x [file exists td1]
file mkdir td1
- list $x [file exist td1]
+ list $x [file exists td1]
} {1 1}
test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} \
- {unixOnly notRoot} {
+ {unixOnly notRoot testchmod} {
cleanup
file mkdir td1/td2/td3
testchmod 000 td1/td2
} {1 {can't create directory "td1/td2/td3": permission denied}}
test fCmd-4.12 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} {macOnly} {
cleanup
- list [catch {file mkdir nonexistantvolume:} msg] $msg
-} {1 {can't create directory "nonexistantvolume:": invalid argument}}
+ list [catch {file mkdir nonexistentvolume:} msg] $msg
+} {1 {can't create directory "nonexistentvolume:": invalid argument}}
test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} {notRoot} {
cleanup
- set x [file exist td1]
+ set x [file exists td1]
file mkdir td1
- list $x [file exist td1]
+ list $x [file exists td1]
} {0 1}
test fCmd-4.14 {TclFileMakeDirsCmd: TclpCreateDirectory fails} \
{unixOnly notRoot} {
createfile tf1
createfile tf2
file mkdir td1
- set x [list [file exist tf1] [file exist tf2] [file exist td1]]
+ set x [list [file exists tf1] [file exists tf2] [file exists td1]]
file delete tf1 td1 tf2
- lappend x [file exist tf1] [file exist tf2] [file exist tf3]
+ lappend x [file exists tf1] [file exists tf2] [file exists tf3]
} {1 1 1 0 0 0}
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} {notRoot unixOrPc} {
cleanup
createfile tf2
file mkdir td1
catch {file delete tf1 td1 $root tf2}
- list [file exist tf1] [file exist tf2] [file exist td1]
+ list [file exists tf1] [file exists tf2] [file exists td1]
} {0 1 0}
test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} {notRoot} {
list [catch {file delete ~_totally_bogus_user} msg] $msg
} {}
test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {notRoot} {
cleanup
- set x [file exist tf1]
+ set x [file exists tf1]
file delete tf1
- list $x [file exist tf1]
+ list $x [file exists tf1]
} {0 0}
test fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} {
cleanup
file mkdir td1
file delete td1
- file exist td1
+ file exists td1
} {0}
test fCmd-5.10 {TclFileDeleteCmd: TclpRemoveDirectory fails} {notRoot} {
cleanup
- file mkdir td1/td2
+ file mkdir [file join td1 td2]
list [catch {file delete td1} msg] $msg
} {1 {error deleting "td1": directory not empty}}
+test fCmd-5.11 {TclFileDeleteCmd: TclpRemoveDirectory with cwd inside} {notRoot} {
+ cleanup
+ set dir [pwd]
+ file mkdir [file join td1 td2]
+ cd [file join td1 td2]
+ set res [list [catch {file delete -force [file dirname [pwd]]} msg]]
+ cd $dir
+ lappend res [file exists td1] $msg
+} {0 0 {}}
+test fCmd-5.12 {TclFileDeleteCmd: TclpRemoveDirectory with bad perms} {unixOnly} {
+ cleanup
+ file mkdir [file join td1 td2]
+ #exec chmod u-rwx [file join td1 td2]
+ file attributes [file join td1 td2] -permissions u+rwx
+ set res [list [catch {file delete -force td1} msg]]
+ lappend res [file exists td1] $msg
+} {0 0 {}}
test fCmd-6.1 {CopyRenameOneFile: bad source} {notRoot} {
# can't test this, because it's caught by FileCopyRename
file rename tf1 tf2
glob tf*
} {tf2}
-test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot} {
+test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} {unixOnly notRoot testchmod} {
cleanup
file mkdir td1
testchmod 000 td1
testchmod 755 td1
set msg
} {1 {error renaming "tf1" to "td1/tf1": permission denied}}
-test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {95} {
+test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {pcOnly 95} {
cleanup
createfile tf1
list [catch {file rename tf1 $long} msg] $msg
catch {file delete -force c:/tcl8975@ d:/tcl8975@}
file mkdir c:/tcl8975@
if [catch {file rename c:/tcl8975@ d:/}] {
- list d:/tcl8975@
+ set msg d:/tcl8975@
} else {
set msg [glob c:/tcl8975@ d:/tcl8975@]
file delete -force d:/tcl8975@
- set msg
}
+ file delete -force c:/tcl8975@
+ set msg
} {d:/tcl8975@}
test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} \
{unixOnly notRoot} {
{unixOnly notRoot xdev} {
cleanup /tmp
file mkdir td1/td2/td3
- exec chmod 000 td1
+ file attributes td1 -permissions 0000
set msg [list [catch {file rename td1 /tmp} msg] $msg]
- exec chmod 755 td1
+ file attributes td1 -permissions 0755
set msg
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} \
{unixOnly notRoot} {
cleanup
file mkdir ~/td1/td2
- exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
+ set td1name [file join [file dirname ~] [file tail ~] td1]
+ file attributes $td1name -permissions 0000
set msg [list [catch {file copy ~/td1 td1} msg] $msg]
- exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
+ file attributes $td1name -permissions 0755
file delete -force ~/td1
set msg
} {1 {error copying "~/td1": permission denied}}
cleanup
file mkdir td2
file mkdir ~/td1
- exec chmod 000 [file join [file dirname ~] [file tail ~] td1]
+ set td1name [file join [file dirname ~] [file tail ~] td1]
+ file attributes $td1name -permissions 0000
set msg [list [catch {file copy td2 ~/td1} msg] $msg]
- exec chmod 755 [file join [file dirname ~] [file tail ~] td1]
+ file attributes $td1name -permissions 0755
file delete -force ~/td1
set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
{unixOnly notRoot} {
cleanup
file mkdir ~/td1/td2
- exec chmod 000 [file join [file dirname ~] [file tail ~] td1 td2]
+ set td2name [file join [file dirname ~] [file tail ~] td1 td2]
+ file attributes $td2name -permissions 0000
set msg [list [catch {file copy ~/td1 td1} msg] $msg]
- exec chmod 755 [file join [file dirname ~] [file tail ~] td1 td2]
+ file attributes $td2name -permissions 0755
file delete -force ~/td1
set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
{unixOnly notRoot xdev} {
cleanup /tmp
file mkdir td1/td2/td3
- exec chmod 000 td1/td2/td3
+ file attributes td1/td2/td3 -permissions 0000
set msg [list [catch {file rename td1 /tmp} msg] $msg]
- exec chmod 755 td1/td2/td3
+ file attributes td1/td2/td3 -permissions 0755
set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \
cleanup
list [catch {file rename tf1 tf2} msg] $msg
} {1 {error renaming "tf1": no such file or directory}}
-test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot} {
+test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot testchmod} {
cleanup
createfile tf1
createfile tf2
file rename tf2 tf4
list [lsort [glob tf*]] [file writable tf3] [file writable tf4]
} {{tf3 tf4} 1 0}
-test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot} {
+test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot testchmod} {
cleanup
file mkdir td1 td2
testchmod 555 td2
file rename td2 td4
list [lsort [glob td*]] [file writable td3] [file writable td4]
} {{td3 td4} 1 0}
-test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot} {
+test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} {
cleanup
createfile tf1 tf1
createfile tf2 tf2
file rename -force tf2 tf2
list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2]
} {tf1 tf2 1 0}
-test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc} {
+test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testchmod} {
cleanup
file mkdir td1
file mkdir td2
file rename -force td2 .
list [lsort [glob td*]] [file writable td1] [file writable td2]
} {{td1 td2} 1 0}
-test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot} {
+test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testchmod} {
cleanup
createfile tf1
createfile tf2
file rename -force tfs4 tfd4
list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
-test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot} {
+test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot testchmod} {
# Under unix, you can rename a read-only directory, but you can't
# move it into another directory.
list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \
[file writable [file join tdd2 tds2]] $w3 $w4
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4} {1 {error renaming "td1" to "[file join td2 td1]": file already exists}} 1 1 0 0}]
-test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot} {
+test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} {notRoot testchmod} {
cleanup
file mkdir tds1
file mkdir tds2
}
list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
-test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot} {
+test fCmd-9.10 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} {
cleanup
createfile tf1
createfile tf2
testchmod 444 tf2
file rename tf1 [file join td1 tf3]
file rename tf2 [file join td1 tf4]
- list [catch {glob tf*}] [lsort [glob [file join td1 t*]]] \
+ list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \
[file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}]
-test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot} {
+test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot testchmod} {
cleanup
file mkdir td1
file mkdir td2
} else {
set w4 0
}
- list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
+ list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] $w4
} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
-test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot} {
+test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot testchmod} {
cleanup
file mkdir [file join td1 td2] [file join td2 td1]
if {$tcl_platform(platform) != "macintosh"} {
cleanup
list [catch {file copy tf1 tf2} msg] $msg
} {1 {error copying "tf1": no such file or directory}}
-test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot} {
+test fCmd-10.2 {file copy: comprehensive: file to new name} {notRoot testchmod} {
cleanup
createfile tf1 tf1
createfile tf2 tf2
file copy tf2 tf4
list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
-test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc} {
+test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc testchmod} {
cleanup
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
testchmod 555 td2
file copy td1 td3
file copy td2 td4
- set msg [list [lsort [glob td*]] [glob [file join td3 t*]] \
- [glob [file join td4 t*]] [file writable td3] [file writable td4]]
+ set msg [list [lsort [glob td*]] [glob -directory td3 t*] \
+ [glob -directory td4 t*] [file writable td3] [file writable td4]]
if {$tcl_platform(platform) != "macintosh"} {
testchmod 755 td2
testchmod 755 td4
}
set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]
-test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot} {
+test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testchmod} {
cleanup
createfile tf1
createfile tf2
file copy -force tfs4 tfd4
list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0}
-test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot} {
+test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} {
cleanup
file mkdir td1
file mkdir [file join td2 td1]
list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5
} [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \
- {notRoot unixOrPc} {
+ {notRoot unixOrPc testchmod} {
cleanup
file mkdir tds1
file mkdir tds2
set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2]
} [subst {{tdd1 tdd2 tds1 tds2} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} {1 {error copying "tds2" to "[file join tdd2 tds2]": file already exists}} 1 0}]
-test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot} {
+test fCmd-10.7 {file rename: comprehensive: file to new name and dir} {notRoot testchmod} {
cleanup
createfile tf1
createfile tf2
testchmod 444 tf2
file copy tf1 [file join td1 tf3]
file copy tf2 [file join td1 tf4]
- list [lsort [glob tf*]] [lsort [glob [file join td1 t*]]] \
+ list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \
[file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \
- {notRoot unixOrPc} {
+ {notRoot unixOrPc testchmod} {
cleanup
file mkdir td1
file mkdir td2
testchmod 555 td2
file copy td1 [file join td3 td3]
file copy td2 [file join td3 td4]
- list [lsort [glob td*]] [lsort [glob [file join td3 t*]]] \
+ list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/dir
- exec chmod 555 tfa
+ file attributes tfa -permissions 0555
set result [catch {file rename tfa/dir tfa2}]
- exec chmod 777 tfa
+ file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa/dir/a/b/c
- exec chmod 000 tfa/dir
+ file attributes tfa/dir -permissions 0000
set r1 [catch {file copy tfa tfa2}]
- exec chmod 777 tfa/dir
+ file attributes tfa/dir -permissions 0777
set result $r1
file delete -force tfa tfa2
set result
catch {file delete -force -- tfa}
file mkdir tfa
createfile tfa/file
- exec chmod 000 tfa
+ file attributes tfa -permissions 0000
set result [catch {file mkdir tfa/file}]
- exec chmod 777 tfa
+ file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
# Coverage tests for TclDeleteFilesCommand()
-test fCmd-16.1 { test the -- argument } {notRoot} {
+test fCmd-16.1 {test the -- argument} {notRoot} {
catch {file delete -force -- tfa}
createfile tfa
file delete -- tfa
file exists tfa
} {0}
-test fCmd-16.2 { test the -force and -- arguments } {notRoot} {
+test fCmd-16.2 {test the -force and -- arguments} {notRoot} {
catch {file delete -force -- tfa}
createfile tfa
file delete -force -- tfa
file exists tfa
} {0}
-test fCmd-16.3 { test bad option } {notRoot} {
+test fCmd-16.3 {test bad option} {notRoot} {
catch {file delete -force -- tfa}
createfile tfa
set result [catch {file delete -dog tfa}]
set result
} {1}
-test fCmd-16.4 { test not enough args } {notRoot} {
+test fCmd-16.4 {test not enough args} {notRoot} {
catch {file delete}
} {1}
-test fCmd-16.5 { test not enough args with options } {notRoot} {
+test fCmd-16.5 {test not enough args with options} {notRoot} {
catch {file delete --}
} {1}
catch {file delete -force -- tfa}
file mkdir tfa
createfile tfa/a
- exec chmod 555 tfa
+ file attributes tfa -permissions 0555
set result [catch {file delete tfa/a }]
#######
####### If any directory in a tree that is being removed does not
####### have write permission, the process will fail!
####### This is also the case with "rm -rf"
#######
- exec chmod 777 tfa
+ file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
expr ![file exists tfa1] && ![file exists tfa2]
} {1}
-test fCmd-16.11 { TclFileDeleteCmd: removing a nonexistant file} {notRoot} {
+test fCmd-16.11 {TclFileDeleteCmd: removing a nonexistant file} {notRoot} {
catch {file delete -force -- tfa}
file delete tfa
set result 1
test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} {
catch {file delete -force -- tfa1}
file mkdir tfa1
- exec chmod 555 tfa1
+ file attributes tfa1 -permissions 0555
set result [catch {file mkdir tfa1/tfa2}]
- exec chmod 777 tfa1
+ file attributes tfa1 -permissions 0777
file delete -force tfa1
set result
} {1}
catch {file delete -force -- tfa1 tfa2 tfa3}
set s [createfile tfa1]
- exec ln -s tfa1 tfa2
+ file link -symbolic tfa2 tfa1
file rename tfa2 tfa3
set t [file type tfa3]
- set result [expr { $t == "link" }]
+ set result [expr {$t eq "link"}]
file delete tfa1 tfa3
set result
} {1}
catch {file delete -force -- tfa1 tfa2 tfa3}
file mkdir tfa1
- exec ln -s tfa1 tfa2
+ file link -symbolic tfa2 tfa1
file rename tfa2 tfa3
set t [file type tfa3]
- set result [expr { $t == "link" }]
+ set result [expr {$t eq "link"}]
file delete tfa1 tfa3
set result
} {1}
file mkdir tfa2
set f [file join [pwd] tfa1/a/b]
set f2 [file join [pwd] {tfa2/b alias}]
- exec ln -s $f $f2
+ file link -symbolic $f2 $f
file rename {tfa2/b alias/c} tfa3
set r1 [file isdir tfa3]
set r2 [file exists tfa1/a/b/c]
file mkdir tfa1
set s [createfile tfa2]
- exec ln -s tfa1 tfalink
+ file link -symbolic tfalink tfa1
file rename tfa2 tfalink
set result [checkcontent tfa1/tfa2 $s ]
catch {file delete -force -- tfa1 tfalink}
file mkdir tfa1
- exec ln -s tfa1 tfalink
+ file link -symbolic tfalink tfa1
file delete tfa1
file rename tfalink tfa2
set result [expr [string compare [file type tfa2] "link"] == 0]
#
# Coverage tests for TclUnixRmdir
#
-test fCmd-19.1 { remove empty directory } {notRoot} {
+test fCmd-19.1 {remove empty directory} {notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file delete tfa
file exists tfa
} {0}
-test fCmd-19.2 { rmdir error besides EEXIST} {unixOnly notRoot} {
+test fCmd-19.2 {rmdir error besides EEXIST} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/a
- exec chmod 555 tfa
+ file attributes tfa -permissions 0555
set result [catch {file delete tfa/a}]
- exec chmod 777 tfa
+ file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
-test fCmd-19.3 { recursive remove } {notRoot} {
+test fCmd-19.3 {recursive remove} {notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/a
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/a
- exec chmod 000 tfa/a
+ file attributes tfa/a -permissions 0000
set result [catch {file delete -force tfa}]
- exec chmod 777 tfa/a
+ file attributes tfa/a -permissions 0777
file delete -force tfa
set result
} {1}
set result
} {1}
-test fCmd-21.7 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {
+test fCmd-21.7.1 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot dontCopyLinks} {
file mkdir tfad1
- exec ln -s tfad1 tfalink
+ file link -symbolic tfalink tfad1
+ file delete tfad1
+ set result [list [catch {file copy tfalink tfalink2} msg] $msg]
+ file delete -force tfalink tfalink2
+ set result
+} {1 {error copying "tfalink": the target of this link doesn't exist}}
+test fCmd-21.7.2 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {
+ file mkdir tfad1
+ file link -symbolic tfalink tfad1
file delete tfad1
file copy tfalink tfalink2
set result [string match [file type tfalink2] link]
set result
} {1}
-test fCmd-21.8 {TclCopyFilesCmd : copy a link } {unixOnly notRoot} {
+test fCmd-21.8.1 {TclCopyFilesCmd: copy a link } {unixOnly notRoot dontCopyLinks} {
file mkdir tfad1
- exec ln -s tfad1 tfalink
+ file link -symbolic tfalink tfad1
file copy tfalink tfalink2
- set r1 [file type tfalink]
- set r2 [file type tfalink2]
- set r3 [file isdir tfad1]
- set result [expr {("$r1" == "link" ) && ("$r2" == "link" ) && $r3}]
- file delete tfad1 tfalink tfalink2
+ set r1 [file type tfalink]; # link
+ set r2 [file type tfalink2]; # directory
+ set r3 [file isdir tfad1]; # 1
+ set result [expr {("$r1" == "link") && ("$r2" == "directory") && $r3}]
+ file delete -force tfad1 tfalink tfalink2
+ set result
+} {1}
+test fCmd-21.8.2 {TclCopyFilesCmd: copy a link } {unixOnly notRoot} {
+ file mkdir tfad1
+ file link -symbolic tfalink tfad1
+ file copy tfalink tfalink2
+ set r1 [file type tfalink]; # link
+ set r2 [file type tfalink2]; # link
+ set r3 [file isdir tfad1]; # 1
+ set result [expr {("$r1" == "link") && ("$r2" == "link") && $r3}]
+ file delete -force tfad1 tfalink tfalink2
set result
} {1}
test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} {
file mkdir tfad1
- exec ln -s "[pwd]/tfad1" tfad1/tfalink
+ file link -symbolic tfad1/tfalink "[pwd]/tfad1"
file copy tfad1 tfad2
set result [string match [file type tfad2/tfalink] link]
file delete -force tfad1 tfad2
file delete -force tfa tfad
set result
} {1}
-
+
#
# Coverage testing for TclpRenameFile
#
set result
} {1}
-test fCmd-22.3 { TclpRenameFile : rename dir to existing dir } {notRoot} {
+test fCmd-22.3 {TclpRenameFile: rename dir to existing dir} {notRoot} {
catch {file delete -force -- d1 tfad}
file mkdir d1 [file join tfad d1]
set r1 [catch {file rename d1 tfad}]
# TclMacCopyDirectory
# Error cases are not covered.
#
-test fCmd-25.1 { TclMacCopyDirectory : copying a normal directory} \
- {notRoot notFileSharing} {
+test fCmd-25.1 {TclMacCopyDirectory: copying a normal directory} {notRoot notFileSharing} {
catch {file delete -force -- tfad1 tfad2}
file mkdir [file join tfad1 a b c]
set result
} {1}
-test fCmd-25.2 { TclMacCopyDirectory : copying a short path normal directory} \
- {notRoot notFileSharing} {
+test fCmd-25.2 {TclMacCopyDirectory: copying a short path normal directory} {notRoot notFileSharing} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
set result
} {1}
-test fCmd-25.3 { TclMacCopyDirectory : copying dirs between different dirs} \
- {notRoot notFileSharing} {
+test fCmd-25.3 {TclMacCopyDirectory: copying dirs between different dirs} {notRoot notFileSharing} {
catch {file delete -force -- tfad1 tfad2}
file mkdir [file join tfad1 x y z]
# Functionality tests for TclDeleteFilesCmd
#
-test fCmd-26.1 { TclDeleteFilesCmd : delete symlink} {unixOnly notRoot} {
+test fCmd-26.1 {TclDeleteFilesCmd: delete symlink} {unixOnly notRoot} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
- exec ln -s tfad1 tfalink
+ file link -symbolic tfalink tfad1
file delete tfalink
set r1 [file isdir tfad1]
set result
} {1}
-test fCmd-26.2 { TclDeleteFilesCmd : delete dir with symlink} {unixOnly notRoot} {
+test fCmd-26.2 {TclDeleteFilesCmd: delete dir with symlink} {unixOnly notRoot} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
file mkdir tfad2
- exec ln -s tfad1 [file join tfad2 link]
+ file link -symbolic [file join tfad2 link] tfad1
file delete -force tfad2
set r1 [file isdir tfad1]
set result
} {1}
-test fCmd-26.3 { TclDeleteFilesCmd : delete dangling symlink} {unixOnly notRoot} {
+test fCmd-26.3 {TclDeleteFilesCmd: delete dangling symlink} {unixOnly notRoot} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
- exec ln -s tfad1 tfad2
+ file link -symbolic tfad2 tfad1
file delete tfad1
file delete tfad2
set result
} {1}
-test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} {
+test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} {testsetplatform} {
+ set platform [testgetplatform]
testsetplatform unix
list [catch {file attributes ~_totally_bogus_user} msg] $msg [testsetplatform $platform]
} {1 {user "_totally_bogus_user" doesn't exist} {}}
# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
if {$tcl_platform(platform) == "unix"} {
- set ::tcltest::testConstraints(foundGroup) 0
+ ::tcltest::testConstraint foundGroup 0
catch {
set groupList [exec groups]
set group [lindex $groupList 0]
- set ::tcltest::testConstraints(foundGroup) 1
+ ::tcltest::testConstraint foundGroup 1
}
} else {
- set ::tcltest::testConstraints(foundGroup) 1
+ ::tcltest::testConstraint foundGroup 1
}
test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} {
list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
+if {[string equal $tcl_platform(platform) "windows"]} {
+ if {[string index $tcl_platform(osVersion) 0] >= 5 \
+ && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
+ tcltest::testConstraint linkDirectory 1
+ tcltest::testConstraint linkFile 1
+ } else {
+ tcltest::testConstraint linkDirectory 0
+ tcltest::testConstraint linkFile 0
+ }
+} else {
+ tcltest::testConstraint linkFile 1
+ tcltest::testConstraint linkDirectory 1
+}
+
+test fCmd-28.1 {file link} {
+ list [catch {file link} msg] $msg
+} {1 {wrong # args: should be "file link ?-linktype? linkname ?target?"}}
+
+test fCmd-28.2 {file link} {
+ list [catch {file link a b c d} msg] $msg
+} {1 {wrong # args: should be "file link ?-linktype? linkname ?target?"}}
+
+test fCmd-28.3 {file link} {
+ list [catch {file link abc b c} msg] $msg
+} {1 {bad switch "abc": must be -symbolic or -hard}}
+
+test fCmd-28.4 {file link} {
+ list [catch {file link -abc b c} msg] $msg
+} {1 {bad switch "-abc": must be -symbolic or -hard}}
+
+makeDirectory abc.dir
+makeDirectory abc2.dir
+makeFile contents abc.file
+makeFile contents abc2.file
+
+cd [temporaryDirectory]
+test fCmd-28.5 {file link: source already exists} {linkDirectory} {
+ cd [temporaryDirectory]
+ set res [list [catch {file link abc.dir abc2.dir} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {1 {could not create new link "abc.dir": that path already exists}}
+
+test fCmd-28.6 {file link: unsupported operation} {linkDirectory macOrWin} {
+ cd [temporaryDirectory]
+ set res [list [catch {file link -hard abc.link abc.dir} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {1 {could not create new link "abc.link" pointing to "abc.dir": illegal operation on a directory}}
+
+test fCmd-28.7 {file link: source already exists} {linkFile} {
+ cd [temporaryDirectory]
+ set res [list [catch {file link abc.file abc2.file} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {1 {could not create new link "abc.file": that path already exists}}
+
+test fCmd-28.8 {file link} {linkFile winOnly} {
+ cd [temporaryDirectory]
+ set res [list [catch {file link -symbolic abc.link abc.file} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {1 {could not create new link "abc.link" pointing to "abc.file": not a directory}}
+
+test fCmd-28.9 {file link: success with file} {linkFile} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ set res [list [catch {file link abc.link abc.file} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {0 abc.file}
+
+cd [temporaryDirectory]
+catch {file delete -force abc.link}
+cd [workingDirectory]
+
+test fCmd-28.10 {file link: linking to nonexistent path} {linkDirectory} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ set res [list [catch {file link abc.link abc2.doesnt} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {1 {could not create new link "abc.link" since target "abc2.doesnt" doesn't exist}}
+
+test fCmd-28.11 {file link: success with directory} {linkDirectory} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ set res [list [catch {file link abc.link abc.dir} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {0 abc.dir}
+
+test fCmd-28.12 {file link: cd into a link} {linkDirectory} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ file link abc.link abc.dir
+ set orig [pwd]
+ cd abc.link
+ set dir [pwd]
+ cd ..
+ set up [pwd]
+ cd $orig
+ # now '$up' should be either $orig or [file dirname abc.dir],
+ # depending on whether 'cd' actually moves to the destination
+ # of a link, or simply treats the link as a directory.
+ # (on windows the former, on unix the latter, I believe)
+ if {([file normalize $up] != [file normalize $orig]) \
+ && ([file normalize $up] != [file normalize [file dirname abc.dir]])} {
+ set res "wrong directory with 'cd $link ; cd ..'"
+ } else {
+ set res "ok"
+ }
+ cd [workingDirectory]
+ set res
+} {ok}
+
+test fCmd-28.13 {file link} {linkDirectory} {
+ # duplicate link throws error
+ cd [temporaryDirectory]
+ set res [list [catch {file link abc.link abc.dir} msg] $msg]
+ cd [workingDirectory]
+ set res
+} {1 {could not create new link "abc.link": that path already exists}}
+
+test fCmd-28.14 {file link: deletes link not dir} {linkDirectory} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ set res [list [file exists abc.link] [file exists abc.dir]]
+ cd [workingDirectory]
+ set res
+} {0 1}
+
+test fCmd-28.15.1 {file link: copies link not dir} {linkDirectory dontCopyLinks} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ file link abc.link abc.dir
+ file copy abc.link abc2.link
+ # abc2.linkdir was a copy of a link to a dir, so it should end up as
+ # a directory, not a link (links trace to endpoint).
+ set res [list [file type abc2.link] [file tail [file link abc.link]]]
+ cd [workingDirectory]
+ set res
+} {directory abc.dir}
+test fCmd-28.15.2 {file link: copies link not dir} {linkDirectory} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ file link abc.link abc.dir
+ file copy abc.link abc2.link
+ set res [list [file type abc2.link] [file tail [file link abc2.link]]]
+ cd [workingDirectory]
+ set res
+} {link abc.dir}
+
+cd [temporaryDirectory]
+file delete -force abc.link
+file delete -force abc2.link
+
+file copy abc.file abc.dir
+file copy abc2.file abc.dir
+cd [workingDirectory]
+
+test fCmd-28.16 {file link: glob inside link} {linkDirectory} {
+ cd [temporaryDirectory]
+ file delete -force abc.link
+ file link abc.link abc.dir
+ set res [glob -dir abc.link -tails *]
+ cd [workingDirectory]
+ set res
+} {abc.file abc2.file}
+
+test fCmd-28.17 {file link: glob -type l} {linkDirectory} {
+ cd [temporaryDirectory]
+ set res [glob -dir [pwd] -type l -tails abc*]
+ cd [workingDirectory]
+ set res
+} {abc.link}
+
+test fCmd-28.18 {file link: glob -type d} {linkDirectory} {
+ cd [temporaryDirectory]
+ set res [lsort [glob -dir [pwd] -type d -tails abc*]]
+ cd [workingDirectory]
+ set res
+} [lsort [list abc.link abc.dir abc2.dir]]
+
+test fCmd-29.1 {weird memory corruption fault} {
+ catch {set res [open [file join ~a_totally_bogus_user_id/foo bar]]}
+} 1
+
+cd [temporaryDirectory]
+file delete -force abc.link
+cd [workingDirectory]
+
+removeFile abc2.file
+removeFile abc.file
+removeDirectory abc2.dir
+removeDirectory abc.dir
+
# cleanup
cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
namespace import -force ::tcltest::*
}
-if {[info commands testsetplatform] == {}} {
- puts "This application hasn't been compiled with the \"testsetplatform\""
- puts "command, so I can't test the filename conversion procedures."
- ::tcltest::cleanupTests
- return
-}
+tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
+tcltest::testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]]
global env
-set platform [testgetplatform]
+if {[tcltest::testConstraint testsetplatform]} {
+ set platform [testgetplatform]
+}
-test filename-1.1 {Tcl_GetPathType: unix} {
+test filename-1.1 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype /
} absolute
-test filename-1.2 {Tcl_GetPathType: unix} {
+test filename-1.2 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype /foo
} absolute
-test filename-1.3 {Tcl_GetPathType: unix} {
+test filename-1.3 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype foo
} relative
-test filename-1.4 {Tcl_GetPathType: unix} {
+test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype c:/foo
} relative
-test filename-1.5 {Tcl_GetPathType: unix} {
+test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~
} absolute
-test filename-1.6 {Tcl_GetPathType: unix} {
+test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~/foo
} absolute
-test filename-1.7 {Tcl_GetPathType: unix} {
+test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ~foo
} absolute
-test filename-1.8 {Tcl_GetPathType: unix} {
+test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} {
testsetplatform unix
file pathtype ./~foo
} relative
-test filename-2.1 {Tcl_GetPathType: mac, denerate names} {
+test filename-2.1 {Tcl_GetPathType: mac, denerate names} {testsetplatform} {
testsetplatform mac
file pathtype /
} relative
-test filename-2.2 {Tcl_GetPathType: mac, denerate names} {
+test filename-2.2 {Tcl_GetPathType: mac, denerate names} {testsetplatform} {
testsetplatform mac
file pathtype /.
} relative
-test filename-2.3 {Tcl_GetPathType: mac, denerate names} {
+test filename-2.3 {Tcl_GetPathType: mac, denerate names} {testsetplatform} {
testsetplatform mac
file pathtype /..
} relative
-test filename-2.4 {Tcl_GetPathType: mac, denerate names} {
+test filename-2.4 {Tcl_GetPathType: mac, denerate names} {testsetplatform} {
testsetplatform mac
file pathtype //.//
} relative
-test filename-2.5 {Tcl_GetPathType: mac, denerate names} {
+test filename-2.5 {Tcl_GetPathType: mac, denerate names} {testsetplatform} {
testsetplatform mac
file pathtype //.//../.
} relative
-test filename-2.6 {Tcl_GetPathType: mac, tilde names} {
+test filename-2.6 {Tcl_GetPathType: mac, tilde names} {testsetplatform} {
testsetplatform mac
file pathtype ~
} absolute
-test filename-2.7 {Tcl_GetPathType: mac, tilde names} {
+test filename-2.7 {Tcl_GetPathType: mac, tilde names} {testsetplatform} {
testsetplatform mac
file pathtype ~:
} absolute
-test filename-2.8 {Tcl_GetPathType: mac, tilde names} {
+test filename-2.8 {Tcl_GetPathType: mac, tilde names} {testsetplatform} {
testsetplatform mac
file pathtype ~:foo
} absolute
-test filename-2.9 {Tcl_GetPathType: mac, tilde names} {
+test filename-2.9 {Tcl_GetPathType: mac, tilde names} {testsetplatform} {
testsetplatform mac
file pathtype ~/
} absolute
-test filename-2.10 {Tcl_GetPathType: mac, tilde names} {
+test filename-2.10 {Tcl_GetPathType: mac, tilde names} {testsetplatform} {
testsetplatform mac
file pathtype ~/foo
} absolute
-test filename-2.11 {Tcl_GetPathType: mac, unix-style names} {
+test filename-2.11 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} {
testsetplatform mac
file pathtype /foo
} absolute
-test filename-2.12 {Tcl_GetPathType: mac, unix-style names} {
+test filename-2.12 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} {
testsetplatform mac
file pathtype /./foo
} absolute
-test filename-2.13 {Tcl_GetPathType: mac, unix-style names} {
+test filename-2.13 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} {
testsetplatform mac
file pathtype /..//./foo
} absolute
-test filename-2.14 {Tcl_GetPathType: mac, unix-style names} {
+test filename-2.14 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} {
testsetplatform mac
file pathtype /foo/bar
} absolute
-test filename-2.15 {Tcl_GetPathType: mac, unix-style names} {
+test filename-2.15 {Tcl_GetPathType: mac, unix-style names} {testsetplatform} {
testsetplatform mac
file pathtype foo/bar
} relative
-test filename-2.16 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.16 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype :
} relative
-test filename-2.17 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.17 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype :foo
} relative
-test filename-2.18 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.18 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype foo:
} absolute
-test filename-2.19 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.19 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype foo:bar
} absolute
-test filename-2.20 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.20 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype :foo:bar
} relative
-test filename-2.21 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.21 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype ::foo:bar
} relative
-test filename-2.22 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.22 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype ~foo
} absolute
-test filename-2.23 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.23 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype :~foo
} relative
-test filename-2.24 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.24 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype ~foo:
} absolute
-test filename-2.25 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.25 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype foo/bar:
} absolute
-test filename-2.26 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.26 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype /foo:
} absolute
-test filename-2.27 {Tcl_GetPathType: mac, mac-style names} {
+test filename-2.27 {Tcl_GetPathType: mac, mac-style names} {testsetplatform} {
testsetplatform mac
file pathtype foo
} relative
-test filename-3.1 {Tcl_GetPathType: windows} {
+test filename-3.1 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype /
} volumerelative
-test filename-3.2 {Tcl_GetPathType: windows} {
+test filename-3.2 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype \\
} volumerelative
-test filename-3.3 {Tcl_GetPathType: windows} {
+test filename-3.3 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype /foo
} volumerelative
-test filename-3.4 {Tcl_GetPathType: windows} {
+test filename-3.4 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype \\foo
} volumerelative
-test filename-3.5 {Tcl_GetPathType: windows} {
+test filename-3.5 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:/
} absolute
-test filename-3.6 {Tcl_GetPathType: windows} {
+test filename-3.6 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:\\
} absolute
-test filename-3.7 {Tcl_GetPathType: windows} {
+test filename-3.7 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:/foo
} absolute
-test filename-3.8 {Tcl_GetPathType: windows} {
+test filename-3.8 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:\\foo
} absolute
-test filename-3.9 {Tcl_GetPathType: windows} {
+test filename-3.9 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:
} volumerelative
-test filename-3.10 {Tcl_GetPathType: windows} {
+test filename-3.10 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype c:foo
} volumerelative
-test filename-3.11 {Tcl_GetPathType: windows} {
+test filename-3.11 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype foo
} relative
-test filename-3.12 {Tcl_GetPathType: windows} {
+test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype //foo/bar
} absolute
-test filename-3.13 {Tcl_GetPathType: windows} {
+test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~foo
} absolute
-test filename-3.14 {Tcl_GetPathType: windows} {
+test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~
} absolute
-test filename-3.15 {Tcl_GetPathType: windows} {
+test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ~/foo
} absolute
-test filename-3.16 {Tcl_GetPathType: windows} {
+test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} {
testsetplatform windows
file pathtype ./~foo
} relative
-test filename-4.1 {Tcl_SplitPath: unix} {
+test filename-4.1 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /
} {/}
-test filename-4.2 {Tcl_SplitPath: unix} {
+test filename-4.2 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo
} {/ foo}
-test filename-4.3 {Tcl_SplitPath: unix} {
+test filename-4.3 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo/bar
} {/ foo bar}
-test filename-4.4 {Tcl_SplitPath: unix} {
+test filename-4.4 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo/bar/baz
} {/ foo bar baz}
-test filename-4.5 {Tcl_SplitPath: unix} {
+test filename-4.5 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo/bar
} {foo bar}
-test filename-4.6 {Tcl_SplitPath: unix} {
+test filename-4.6 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ./foo/bar
} {. foo bar}
-test filename-4.7 {Tcl_SplitPath: unix} {
+test filename-4.7 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split /foo/../././foo/bar
} {/ foo .. . . foo bar}
-test filename-4.8 {Tcl_SplitPath: unix} {
+test filename-4.8 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../foo/bar
} {.. foo bar}
-test filename-4.9 {Tcl_SplitPath: unix} {
+test filename-4.9 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split {}
} {}
-test filename-4.10 {Tcl_SplitPath: unix} {
+test filename-4.10 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split .
} {.}
-test filename-4.11 {Tcl_SplitPath: unix} {
+test filename-4.11 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../
} {..}
-test filename-4.12 {Tcl_SplitPath: unix} {
+test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ../..
} {.. ..}
-test filename-4.13 {Tcl_SplitPath: unix} {
+test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split //foo
} {/ foo}
-test filename-4.14 {Tcl_SplitPath: unix} {
+test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo//bar
} {foo bar}
-test filename-4.15 {Tcl_SplitPath: unix} {
+test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo
} {~foo}
-test filename-4.16 {Tcl_SplitPath: unix} {
+test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo/~bar
} {~foo ./~bar}
-test filename-4.17 {Tcl_SplitPath: unix} {
+test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split ~foo/~bar/~baz
} {~foo ./~bar ./~baz}
-test filename-4.18 {Tcl_SplitPath: unix} {
+test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} {
testsetplatform unix
file split foo/bar~/baz
} {foo bar~ baz}
-test filename-5.1 {Tcl_SplitPath: mac} {
+if {[tcltest::testConstraint testsetplatform]} {
+ testsetplatform $platform
+}
+
+test filename-4.19 {Tcl_SplitPath} {
+ set oldDir [pwd]
+ set res [catch {
+ cd [temporaryDirectory]
+ file mkdir tildetmp
+ set nastydir [file join tildetmp ./~tilde]
+ file mkdir $nastydir
+ set norm [file normalize $nastydir]
+ cd tildetmp
+ cd ./~tilde
+ glob -nocomplain *
+ set idx [string first tildetmp $norm]
+ set norm [string range $norm $idx end]
+ # fix path away so all platforms are the same
+ regsub {(.*):$} $norm {\1} norm
+ regsub -all ":" $norm "/" norm
+ # make sure we can delete the directory we created
+ cd $oldDir
+ file delete -force $nastydir
+ set norm
+ } err]
+ cd $oldDir
+ catch {file delete -force tildetmp}
+ list $res $err
+} {0 tildetmp/~tilde}
+
+test filename-5.1 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:b
} {a: b}
-test filename-5.2 {Tcl_SplitPath: mac} {
+test filename-5.2 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:b:c
} {a: b c}
-test filename-5.3 {Tcl_SplitPath: mac} {
+test filename-5.3 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:b:c:
} {a: b c}
-test filename-5.4 {Tcl_SplitPath: mac} {
+test filename-5.4 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:
} {a:}
-test filename-5.5 {Tcl_SplitPath: mac} {
+test filename-5.5 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a::
} {a: ::}
-test filename-5.6 {Tcl_SplitPath: mac} {
+test filename-5.6 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:::
} {a: :: ::}
-test filename-5.7 {Tcl_SplitPath: mac} {
+test filename-5.7 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split :a
} {a}
-test filename-5.8 {Tcl_SplitPath: mac} {
+test filename-5.8 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split :a::
} {a ::}
-test filename-5.9 {Tcl_SplitPath: mac} {
+test filename-5.9 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split :
} {:}
-test filename-5.10 {Tcl_SplitPath: mac} {
+test filename-5.10 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ::
} {::}
-test filename-5.11 {Tcl_SplitPath: mac} {
+test filename-5.11 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split :::
} {:: ::}
-test filename-5.12 {Tcl_SplitPath: mac} {
+test filename-5.12 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:::b
} {a: :: :: b}
-test filename-5.13 {Tcl_SplitPath: mac} {
+test filename-5.13 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /a:b
} {/a: b}
-test filename-5.14 {Tcl_SplitPath: mac} {
+test filename-5.14 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~:
} {~:}
-test filename-5.15 {Tcl_SplitPath: mac} {
+test filename-5.15 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~/:
} {~/:}
-test filename-5.16 {Tcl_SplitPath: mac} {
+test filename-5.16 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~:foo
} {~: foo}
-test filename-5.17 {Tcl_SplitPath: mac} {
+test filename-5.17 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~/foo
} {~: foo}
-test filename-5.18 {Tcl_SplitPath: mac} {
+test filename-5.18 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~foo:
} {~foo:}
-test filename-5.19 {Tcl_SplitPath: mac} {
+test filename-5.19 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:~foo
} {a: :~foo}
-test filename-5.20 {Tcl_SplitPath: mac} {
+test filename-5.20 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /
} {:/}
-test filename-5.21 {Tcl_SplitPath: mac} {
+test filename-5.21 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:b/c
} {a: :b/c}
-test filename-5.22 {Tcl_SplitPath: mac} {
+test filename-5.22 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /foo
} {foo:}
-test filename-5.23 {Tcl_SplitPath: mac} {
+test filename-5.23 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /a/b
} {a: b}
-test filename-5.24 {Tcl_SplitPath: mac} {
+test filename-5.24 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /a/b/foo
} {a: b foo}
-test filename-5.25 {Tcl_SplitPath: mac} {
+test filename-5.25 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a/b
} {a b}
-test filename-5.26 {Tcl_SplitPath: mac} {
+test filename-5.26 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ./foo/bar
} {: foo bar}
-test filename-5.27 {Tcl_SplitPath: mac} {
+test filename-5.27 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ../foo/bar
} {:: foo bar}
-test filename-5.28 {Tcl_SplitPath: mac} {
+test filename-5.28 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split {}
} {}
-test filename-5.29 {Tcl_SplitPath: mac} {
+test filename-5.29 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split .
} {:}
-test filename-5.30 {Tcl_SplitPath: mac} {
+test filename-5.30 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ././
} {: :}
-test filename-5.31 {Tcl_SplitPath: mac} {
+test filename-5.31 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ././.
} {: : :}
-test filename-5.32 {Tcl_SplitPath: mac} {
+test filename-5.32 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ../
} {::}
-test filename-5.33 {Tcl_SplitPath: mac} {
+test filename-5.33 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ..
} {::}
-test filename-5.34 {Tcl_SplitPath: mac} {
+test filename-5.34 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ../..
} {:: ::}
-test filename-5.35 {Tcl_SplitPath: mac} {
+test filename-5.35 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split //foo
} {foo:}
-test filename-5.36 {Tcl_SplitPath: mac} {
+test filename-5.36 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split foo//bar
} {foo bar}
-test filename-5.37 {Tcl_SplitPath: mac} {
+test filename-5.37 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~foo
} {~foo:}
-test filename-5.38 {Tcl_SplitPath: mac} {
+test filename-5.38 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~
} {~:}
-test filename-5.39 {Tcl_SplitPath: mac} {
+test filename-5.39 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split foo
} {foo}
-test filename-5.40 {Tcl_SplitPath: mac} {
+test filename-5.40 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~/
} {~:}
-test filename-5.41 {Tcl_SplitPath: mac} {
+test filename-5.41 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~foo/~bar
} {~foo: :~bar}
-test filename-5.42 {Tcl_SplitPath: mac} {
+test filename-5.42 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split ~foo/~bar/~baz
} {~foo: :~bar :~baz}
-test filename-5.43 {Tcl_SplitPath: mac} {
+test filename-5.43 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split foo/bar~/baz
} {foo bar~ baz}
-test filename-5.44 {Tcl_SplitPath: mac} {
+test filename-5.44 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a/../b
} {a :: b}
-test filename-5.45 {Tcl_SplitPath: mac} {
+test filename-5.45 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a/../../b
} {a :: :: b}
-test filename-5.46 {Tcl_SplitPath: mac} {
+test filename-5.46 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a/.././../b
} {a :: : :: b}
-test filename-5.47 {Tcl_SplitPath: mac} {
+test filename-5.47 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /../bar
} {bar:}
-test filename-5.48 {Tcl_SplitPath: mac} {
+test filename-5.48 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /./bar
} {bar:}
-test filename-5.49 {Tcl_SplitPath: mac} {
+test filename-5.49 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split //.//.././bar
} {bar:}
-test filename-5.50 {Tcl_SplitPath: mac} {
+test filename-5.50 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split /..
} {:/..}
-test filename-5.51 {Tcl_SplitPath: mac} {
+test filename-5.51 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split //.//.././
} {://.//.././}
-test filename-6.1 {Tcl_SplitPath: win} {
+test filename-6.1 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /
} {/}
-test filename-6.2 {Tcl_SplitPath: win} {
+test filename-6.2 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo
} {/ foo}
-test filename-6.3 {Tcl_SplitPath: win} {
+test filename-6.3 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo/bar
} {/ foo bar}
-test filename-6.4 {Tcl_SplitPath: win} {
+test filename-6.4 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo/bar/baz
} {/ foo bar baz}
-test filename-6.5 {Tcl_SplitPath: win} {
+test filename-6.5 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split foo/bar
} {foo bar}
-test filename-6.6 {Tcl_SplitPath: win} {
+test filename-6.6 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ./foo/bar
} {. foo bar}
-test filename-6.7 {Tcl_SplitPath: win} {
+test filename-6.7 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /foo/../././foo/bar
} {/ foo .. . . foo bar}
-test filename-6.8 {Tcl_SplitPath: win} {
+test filename-6.8 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ../foo/bar
} {.. foo bar}
-test filename-6.9 {Tcl_SplitPath: win} {
+test filename-6.9 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split {}
} {}
-test filename-6.10 {Tcl_SplitPath: win} {
+test filename-6.10 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split .
} {.}
-test filename-6.11 {Tcl_SplitPath: win} {
+test filename-6.11 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ../
} {..}
-test filename-6.12 {Tcl_SplitPath: win} {
+test filename-6.12 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ../..
} {.. ..}
-test filename-6.13 {Tcl_SplitPath: win} {
+test filename-6.13 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split //foo
} {/ foo}
-test filename-6.14 {Tcl_SplitPath: win} {
+test filename-6.14 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split foo//bar
} {foo bar}
-test filename-6.15 {Tcl_SplitPath: win} {
+test filename-6.15 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /\\/foo//bar
} {//foo/bar}
-test filename-6.16 {Tcl_SplitPath: win} {
+test filename-6.16 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /\\/foo//bar
} {//foo/bar}
-test filename-6.17 {Tcl_SplitPath: win} {
+test filename-6.17 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split /\\/foo//bar
} {//foo/bar}
-test filename-6.18 {Tcl_SplitPath: win} {
+test filename-6.18 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split \\\\foo\\bar
} {//foo/bar}
-test filename-6.19 {Tcl_SplitPath: win} {
+test filename-6.19 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split \\\\foo\\bar/baz
} {//foo/bar baz}
-test filename-6.20 {Tcl_SplitPath: win} {
+test filename-6.20 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:/foo
} {c:/ foo}
-test filename-6.21 {Tcl_SplitPath: win} {
+test filename-6.21 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:foo
} {c: foo}
-test filename-6.22 {Tcl_SplitPath: win} {
+test filename-6.22 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:
} {c:}
-test filename-6.23 {Tcl_SplitPath: win} {
+test filename-6.23 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:\\
} {c:/}
-test filename-6.24 {Tcl_SplitPath: win} {
+test filename-6.24 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:/
} {c:/}
-test filename-6.25 {Tcl_SplitPath: win} {
+test filename-6.25 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:/./..
} {c:/ . ..}
-test filename-6.26 {Tcl_SplitPath: win} {
+test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo
} {~foo}
-test filename-6.27 {Tcl_SplitPath: win} {
+test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo/~bar
} {~foo ./~bar}
-test filename-6.28 {Tcl_SplitPath: win} {
+test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split ~foo/~bar/~baz
} {~foo ./~bar ./~baz}
-test filename-6.29 {Tcl_SplitPath: win} {
+test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split foo/bar~/baz
} {foo bar~ baz}
-test filename-6.30 {Tcl_SplitPath: win} {
+test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} {
testsetplatform win
file split c:~foo
} {c: ./~foo}
-test filename-7.1 {Tcl_JoinPath: unix} {
+test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join / a
} {/a}
-test filename-7.2 {Tcl_JoinPath: unix} {
+test filename-7.2 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a b
} {a/b}
-test filename-7.3 {Tcl_JoinPath: unix} {
+test filename-7.3 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a c /b d
} {/b/d}
-test filename-7.4 {Tcl_JoinPath: unix} {
+test filename-7.4 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /
} {/}
-test filename-7.5 {Tcl_JoinPath: unix} {
+test filename-7.5 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a
} {a}
-test filename-7.6 {Tcl_JoinPath: unix} {
+test filename-7.6 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join {}
} {}
-test filename-7.7 {Tcl_JoinPath: unix} {
+test filename-7.7 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a/ b
} {/a/b}
-test filename-7.8 {Tcl_JoinPath: unix} {
+test filename-7.8 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a// b
} {/a/b}
-test filename-7.9 {Tcl_JoinPath: unix} {
+test filename-7.9 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /a/./../. b
} {/a/./.././b}
-test filename-7.10 {Tcl_JoinPath: unix} {
+test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~ a
} {~/a}
-test filename-7.11 {Tcl_JoinPath: unix} {
+test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ~a ~b
} {~b}
-test filename-7.12 {Tcl_JoinPath: unix} {
+test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a b
} {./~a/b}
-test filename-7.13 {Tcl_JoinPath: unix} {
+test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a ~b
} {~b}
-test filename-7.14 {Tcl_JoinPath: unix} {
+test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join ./~a ./~b
} {./~a/~b}
-test filename-7.15 {Tcl_JoinPath: unix} {
+test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . b
} {a/./b}
-test filename-7.16 {Tcl_JoinPath: unix} {
+test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join a . ./~b
} {a/./~b}
-test filename-7.17 {Tcl_JoinPath: unix} {
+test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join //a b
} {/a/b}
-test filename-7.18 {Tcl_JoinPath: unix} {
+test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
file join /// a b
} {/a/b}
-test filename-8.1 {Tcl_JoinPath: mac} {
+test filename-8.1 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a b
} {:a:b}
-test filename-8.2 {Tcl_JoinPath: mac} {
+test filename-8.2 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join :a b
} {:a:b}
-test filename-8.3 {Tcl_JoinPath: mac} {
+test filename-8.3 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a b:
} {b:}
-test filename-8.4 {Tcl_JoinPath: mac} {
+test filename-8.4 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a: :b
} {a:b}
-test filename-8.5 {Tcl_JoinPath: mac} {
+test filename-8.5 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a: :b:
} {a:b}
-test filename-8.6 {Tcl_JoinPath: mac} {
+test filename-8.6 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a :: b
} {:a::b}
-test filename-8.7 {Tcl_JoinPath: mac} {
+test filename-8.7 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a :: :: b
} {:a:::b}
-test filename-8.8 {Tcl_JoinPath: mac} {
+test filename-8.8 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a ::: b
} {:a:::b}
-test filename-8.9 {Tcl_JoinPath: mac} {
+test filename-8.9 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a: b:
} {b:}
-test filename-8.10 {Tcl_JoinPath: mac} {
+test filename-8.10 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join /a/b
} {a:b}
-test filename-8.11 {Tcl_JoinPath: mac} {
+test filename-8.11 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join /a/b c/d
} {a:b:c:d}
-test filename-8.12 {Tcl_JoinPath: mac} {
+test filename-8.12 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join /a/b :c:d
} {a:b:c:d}
-test filename-8.13 {Tcl_JoinPath: mac} {
+test filename-8.13 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join ~ foo
} {~:foo}
-test filename-8.14 {Tcl_JoinPath: mac} {
+test filename-8.14 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join :: ::
} {:::}
-test filename-8.15 {Tcl_JoinPath: mac} {
+test filename-8.15 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a: ::
} {a::}
-test filename-8.16 {Tcl_JoinPath: mac} {
+test filename-8.16 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a {} b
} {:a:b}
-test filename-8.17 {Tcl_JoinPath: mac} {
+test filename-8.17 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a::: b
} {a:::b}
-test filename-8.18 {Tcl_JoinPath: mac} {
+test filename-8.18 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a : : :
} {:a}
-test filename-8.19 {Tcl_JoinPath: mac} {
+test filename-8.19 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join :
} {:}
-test filename-8.20 {Tcl_JoinPath: mac} {
+test filename-8.20 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join : a
} {:a}
-test filename-8.21 {Tcl_JoinPath: mac} {
+test filename-8.21 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join a: :b/c
} {a:b/c}
-test filename-8.22 {Tcl_JoinPath: mac} {
+test filename-8.22 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
file join :a :b/c
} {:a:b/c}
-test filename-9.1 {Tcl_JoinPath: win} {
+test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join a b
} {a/b}
-test filename-9.2 {Tcl_JoinPath: win} {
+test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join /a b
} {/a/b}
-test filename-9.3 {Tcl_JoinPath: win} {
+test filename-9.3 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join /a /b
} {/b}
-test filename-9.4 {Tcl_JoinPath: win} {
+test filename-9.4 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join c: foo
} {c:foo}
-test filename-9.5 {Tcl_JoinPath: win} {
+test filename-9.5 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join c:/ foo
} {c:/foo}
-test filename-9.6 {Tcl_JoinPath: win} {
+test filename-9.6 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join c:\\bar foo
} {c:/bar/foo}
-test filename-9.7 {Tcl_JoinPath: win} {
+test filename-9.7 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join /foo c:bar
} {c:bar}
-test filename-9.8 {Tcl_JoinPath: win} {
+test filename-9.8 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ///host//share dir
} {//host/share/dir}
-test filename-9.9 {Tcl_JoinPath: win} {
+test filename-9.9 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~ foo
} {~/foo}
-test filename-9.10 {Tcl_JoinPath: win} {
+test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~/~foo
} {~/~foo}
-test filename-9.11 {Tcl_JoinPath: win} {
+test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ~ ./~foo
} {~/~foo}
-test filename-9.12 {Tcl_JoinPath: win} {
+test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join / ~foo
} {~foo}
-test filename-9.13 {Tcl_JoinPath: win} {
+test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ./a/ b c
} {./a/b/c}
-test filename-9.14 {Tcl_JoinPath: win} {
+test filename-9.14 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join ./~a/ b c
} {./~a/b/c}
-test filename-9.15 {Tcl_JoinPath: win} {
+test filename-9.15 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join // host share path
} {/host/share/path}
-test filename-9.16 {Tcl_JoinPath: win} {
+test filename-9.16 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo . bar
} {foo/./bar}
-test filename-9.17 {Tcl_JoinPath: win} {
+test filename-9.17 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo .. bar
} {foo/../bar}
-test filename-9.18 {Tcl_JoinPath: win} {
+test filename-9.18 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo/./bar
} {foo/./bar}
-test filename-10.1 {Tcl_TranslateFileName} {
+test filename-10.1 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform unix
list [catch {testtranslatefilename foo} msg] $msg
} {0 foo}
-test filename-10.2 {Tcl_TranslateFileName} {
+test filename-10.2 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
list [catch {testtranslatefilename {c:/foo}} msg] $msg
} {0 {c:\foo}}
-test filename-10.3 {Tcl_TranslateFileName} {
+test filename-10.3 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg
} {0 {c:\foo}}
-test filename-10.4 {Tcl_TranslateFileName} {
+test filename-10.4 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform mac
list [catch {testtranslatefilename foo} msg] $msg
} {0 :foo}
-test filename-10.5 {Tcl_TranslateFileName} {
+test filename-10.5 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform mac
list [catch {testtranslatefilename :~foo} msg] $msg
} {0 :~foo}
-test filename-10.6 {Tcl_TranslateFileName} {
+test filename-10.6 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test"
set env(HOME) $temp
set result
} {0 /home/test/foo}
-test filename-10.7 {Tcl_TranslateFileName} {
+test filename-10.7 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
unset env(HOME)
set env(HOME) $temp
set result
} {1 {couldn't find HOME environment variable to expand path}}
-test filename-10.8 {Tcl_TranslateFileName} {
+test filename-10.8 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test"
set env(HOME) $temp
set result
} {0 /home/test}
-test filename-10.9 {Tcl_TranslateFileName} {
+test filename-10.9 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test/"
set env(HOME) $temp
set result
} {0 /home/test}
-test filename-10.10 {Tcl_TranslateFileName} {
+test filename-10.10 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "/home/test/"
set env(HOME) $temp
set result
} {0 /home/test/foo}
-test filename-10.11 {Tcl_TranslateFileName} {
+test filename-10.11 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "Root:"
set env(HOME) $temp
set result
} {0 Root:foo}
-test filename-10.12 {Tcl_TranslateFileName} {
+test filename-10.12 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "Root:home"
set env(HOME) $temp
set result
} {0 Root:home:foo}
-test filename-10.13 {Tcl_TranslateFileName} {
+test filename-10.13 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "Root:home"
set env(HOME) $temp
set result
} {0 Root:home::foo}
-test filename-10.14 {Tcl_TranslateFileName} {
+test filename-10.14 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "Root:home"
set env(HOME) $temp
set result
} {0 Root:home}
-test filename-10.15 {Tcl_TranslateFileName} {
+test filename-10.15 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "Root:home:"
set env(HOME) $temp
set result
} {0 Root:home::foo}
-test filename-10.16 {Tcl_TranslateFileName} {
+test filename-10.16 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "Root:home::"
set env(HOME) $temp
set result
} {0 Root:home:::foo}
-test filename-10.17 {Tcl_TranslateFileName} {
+test filename-10.17 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "\\home\\"
set env(HOME) $temp
set result
} {0 {\home\foo}}
-test filename-10.18 {Tcl_TranslateFileName} {
+test filename-10.18 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "\\home\\"
set env(HOME) $temp
set result
} {0 {\home\foo\bar}}
-test filename-10.19 {Tcl_TranslateFileName} {
+test filename-10.19 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "c:"
set env(HOME) $temp
set result
} {0 c:foo}
-test filename-10.20 {Tcl_TranslateFileName} {
+test filename-10.20 {Tcl_TranslateFileName} {testtranslatefilename} {
list [catch {testtranslatefilename ~blorp/foo} msg] $msg
} {1 {user "blorp" doesn't exist}}
-test filename-10.21 {Tcl_TranslateFileName} {
+test filename-10.21 {Tcl_TranslateFileName} {testsetplatform} {
global env
set temp $env(HOME)
set env(HOME) "c:\\"
set env(HOME) $temp
set result
} {0 {c:\foo}}
-test filename-10.22 {Tcl_TranslateFileName} {
+test filename-10.22 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
list [catch {testtranslatefilename foo//bar} msg] $msg
} {0 {foo\bar}}
-testsetplatform $platform
+if {[tcltest::testConstraint testsetplatform]} {
+ testsetplatform $platform
+}
test filename-10.23 {Tcl_TranslateFileName} {unixOnly nonPortable} {
# this test fails if ~ouster is not /home/ouster
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
test filename-11.2 {Tcl_GlobCmd} {
list [catch {glob -gorp} msg] $msg
-} {1 {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -types, or --}}
+} {1 {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
test filename-11.3 {Tcl_GlobCmd} {
list [catch {glob -nocomplai} msg] $msg
} {1 {wrong # args: should be "glob ?switches? name ?name ...?"}}
test filename-11.8 {Tcl_GlobCmd} {
list [catch {glob -nocomplain -- -nocomplain} msg] $msg
} {0 {}}
-test filename-11.9 {Tcl_GlobCmd} {
+test filename-11.9 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
list [catch {glob ~\\xyqrszzz/bar} msg] $msg
} {1 {user "\xyqrszzz" doesn't exist}}
-test filename-11.10 {Tcl_GlobCmd} {
+test filename-11.10 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
list [catch {glob -nocomplain ~\\xyqrszzz/bar} msg] $msg
} {0 {}}
-test filename-11.11 {Tcl_GlobCmd} {
+test filename-11.11 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
list [catch {glob ~xyqrszzz\\/\\bar} msg] $msg
} {1 {user "xyqrszzz" doesn't exist}}
-test filename-11.12 {Tcl_GlobCmd} {
+test filename-11.12 {Tcl_GlobCmd} {testsetplatform} {
testsetplatform unix
set home $env(HOME)
unset env(HOME)
set x
} {1 {couldn't find HOME environment variable to expand path}}
-testsetplatform $platform
+if {[tcltest::testConstraint testsetplatform]} {
+ testsetplatform $platform
+}
test filename-11.13 {Tcl_GlobCmd} {
list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]
+set oldpwd [pwd]
set oldhome $env(HOME)
+cd [temporaryDirectory]
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
set globname "globTest"
set horribleglobname "glob\[\{Test"
-test filename-11.17 {Tcl_GlobCmd} {
+test filename-11.17 {Tcl_GlobCmd} {unixOnly} {
+ list [catch {lsort [glob -directory $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.17.1 {Tcl_GlobCmd} {pcOnly macOnly} {
list [catch {lsort [glob -directory $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
-test filename-11.18 {Tcl_GlobCmd} {
+if {[string equal $tcl_platform(platform) "windows"]} {
+ if {[string index $tcl_platform(osVersion) 0] >= 5 \
+ && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
+ tcltest::testConstraint linkDirectory 1
+ } else {
+ tcltest::testConstraint linkDirectory 0
+ }
+} else {
+ tcltest::testConstraint linkDirectory 1
+}
+test filename-11.17.2 {Tcl_GlobCmd} {notRoot linkDirectory} {
+ set dir [pwd]
+ set ret "error in test"
+ if {[catch {
+ cd $globname
+ file link -symbolic link a1
+ cd $dir
+ set ret [list [catch {
+ lsort [glob -directory $globname -join * b1]
+ } msg] $msg]
+ }]} {
+ cd $dir
+ }
+ file delete [file join $globname link]
+ set ret
+} [list 0 [lsort [list [file join $globname a1 b1] \
+ [file join $globname link b1]]]]
+# Simpler version of the above test to illustrate a given bug.
+test filename-11.17.3 {Tcl_GlobCmd} {notRoot linkDirectory} {
+ set dir [pwd]
+ set ret "error in test"
+ if {[catch {
+ cd $globname
+ file link -symbolic link a1
+ cd $dir
+ set ret [list [catch {
+ lsort [glob -directory $globname -type d *]
+ } msg] $msg]
+ }]} {
+ cd $dir
+ }
+ file delete [file join $globname link]
+ set ret
+} [list 0 [lsort [list [file join $globname a1] \
+ [file join $globname a2] \
+ [file join $globname a3] \
+ [file join $globname link]]]]
+# Make sure the bugfix isn't too simple. We don't want
+# to break 'glob -type l'.
+test filename-11.17.4 {Tcl_GlobCmd} {notRoot linkDirectory} {
+ set dir [pwd]
+ set ret "error in test"
+ if {[catch {
+ cd $globname
+ file link -symbolic link a1
+ cd $dir
+ set ret [list [catch {
+ lsort [glob -directory $globname -type l *]
+ } msg] $msg]
+ }]} {
+ cd $dir
+ }
+ file delete [file join $globname link]
+ set ret
+} [list 0 [list [file join $globname link]]]
+test filename-11.17.5 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -directory $globname -tails *.c]} msg] $msg
+} [list 0 [lsort [list "weird name.c" x,z1.c x1.c y1.c z1.c]]]
+test filename-11.17.6 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -directory $globname -tails *.c *.c]} msg] $msg
+} [list 0 [lsort [concat [list "weird name.c" x,z1.c x1.c y1.c z1.c] \
+ [list "weird name.c" x,z1.c x1.c y1.c z1.c]]]]
+test filename-11.18 {Tcl_GlobCmd} {unixOnly} {
+ list [catch {lsort [glob -path $globname/ *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.18.1 {Tcl_GlobCmd} {pcOnly macOnly} {
list [catch {lsort [glob -path $globname/ *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname .1]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.19 {Tcl_GlobCmd} {unixOnly} {
+ list [catch {lsort [glob -join -path \
+ [string range $globname 0 5] * *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
-test filename-11.19 {Tcl_GlobCmd} {
+test filename-11.19.1 {Tcl_GlobCmd} {pcOnly macOnly} {
list [catch {lsort [glob -join -path \
[string range $globname 0 5] * *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
list [catch {lsort [glob -type d -path $globname *]} msg] $msg
} [list 0 [lsort [list $globname]]]
+# Get rid of file/dir if it exists, since it will have
+# been left behind by a previous failed run.
+if {[file exists $horribleglobname]} {
+ file delete -force $horribleglobname
+}
file rename globTest $horribleglobname
set globname $horribleglobname
-test filename-11.22 {Tcl_GlobCmd} {
+test filename-11.22 {Tcl_GlobCmd} {unixOnly} {
+ list [catch {lsort [glob -dir $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.22.1 {Tcl_GlobCmd} {pcOnly macOnly} {
list [catch {lsort [glob -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
-test filename-11.23 {Tcl_GlobCmd} {
+test filename-11.23 {Tcl_GlobCmd} {unixOnly} {
list [catch {lsort [glob -path $globname/ *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname a3]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
-test filename-11.24 {Tcl_GlobCmd} {
+test filename-11.23.1 {Tcl_GlobCmd} {pcOnly macOnly} {
+ list [catch {lsort [glob -path $globname/ *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname .1]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.24 {Tcl_GlobCmd} {unixOnly} {
+ list [catch {lsort [glob -join -path \
+ [string range $globname 0 5] * *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname a3]\
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-11.24.1 {Tcl_GlobCmd} {pcOnly macOnly} {
list [catch {lsort [glob -join -path \
[string range $globname 0 5] * *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
+ [file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
} [list 0 [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]]
+test filename-11.25.1 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -type {d r} -dir $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1]\
+ [file join $globname a2]\
+ [file join $globname a3]]]]
+test filename-11.25.2 {Tcl_GlobCmd} {
+ list [catch {lsort [glob -type {d r w} -dir $globname *]} msg] $msg
+} [list 0 [lsort [list [file join $globname a1]\
+ [file join $globname a2]\
+ [file join $globname a3]]]]
test filename-11.26 {Tcl_GlobCmd} {
list [catch {glob -type d -path $globname *} msg] $msg
} [list 0 [list $globname]]
} {1 {missing argument to "-directory"}}
test filename-11.35 {Tcl_GlobCmd} {
list [catch {glob -paths *} msg] $msg
-} {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -types, or --}}
+} {1 {bad option "-paths": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
+# Test '-tails' flag to glob.
+test filename-11.36 {Tcl_GlobCmd} {
+ list [catch {glob -tails *} msg] $msg
+} {1 {"-tails" must be used with either "-directory" or "-path"}}
+test filename-11.37 {Tcl_GlobCmd} {
+ list [catch {glob -type d -tails -path $globname *} msg] $msg
+} [list 0 [list $globname]]
+test filename-11.38 {Tcl_GlobCmd} {
+ list [catch {glob -tails -path $globname *} msg] $msg
+} [list 0 [list $globname]]
+test filename-11.39 {Tcl_GlobCmd} {
+ list [catch {glob -tails -join -path $globname *} msg] $msg
+} [list 0 [list $globname]]
+test filename-11.40 {Tcl_GlobCmd} {
+ expr {[glob -dir [pwd] -tails *] == [glob *]}
+} {1}
+test filename-11.41 {Tcl_GlobCmd} {
+ expr {[glob -dir [pwd] -tails *] != [glob -dir [pwd] *]}
+} {1}
+test filename-11.42 {Tcl_GlobCmd} {
+ set res [list]
+ foreach f [glob -dir [pwd] *] {
+ lappend res [file tail $f]
+ }
+ expr {$res == [glob *]}
+} {1}
+test filename-11.43 {Tcl_GlobCmd} {
+ list [catch {glob -t *} msg] $msg
+} {1 {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
+test filename-11.44 {Tcl_GlobCmd} {
+ list [catch {glob -tails -path hello -directory hello *} msg] $msg
+} {1 {"-directory" cannot be used with "-path"}}
+test filename-11.45 {Tcl_GlobCmd on root volume} {
+ set res1 ""
+ set res2 ""
+ catch {
+ set res1 [glob -dir [lindex [file volumes] 0] -tails *]
+ }
+ catch {
+ set tmpd [pwd]
+ cd [lindex [file volumes] 0]
+ set res2 [glob *]
+ cd $tmpd
+ }
+ expr {$res1 == $res2}
+} {1}
+test filename-11.46 {Tcl_GlobCmd} {
+ list [catch {glob -types abcde -dir foo *} msg] $msg
+} {1 {bad argument to "-types": abcde}}
+test filename-11.47 {Tcl_GlobCmd} {
+ list [catch {glob -types abcde -path foo *} msg] $msg
+} {1 {bad argument to "-types": abcde}}
+test filename-11.48 {Tcl_GlobCmd} {
+ list [catch {glob -types abcde -dir foo -join * *} msg] $msg
+} {1 {bad argument to "-types": abcde}}
+test filename-11.49 {Tcl_GlobCmd} {
+ list [catch {glob -types abcde -path foo -join * *} msg] $msg
+} {1 {bad argument to "-types": abcde}}
file rename $horribleglobname globTest
set globname globTest
test filename-12.1 {simple globbing} {unixOrPc} {
list [catch {glob {}} msg] $msg
} {0 .}
+test filename-12.1.1 {simple globbing} {unixOrPc} {
+ list [catch {glob -types f {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
+test filename-12.1.2 {simple globbing} {unixOrPc} {
+ list [catch {glob -types d {}} msg] $msg
+} {0 .}
+test filename-12.1.3 {simple globbing} {unixOnly} {
+ list [catch {glob -types hidden {}} msg] $msg
+} {0 .}
+test filename-12.1.4 {simple globbing} {pcOnly} {
+ list [catch {glob -types hidden {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
+test filename-12.1.5 {simple globbing} {pcOnly} {
+ list [catch {glob -types hidden c:/} msg] $msg
+} {1 {no files matched glob pattern "c:/"}}
+test filename-12.1.6 {simple globbing} {pcOnly} {
+ list [catch {glob c:/} msg] $msg
+} {0 c:/}
test filename-12.2 {simple globbing} {macOnly} {
list [catch {glob {}} msg] $msg
} {0 :}
+test filename-12.2.1 {simple globbing} {macOnly} {
+ list [catch {glob -types f {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
+test filename-12.2.2 {simple globbing} {macOnly} {
+ list [catch {glob -types d {}} msg] $msg
+} {0 :}
+test filename-12.2.3 {simple globbing} {macOnly} {
+ list [catch {glob -types hidden {}} msg] $msg
+} {1 {no files matched glob pattern ""}}
test filename-12.3 {simple globbing} {
list [catch {glob -nocomplain \{a1,a2\}} msg] $msg
} {0 {}}
if {$tcl_platform(platform) == "macintosh"} {
- set globPreResult :globTest:
+ set globPreResult :globTest:
} else {
- set globPreResult globTest/
+ set globPreResult globTest/
}
set x1 x1.c
set y1 y1.c
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
+
+# The current directory could be anywhere; do this to stop spurious matches
+file mkdir globTestContext
+file rename globTest [file join globTestContext globTest]
+set savepwd [pwd]
+cd globTestContext
+
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
-test filename-14.7 {asterisks, question marks, and brackets} {unixOrPc} {
+
+# Reset to where we were
+cd $savepwd
+file rename [file join globTestContext globTest] globTest
+file delete globTestContext
+
+test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
+test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} {
+ lsort [glob globTest/*]
+} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/*]
} {:globTest:.1 :globTest:a1 :globTest:a2 :globTest:a3 {:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.24 {slash globbing} {pcOnly} {
glob {\\}
} /
-test filename-14.25 {type specific globbing} {
+test filename-14.25 {type specific globbing} {unixOnly} {
+ list [catch {lsort [glob -dir globTest -types f *]} msg] $msg
+} [list 0 [lsort [list \
+ [file join $globname "weird name.c"]\
+ [file join $globname x,z1.c]\
+ [file join $globname x1.c]\
+ [file join $globname y1.c] [file join $globname z1.c]]]]
+test filename-14.25.1 {type specific globbing} {pcOnly macOnly} {
list [catch {lsort [glob -dir globTest -types f *]} msg] $msg
} [list 0 [lsort [list \
+ [file join $globname .1]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.
-catch {exec chmod 000 globTest/a1}
+catch {file attributes globTest/a1 -permissions 0000}
test filename-15.1 {unix specific globbing} {unixOnly nonPortable} {
string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
glob -nocomplain globTest/a1/*
} {}
test filename-15.3 {unix specific no complain: no errors, good result} \
- {unixOnly nonPortable knownBug} {
+ {unixOnly nonPortable} {
# test fails because if an error occur , the interp's result
# is reset...
glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}
-catch {exec chmod 755 globTest/a1}
+catch {file attributes globTest/a1 -permissions 0755}
test filename-15.4 {unix specific no complain: no errors, good result} \
- {unixOnly nonPortable knownBug} {
+ {unixOnly nonPortable} {
# test fails because if an error occurs, the interp's result
# is reset... or you don't run at scriptics where the
# outser and welch users exists
glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
+test filename-15.4.1 {no complain: no errors, good result} {
+ # test used to fail because if an error occurs, the interp's result
+ # is reset...
+ string equal [glob -nocomplain ~wontexist ~blah ~] \
+ [glob -nocomplain ~ ~blah ~wontexist]
+} {1}
test filename-15.5 {unix specific globbing} {unixOnly nonPortable} {
glob ~ouster/.csh*
} "/home/ouster/.cshrc"
set result [list [catch {glob ~} msg] $msg]
set env(HOME) $temp
set result
-} [list 0 [list [glob ~]/globTest/odd\\\[\]*?\{\}name]]
-catch {exec rm -f globTest/odd\\\[\]*?\{\}name}
-
+} [list 0 [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name]]
+catch {file delete -force globTest/odd\\\[\]*?\{\}name}
# The following tests are only valid for Windows systems.
-set temp [pwd]
-catch {cd c:/}
-catch {
+set oldDir [pwd]
+if {$::tcltest::testConstraints(pcOnly)} {
cd c:/
- removeDirectory globTest
- makeDirectory globTest
+ file delete -force globTest
+ file mkdir globTest
close [open globTest/x1.BAT w]
close [open globTest/y1.Bat w]
close [open globTest/z1.bat w]
glob c:/
} c:/
test filename-16.5 {windows specific globbing} {pcOnly} {
- glob c:*Test
+ glob c:*bTest
} c:globTest
test filename-16.6 {windows specific globbing} {pcOnly} {
- glob c:\\\\*Test
+ glob c:\\\\*bTest
} c:/globTest
test filename-16.7 {windows specific globbing} {pcOnly} {
- glob c:/*Test
+ glob c:/*bTest
} c:/globTest
test filename-16.8 {windows specific globbing} {pcOnly} {
lsort [glob c:globTest/*.bat]
test filename-16.12 {windows specific globbing} {pcOnly sharedCdrive} {
cd //[info hostname]/c
- removeDirectory globTest
- makeDirectory globTest
- close [open globTest/x1.BAT w]
- close [open globTest/y1.Bat w]
- close [open globTest/z1.bat w]
glob //[info hostname]/c/*Test
} //[info hostname]/c/globTest
test filename-16.13 {windows specific globbing} {pcOnly sharedCdrive} {
cd //[info hostname]/c
- removeDirectory globTest
- makeDirectory globTest
- close [open globTest/x1.BAT w]
- close [open globTest/y1.Bat w]
- close [open globTest/z1.bat w]
glob "\\\\\\\\[info hostname]\\\\c\\\\*Test"
} //[info hostname]/c/globTest
+test filename-16.14 {windows specific globbing} {pcOnly} {
+ cd [lindex [glob -types d -dir C:/ *] 0]
+ expr {[lsearch -exact [glob {{.,*}*}] ".."] != -1}
+} {1}
+test filename-16.15 {windows specific globbing} {pcOnly} {
+ cd [lindex [glob -types d -dir C:/ *] 0]
+ glob ..
+} {..}
+test filename-16.16 {windows specific globbing} {pcOnly} {
+ file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
+} {..}
# cleanup
-file delete -force //[info hostname]/c/globTest
-cd $temp
+catch {file delete -force C:/globTest}
file delete -force globTest
+cd $oldpwd
set env(HOME) $oldhome
-testsetplatform $platform
-catch {unset oldhome platform temp result}
+if {[tcltest::testConstraint testsetplatform]} {
+ testsetplatform $platform
+ catch {unset platform}
+}
+catch {unset oldhome temp result}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
# Test for incorrect "double evaluation" semantics
-test for-5.1 {possible delayed substitution of increment command} {knownBug} {
- # Increment should be 5, and lappend should always append 5
+test for-5.1 {possible delayed substitution of increment command} {
+ # Increment should be 5, and lappend should always append $a
catch {unset a}
catch {unset i}
set a 5
set i
} {1 6 11}
-test for-5.2 {possible delayed substitution of body command} {knownBug} {
- # Increment should be 5, and lappend should always append 5
+test for-5.2 {possible delayed substitution of increment command} {
+ # Increment should be 5, and lappend should always append $a
+ catch {rename p ""}
+ proc p {} {
+ set a 5
+ set i {}
+ for {set a 1} {$a < 12} "incr a $a" {lappend i $a}
+ set i
+ }
+ p
+} {1 6 11}
+test for-5.3 {possible delayed substitution of body command} {
+ # Increment should be $a, and lappend should always append 5
set a 5
set i {}
for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
set i
} {5 5 5 5}
+test for-5.4 {possible delayed substitution of body command} {
+ # Increment should be $a, and lappend should always append 5
+ catch {rename p ""}
+ proc p {} {
+ set a 5
+ set i {}
+ for {set a 1} {$a < 12} {incr a $a} "lappend i $a"
+ set i
+ }
+ p
+} {5 5 5 5}
# In the following tests we need to bypass the bytecode compiler by
# substituting the command from a variable. This ensures that command
test for-6.7 {Tcl_ForObjCmd: error in test expression} {
set z for
list [catch {$z {set i 0} {i < 5} {incr i} {body}} msg] $msg $errorInfo
-} {1 {syntax error in expression "i < 5"} {syntax error in expression "i < 5"
+} {1 {syntax error in expression "i < 5": variable references require preceding $} {syntax error in expression "i < 5": variable references require preceding $
while executing
"$z {set i 0} {i < 5} {incr i} {body}"}}
test for-6.8 {Tcl_ForObjCmd: test expression is enclosed in quotes} {
# cleanup
::tcltest::cleanupTests
return
-
-
catch {break foo} msg
set msg
} {wrong # args: should be "break"}
+# Check for bug #406709
+test foreach-5.5 {break tests} {
+ proc a {} {
+ set a 1
+ foreach b b {list [concat a; break]; incr a}
+ incr a
+ }
+ a
+} {2}
# Test for incorrect "double evaluation" semantics
-test foreach-6.1 {delayed substitution of body} {knownBug} {
+test foreach-6.1 {delayed substitution of body} {
proc foo {} {
set a 0
foreach a [list 1 2 3] "
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
# fail. Someday I hope this code shouldn't be necessary (code added
# 9/9/91).
-set roundOffBug 0
-if {"[format %7.1e 68.514]" == "6.8e+01"} {
- puts stdout "Note: this system has a sprintf round-off bug, some tests skipped\n"
- set roundOffBug 1
-}
+set ::tcltest::testConstraints(roundOffBug) \
+ [expr {"[format %7.1e 68.514]" != "6.8e+01"}]
test format-1.1 {integer formatting} {
format "%*d %d %d %d" 6 34 16923 -12 -1
test format-4.2 {e and f formats} {eformat} {
format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053
} { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04}
-if {!$roundOffBug} {
- test format-4.3 {e and f formats} {eformat} {
- format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
- } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
- test format-4.4 {e and f formats} {eformat} {
- format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
- } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04}
- test format-4.5 {e and f formats} {eformat} {
- format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
- } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
- test format-4.6 {e and f formats} {
- format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
- } {34200000000000.000000 68.514000 -0.125000 -16000.000000}
-}
+test format-4.3 {e and f formats} {eformat roundOffBug} {
+ format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053
+} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
+test format-4.4 {e and f formats} {eformat roundOffBug} {
+ format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053
+} {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04}
+test format-4.5 {e and f formats} {eformat roundOffBug} {
+ format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053
+} {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04}
+test format-4.6 {e and f formats roundOffBug} {
+ format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053
+} {34200000000000.000000 68.514000 -0.125000 -16000.000000}
test format-4.7 {e and f formats} {nonPortable} {
format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053
} {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001}
append b $a
}
for {set i 290} {$i < 400} {incr i} {
- test format-15.[expr $i -290] {testing MAX_FLOAT_SIZE} {
+ test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
+::tcltest::testConstraint 64bitInts \
+ [expr {0x80000000 > 0}]
+::tcltest::testConstraint wideIntExpressions \
+ [expr {wide(0x80000000) != int(0x80000000)}]
+
+test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
+ list [catch {format %d 7810179016327718216} msg] $msg
+} {1 {integer value too large to represent}}
+test format-17.2 {testing %ld with wide} {64bitInts} {
+ format %ld 7810179016327718216
+} 7810179016327718216
+test format-17.3 {testing %ld with non-wide} {64bitInts} {
+ format %ld 42
+} 42
+
# cleanup
catch {unset a}
catch {unset b}
catch {unset d}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
# The following tests are non-portable because they depend on
# word size.
-if {0x80000000 > 0} {
+if {wide(0x80000000) > wide(0)} {
test get-1.7 {Tcl_GetInt procedure} {
set x 44
- list [catch {incr x 18446744073709551616} msg] $msg $errorCode
+ list [catch {eval incr x 18446744073709551616} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
test get-1.8 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x -18446744073709551614} msg] $msg
} {0 2}
} else {
- test get-1.7 {Tcl_GetInt procedure} {
+ test get-1.11 {Tcl_GetInt procedure} {
set x 44
list [catch {incr x 4294967296} msg] $msg $errorCode
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
- test get-1.8 {Tcl_GetInt procedure} {
+ test get-1.12 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x 4294967294} msg] $msg
} {0 -2}
- test get-1.9 {Tcl_GetInt procedure} {
+ test get-1.13 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x +4294967294} msg] $msg
} {0 -2}
- test get-1.10 {Tcl_GetInt procedure} {
+ test get-1.14 {Tcl_GetInt procedure} {
set x 0
list [catch {incr x -4294967294} msg] $msg
} {0 2}
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
-set tcltest::testConstraints(notLinux) \
- [expr ![string equal Linux $tcl_platform(os)]]
if {[catch {package require http 2} version]} {
- if {[info exist http2]} {
+ if {[info exists http2]} {
catch {puts "Cannot load http 2.* package"}
return
} else {
catch {puts "Running http 2.* tests in slave interp"}
set interp [interp create http2]
$interp eval [list set http2 "running"]
+ $interp eval [list set argv $argv]
$interp eval [list source [info script]]
interp delete $interp
return
# Ensure httpd file exists
set origFile [file join $::tcltest::testsDirectory httpd]
-set newFile [file join $::tcltest::workingDirectory httpd]
-if {![file exists $newFile]} {
- file copy $origFile $newFile
+set httpdFile [file join [temporaryDirectory] httpd_[pid]]
+if {![file exists $httpdFile]} {
+ makeFile "" $httpdFile
+ file delete $httpdFile
+ file copy $origFile $httpdFile
set removeHttpd 1
}
-set httpdFile [file join $::tcltest::workingDirectory httpd]
if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
set httpthread [testthread create "
- source $httpdFile
+ source [list $httpdFile]
testthread wait
"]
testthread send $httpthread [list set port $port]
testthread send $httpthread {httpd_init $port}
puts "Running httpd in thread $httpthread"
} else {
- if ![file exists $httpdFile] {
+ if {![file exists $httpdFile]} {
puts "Cannot read $httpdFile script, http test skipped"
unset port
return
}
source $httpdFile
- if [catch {httpd_init $port} listen] {
+ # Let the OS pick the port; that's much more flexible
+ if {[catch {httpd_init 0} listen]} {
puts "Cannot start http server, http test skipped"
unset port
return
+ } else {
+ set port [lindex [fconfigure $listen -sockname] 2]
}
}
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
test http-1.5 {http::config} {
- catch {http::config -proxyhost {} -junk 8080}
-} 1
+ list [catch {http::config -proxyhost {} -junk 8080} msg] $msg
+} {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -useragent}}
+
test http-2.1 {http::reset} {
catch {http::reset http#1}
} 0
test http-3.1 {http::geturl} {
- catch {http::geturl -bogus flag}
-} 1
+ list [catch {http::geturl -bogus flag} msg] $msg
+} {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}
+
test http-3.2 {http::geturl} {
catch {http::geturl http:junk} err
set err
append query $sep$query
set sep &
}
- ::tcltest::makeFile $query outdata
- set fp [open outdata]
+ set file [makeFile $query outdata]
+ set fp [open $file]
proc asyncCB {token} {
global postResult
# Now do async
http::cleanup $t
close $fp
- set fp [open outdata]
+ set fp [open $file]
set t [http::geturl $posturl -querychannel $fp -command asyncCB]
set postResult [list PostStart]
http::wait $t
+ close $fp
lappend testRes [http::status $t] $postResult
+ removeFile outdata
set testRes
} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
append query $sep$query
set sep &
}
- ::tcltest::makeFile $query outdata
- set fp [open outdata]
+ set file [makeFile $query outdata]
+ set fp [open $file]
proc asyncCB {token} {
global postResult
error $err
}
+ removeFile outdata
list [http::status $t] [http::code $t]
} {ok {HTTP/1.0 200 Data follows}}
test http-3.13 {http::geturl socket leak test} {
set chanCount [llength [file channels]]
for {set i 0} {$i < 3} {incr i} {
- catch {http::geturl $badurl -timeout 5000}
+ catch {http::geturl $badurl -timeout 5000}
}
# No extra channels should be taken
} {HTTP/1.0 200 Data follows}
test http-4.4 {http::Event} {
- set out [open testfile w]
+ set testfile [makeFile "" testfile]
+ set out [open $testfile w]
set token [http::geturl $url -channel $out]
close $out
- set in [open testfile]
+ set in [open $testfile]
set x [read $in]
close $in
- file delete testfile
+ removeFile $testfile
set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
</body></html>"
test http-4.5 {http::Event} {
- set out [open testfile w]
+ set testfile [makeFile "" testfile]
+ set out [open $testfile w]
set token [http::geturl $url -channel $out]
close $out
upvar #0 $token data
- file delete testfile
+ removeFile $testfile
expr $data(currentsize) == $data(totalsize)
} 1
test http-4.6 {http::Event} {
- set out [open testfile w]
+ set testfile [makeFile "" testfile]
+ set out [open $testfile w]
set token [http::geturl $binurl -channel $out]
close $out
- set in [open testfile]
+ set in [open $testfile]
fconfigure $in -translation binary
set x [read $in]
close $in
- file delete testfile
+ removeFile $testfile
set x
} "$bindata$binurl"
http::status $token
} err]
# error code varies among platforms.
- list $code [string match "connect failed*" $err]
+ list $code [regexp {(connect failed|couldn't open socket)} $err]
} {1 1}
# Bogus host
<h2>GET http://$url</h2>
</body></html>"
+test http-7.1 {http::mapReply} {
+ http::mapReply "abc\$\[\]\"\\()\}\{"
+} {abc%24%5b%5d%22%5c%28%29%7d%7b}
+
# cleanup
catch {unset url}
catch {unset badurl}
close $listen
}
-if {[info exist removeHttpd]} {
+if {[info exists removeHttpd]} {
removeFile $httpdFile
}
::tcltest::cleanupTests
-
# Read the query data
- if {![info exist data(length_orig)]} {
+ if {![info exists data(length_orig)]} {
set data(length_orig) $data(length)
}
set line [read $sock $data(length)]
}
0,mime,POST {
# Empty line between headers and query data
- if {![info exist data(mime,content-length)]} {
+ if {![info exists data(mime,content-length)]} {
httpd_log $sock Error "No Content-Length for POST"
httpdError $sock 400
httpdSockDone $sock
append html "<h2>Query</h2>\n<dl>\n"
foreach {key value} [split $data(query) &=] {
append html "<dt>$key<dd>$value\n"
+ if {$key == "timeout"} {
+ after $value ;# pause
+ }
}
append html </dl>\n
}
}
if {[catch {package require http 1.0}]} {
- if {[info exist httpold]} {
+ if {[info exists httpold]} {
catch {puts "Cannot load http 1.0 package"}
::tcltest::cleanupTests
return
catch {puts "Running http 1.0 tests in slave interp"}
set interp [interp create httpold]
$interp eval [list set httpold "running"]
+ $interp eval [list set argv $argv]
$interp eval [list source [info script]]
interp delete $interp
::tcltest::cleanupTests
return
}
-test http-1.1 {http_config} {
+test httpold-1.1 {http_config} {
http_config
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
-test http-1.2 {http_config} {
+test httpold-1.2 {http_config} {
http_config -proxyfilter
} httpProxyRequired
-test http-1.3 {http_config} {
+test httpold-1.3 {http_config} {
catch {http_config -junk}
} 1
-test http-1.4 {http_config} {
+test httpold-1.4 {http_config} {
http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
set x [http_config]
http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
-test http-1.5 {http_config} {
+test httpold-1.5 {http_config} {
catch {http_config -proxyhost {} -junk 8080}
} 1
-test http-2.1 {http_reset} {
+test httpold-2.1 {http_reset} {
catch {http_reset http#1}
} 0
-test http-3.1 {http_get} {
+test httpold-3.1 {http_get} {
catch {http_get -bogus flag}
} 1
-test http-3.2 {http_get} {
+test httpold-3.2 {http_get} {
catch {http_get http:junk} err
set err
} {Unsupported URL: http:junk}
set url [info hostname]:$port
-test http-3.3 {http_get} {
+test httpold-3.3 {http_get} {
set token [http_get $url]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
set url [info hostname]:$port/a/b/c
set binurl [info hostname]:$port/binary
-test http-3.4 {http_get} {
+test httpold-3.4 {http_get} {
set token [http_get $url]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
global port
return [list [info hostname] $port]
}
-test http-3.5 {http_get} {
+test httpold-3.5 {http_get} {
http_config -proxyfilter selfproxy
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
<h2>GET http://$url</h2>
</body></html>"
-test http-3.6 {http_get} {
+test httpold-3.6 {http_get} {
http_config -proxyfilter bogus
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
<h2>GET $tail</h2>
</body></html>"
-test http-3.7 {http_get} {
+test httpold-3.7 {http_get} {
set token [http_get $url -headers {Pragma no-cache}]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h2>GET $tail</h2>
</body></html>"
-test http-3.8 {http_get} {
+test httpold-3.8 {http_get} {
set token [http_get $url -query Name=Value&Foo=Bar]
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
</dl>
</body></html>"
-test http-3.9 {http_get} {
+test httpold-3.9 {http_get} {
set token [http_get $url -validate 1]
http_code $token
} "HTTP/1.0 200 OK"
-test http-4.1 {httpEvent} {
+test httpold-4.1 {httpEvent} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
expr ($data(totalsize) == $meta(Content-Length))
} 1
-test http-4.2 {httpEvent} {
+test httpold-4.2 {httpEvent} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
string compare $data(type) [string trim $meta(Content-Type)]
} 0
-test http-4.3 {httpEvent} {
+test httpold-4.3 {httpEvent} {
set token [http_get $url]
http_code $token
} {HTTP/1.0 200 Data follows}
-test http-4.4 {httpEvent} {
- set out [open testfile w]
+test httpold-4.4 {httpEvent} {
+ set testfile [makeFile "" testfile]
+ set out [open $testfile w]
set token [http_get $url -channel $out]
close $out
- set in [open testfile]
+ set in [open $testfile]
set x [read $in]
close $in
- file delete testfile
+ removeFile $testfile
set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
-test http-4.5 {httpEvent} {
- set out [open testfile w]
+test httpold-4.5 {httpEvent} {
+ set testfile [makeFile "" testfile]
+ set out [open $testfile w]
set token [http_get $url -channel $out]
close $out
upvar #0 $token data
- file delete testfile
+ removeFile $testfile
expr $data(currentsize) == $data(totalsize)
} 1
-test http-4.6 {httpEvent} {
- set out [open testfile w]
+test httpold-4.6 {httpEvent} {
+ set testfile [makeFile "" testfile]
+ set out [open $testfile w]
set token [http_get $binurl -channel $out]
close $out
- set in [open testfile]
+ set in [open $testfile]
fconfigure $in -translation binary
set x [read $in]
close $in
- file delete testfile
+ removeFile $testfile
set x
} "$bindata$binurl"
if 0 {
# This test hangs on Windows95 because the client never gets EOF
set httpLog 1
- test http-4.6 {httpEvent} {
+ test httpold-4.6 {httpEvent} {
set token [http_get $url -blocksize 50 -progress myProgress]
set progress
} {111 111}
}
-test http-4.7 {httpEvent} {
+test httpold-4.7 {httpEvent} {
set token [http_get $url -progress myProgress]
set progress
} {111 111}
-test http-4.8 {httpEvent} {
+test httpold-4.8 {httpEvent} {
set token [http_get $url]
http_status $token
} {ok}
-test http-4.9 {httpEvent} {
+test httpold-4.9 {httpEvent} {
set token [http_get $url -progress myProgress]
http_code $token
} {HTTP/1.0 200 Data follows}
-test http-4.10 {httpEvent} {
+test httpold-4.10 {httpEvent} {
set token [http_get $url -progress myProgress]
http_size $token
} {111}
-test http-4.11 {httpEvent} {
+test httpold-4.11 {httpEvent} {
set token [http_get $url -timeout 1 -command {#}]
http_reset $token
http_status $token
} {reset}
-test http-4.12 {httpEvent} {
+test httpold-4.12 {httpEvent} {
update
set x {}
after 500 {lappend x ok}
list [http_status $token] $x
} {timeout ok}
-test http-5.1 {http_formatQuery} {
+test httpold-5.1 {http_formatQuery} {
http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}
-test http-5.2 {http_formatQuery} {
+test httpold-5.2 {http_formatQuery} {
http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%a1%a2%a2}
-test http-5.3 {http_formatQuery} {
+test httpold-5.3 {http_formatQuery} {
http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}
-test http-6.1 {httpProxyRequired} {
+test httpold-6.1 {httpProxyRequired} {
update
http_config -proxyhost [info hostname] -proxyport $port
set token [http_get $url]
-
} {1 {error in condition}}
test if-1.3 {TclCompileIfCmd: error in if/elseif test} {
list [catch {if {1+}} msg] $msg $errorInfo
-} {1 {syntax error in expression "1+"} {syntax error in expression "1+"
+} {1 {syntax error in expression "1+": premature end of expression} {syntax error in expression "1+": premature end of expression
("if" test expression)
while compiling
"if {1+}"}}
test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} {
set a {}
list [catch {if 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo
-} {1 {syntax error in expression "1>"} {syntax error in expression "1>"
+} {1 {syntax error in expression "1>": premature end of expression} {syntax error in expression "1>": premature end of expression
("if" test expression)
while compiling
"if 3>4 {set a 1} elseif {1>}"}}
test if-5.3 {if cmd with computed command names: error in if/elseif test} {
set z if
list [catch {$z {1+}} msg] $msg $errorInfo
-} {1 {syntax error in expression "1+"} {syntax error in expression "1+"
+} {1 {syntax error in expression "1+": premature end of expression} {syntax error in expression "1+": premature end of expression
while executing
"$z {1+}"}}
test if-5.4 {if cmd with computed command names: if/elseif test in braces} {
set z if
set a {}
list [catch {$z 3>4 {set a 1} elseif {1>}} msg] $msg $errorInfo
-} {1 {syntax error in expression "1>"} {syntax error in expression "1>"
+} {1 {syntax error in expression "1>": premature end of expression} {syntax error in expression "1>": premature end of expression
while executing
"$z 3>4 {set a 1} elseif {1>}"}}
test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} {
# Test for incorrect "double evaluation semantics"
-test if-10.1 {delayed substitution of then body} {knownBug} {
+test if-10.1 {delayed substitution of then body} {
set j 0
- if {[incr j] == 1} "
+ set if if
+ # this is not compiled
+ $if {[incr j] == 1} "
set result $j
"
- set result
-} {0}
-test if-10.2 {delayed substitution of elseif expression} {knownBug} {
+ # this will be compiled
+ proc p {} {
+ set j 0
+ if {[incr j]} "
+ set result $j
+ "
+ set result
+ }
+ append result [p]
+} {00}
+test if-10.2 {delayed substitution of elseif expression} {
set j 0
- if {[incr j] == 0} {
+ set if if
+ # this is not compiled
+ $if {[incr j] == 0} {
set result badthen
} elseif "$j == 1" {
set result badelseif
} else {
- set result ok
+ set result 0
}
- set result
-} {ok}
-test if-10.3 {delayed substitution of elseif body} {knownBug} {
+ # this will be compiled
+ proc p {} {
+ set j 0
+ if {[incr j] == 0} {
+ set result badthen
+ } elseif "$j == 1" {
+ set result badelseif
+ } else {
+ set result 0
+ }
+ set result
+ }
+ append result [p]
+} {00}
+test if-10.3 {delayed substitution of elseif body} {
set j 0
- if {[incr j] == 0} {
+ set if if
+ # this is not compiled
+ $if {[incr j] == 0} {
set result badthen
} elseif {1} "
set result $j
"
- set result
-} {0}
-test if-10.4 {delayed substitution of else body} {knownBug} {
+ # this will be compiled
+ proc p {} {
+ set j 0
+ if {[incr j] == 0} {
+ set result badthen
+ } elseif {1} "
+ set result $j
+ "
+ }
+ append result [p]
+} {00}
+test if-10.4 {delayed substitution of else body} {
set j 0
if {[incr j] == 0} {
set result badthen
"
set result
} {0}
-test if-10.5 {substituted control words} {knownBug} {
+test if-10.5 {substituted control words} {
set then then; proc then {} {return badthen}
set else else; proc else {} {return badelse}
set elseif elseif; proc elseif {} {return badelseif}
list [catch {if 1 $then {if 0 {} $elseif 1 {if 0 {} $else {list ok}}}} a] $a
} {0 ok}
-test if-10.6 {double invocation of variable traces} {knownBug} {
+test if-10.6 {double invocation of variable traces} {
set iftracecounter 0
proc iftraceproc {args} {
upvar #0 iftracecounter counter
list [catch {if "$iftracevar + 20" {}} a] $a \
[catch {if "$iftracevar + 20" {}} b] $b \
[unset iftracevar iftracecounter]
-} {1 {syntax error in expression "1 oops 10 + 20"} 0 {} {}}
+} {1 {syntax error in expression "1 oops 10 + 20": extra tokens at end of expression} 0 {} {}}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
testindexobj 1 1 $x abc def {a b} zzz
} {2}
+test indexObj-5.1 {Tcl_WrongNumArgs} {
+ testwrongnumargs 1 "?option?" mycmd
+} "wrong # args: should be \"mycmd ?option?\""
+test indexObj-5.2 {Tcl_WrongNumArgs} {
+ testwrongnumargs 2 "bar" mycmd foo
+} "wrong # args: should be \"mycmd foo bar\""
+test indexObj-5.3 {Tcl_WrongNumArgs} {
+ testwrongnumargs 0 "bar" mycmd foo
+} "wrong # args: should be \"bar\""
+test indexObj-5.4 {Tcl_WrongNumArgs} {
+ testwrongnumargs 0 "" mycmd foo
+} "wrong # args: should be \"\""
+test indexObj-5.5 {Tcl_WrongNumArgs} {
+ testwrongnumargs 1 "" mycmd foo
+} "wrong # args: should be \"mycmd\""
+test indexObj-5.6 {Tcl_WrongNumArgs} {
+ testwrongnumargs 2 "" mycmd foo
+} "wrong # args: should be \"mycmd foo\""
+
+test indexObj-6.1 {Tcl_GetIndexFromObjStruct} {
+ set x a
+ testgetindexfromobjstruct $x 0
+} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
+test indexObj-6.2 {Tcl_GetIndexFromObjStruct} {
+ set x a
+ testgetindexfromobjstruct $x 0
+ testgetindexfromobjstruct $x 0
+} "wrong # args: should be \"testgetindexfromobjstruct a 0\""
+test indexObj-6.3 {Tcl_GetIndexFromObjStruct} {
+ set x c
+ testgetindexfromobjstruct $x 1
+} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
+test indexObj-6.4 {Tcl_GetIndexFromObjStruct} {
+ set x c
+ testgetindexfromobjstruct $x 1
+ testgetindexfromobjstruct $x 1
+} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
+
# cleanup
::tcltest::cleanupTests
return
-
list [info body p] [info body q]
}
} {{return "x=$x"} {return "y=$y"}}
+# Prior to 8.3.0 this would cause a crash because [info body]
+# would return the bytecompiled version of foo, which the catch
+# would then try and eval out of the foo context, accessing
+# compiled local indices
test info-2.5 {info body option, returning bytecompiled bodies} {
- # Prior to 8.3.0 this would cause a crash because [info body]
- # would return the bytecompiled version of foo, which the catch
- # would then try and eval out of the foo context, accessing
- # compiled local indices
catch {unset args}
proc foo {args} {
foreach v $args {
foo a
list [catch [info body foo] msg] $msg
} {1 {can't read "args": no such variable}}
+# Fix for problem tested for in info-2.5 caused problems when
+# procedure body had no string rep (i.e. was not yet bytecode)
+# causing an empty string to be returned [Bug #545644]
+test info-2.6 {info body option, returning list bodies} {
+ proc foo args [list subst bar]
+ list [string bytelength [info body foo]] \
+ [foo; string bytelength [info body foo]]
+} {9 9}
# "info cmdcount" is no longer accurate for compiled commands!
# The expected result for info-3.1 used to be "3" and is now "1"
proc t1 {x} {info level $x}
list [catch {t1 -3} msg] $msg
} {1 {bad level "-3"}}
+test info-9.10 {info level option, namespaces} {
+ set msg [namespace eval t {info level 0}]
+ namespace delete t
+ set msg
+} {namespace eval t {info level 0}}
set savedLibrary $tcl_library
test info-10.1 {info library option} {
set b 13
set c testing
global a
+ global aa
+ set aa 23
return [info locals]
}
lsort [t1 23 24]
}
test info-16.1 {info script option} {
- list [catch {info script x} msg] $msg
-} {1 {wrong # args: should be "info script"}}
+ list [catch {info script x x} msg] $msg
+} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
file tail [info sc]
} "info.test"
-removeFile gorp.info
-makeFile "info script\n" gorp.info
+set gorpfile [makeFile "info script\n" gorp.info]
test info-16.3 {info script option} {
- list [source gorp.info] [file tail [info script]]
-} [list gorp.info info.test]
+ list [source $gorpfile] [file tail [info script]]
+} [list $gorpfile info.test]
test info-16.4 {resetting "info script" after errors} {
catch {source ~_nobody_/foo}
file tail [info script]
catch {source _nonexistent_}
file tail [info script]
} "info.test"
+test info-16.6 {info script option} {
+ set script [info script]
+ list [file tail [info script]] \
+ [info script newname.txt] \
+ [file tail [info script $script]]
+} [list info.test newname.txt info.test]
+test info-16.7 {info script option} {
+ set script [info script]
+ info script newname.txt
+ list [source $gorpfile] [file tail [info script]] \
+ [file tail [info script $script]]
+} [list $gorpfile newname.txt info.test]
+removeFile gorp.info
+set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
+test info-16.8 {info script option} {
+ list [source $gorpfile] [file tail [info script]]
+} [list [list $gorpfile foo.bar] info.test]
removeFile gorp.info
test info-17.1 {info sharedlibextension option} {
t1
} {a}
-test info-20.1 {miscellaneous error conditions} {
+# Check whether the extra testing functions are defined...
+if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
+ set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
+} else {
+ set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
+}
+test info-20.1 {info functions option} {info functions sin} sin
+test info-20.2 {info functions option} {lsort [info functions]} $functions
+test info-20.3 {info functions option} {
+ lsort [info functions a*]
+} {abs acos asin atan atan2}
+test info-20.4 {info functions option} {
+ lsort [info functions *tan*]
+} {atan atan2 tan tanh}
+test info-20.5 {info functions option} {
+ list [catch {info functions raise an error} msg] $msg
+} {1 {wrong # args: should be "info functions ?pattern?"}}
+
+test info-21.1 {miscellaneous error conditions} {
list [catch {info} msg] $msg
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
-test info-20.2 {miscellaneous error conditions} {
+test info-21.2 {miscellaneous error conditions} {
list [catch {info gorp} msg] $msg
-} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
-test info-20.3 {miscellaneous error conditions} {
+} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+test info-21.3 {miscellaneous error conditions} {
list [catch {info c} msg] $msg
-} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
-test info-20.4 {miscellaneous error conditions} {
+} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+test info-21.4 {miscellaneous error conditions} {
list [catch {info l} msg] $msg
-} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
-test info-20.5 {miscellaneous error conditions} {
+} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+test info-21.5 {miscellaneous error conditions} {
list [catch {info s} msg] $msg
-} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
+} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
-
catch {rename parray {}}
test init-2.0 {load parray - stage 1} {
- set ret [catch {namespace eval ::tcltest {parray}} error]
+ set ret [catch {parray} error]
rename parray {} ; # remove it, for the next test - that should not fail.
list $ret $error
-} {1 {no value given for parameter "a" to "parray"}}
+} {1 {wrong # args: should be "parray a ?pattern?"}}
test init-2.1 {load parray - stage 2} {
- set ret [catch {namespace eval ::tcltest {parray}} error]
+ set ret [catch {parray} error]
list $ret $error
-} {1 {no value given for parameter "a" to "parray"}}
+} {1 {wrong # args: should be "parray a ?pattern?"}}
auto_reset
test init-2.8 {load http::geturl (package)} {
# 3 ':' on purpose
- set ret [catch {namespace eval ::tcltest {http:::geturl}} error]
+ set ret [catch {http:::geturl} error]
# removing it, for the next test. should not fail.
rename ::http::geturl {} ;
list $ret $error
-} {1 {no value given for parameter "url" to "http:::geturl"}}
+} {1 {wrong # args: should be "http:::geturl url args"}}
test init-3.0 {random stuff in the auto_index, should still work} {
foo:::bar::blah
} 1
+# Tests that compare the error stack trace generated when autoloading
+# with that generated when no autoloading is necessary. Ideally they
+# should be the same.
+
+set count 0
+foreach arg {
+ c
+ {argument
+ which spans
+ multiple lines}
+ {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack}
+ {argument which spans multiple lines
+ and is long enough to be truncated and
+" <- includes a false lead in the prune point search
+ and must be longer still to force truncation}
+ {contrived example: rare circumstance
+ where the point at which to prune the
+ error stack cannot be uniquely determined.
+ foo bar foo
+"}
+ {contrived example: rare circumstance
+ where the point at which to prune the
+ error stack cannot be uniquely determined.
+ foo bar
+"}
+ } {
+
+ test init-4.$count.0 {::errorInfo produced by [unknown]} {
+ auto_reset
+ catch {parray a b $arg}
+ set first $::errorInfo
+ catch {parray a b $arg}
+ set second $::errorInfo
+ string equal $first $second
+ } 1
+
+ test init-4.$count.1 {::errorInfo produced by [unknown]} {
+ auto_reset
+ namespace eval junk [list array set $arg [list 1 2 3 4]]
+ trace variable ::junk::$arg r \
+ "[list error [subst {Variable \"$arg\" is write-only}]] ;# "
+ catch {parray ::junk::$arg}
+ set first $::errorInfo
+ catch {parray ::junk::$arg}
+ set second $::errorInfo
+ string equal $first $second
+ } 1
+
+ incr count
}
+} ;# End of [interp eval $testInterp]
+
# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
} {1 {wrong # args: should be "interp cmd ?arg ...?"}}
test interp-1.2 {options for interp command} {
list [catch {interp frobox} msg] $msg
-} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
+} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.3 {options for interp command} {
interp delete
} ""
} {1 {wrong # args: should be "interp slaves ?path?"}}
test interp-1.7 {options for interp command} {
list [catch {interp hello} msg] $msg
-} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
+} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.8 {options for interp command} {
list [catch {interp -froboz} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
+} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.9 {options for interp command} {
list [catch {interp -froboz -safe} msg] $msg
-} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
+} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, recursionlimit, slaves, share, target, or transfer}}
test interp-1.10 {options for interp command} {
list [catch {interp target} msg] $msg
} {1 {wrong # args: should be "interp target path alias"}}
+
# Part 1: Basic interpreter creation tests:
test interp-2.1 {basic interpreter creation} {
interp create a
test interp-7.5 {testing basic alias creation} {
a aliases
} {foo bar}
+test interp-7.6 {testing basic aliases arg checking} {
+ list [catch {a aliases too many args} msg] $msg
+} {1 {wrong # args: should be "a aliases"}}
# Part 7: testing basic alias invocation
test interp-8.1 {testing basic alias invocation} {
a alias bar in_master a1 a2 a3
a eval bar s1 s2 s3
} {seen in master: {a1 a2 a3 s1 s2 s3}}
+test interp-8.3 {testing basic alias invocation} {
+ catch {interp create a}
+ list [catch {a alias} msg] $msg
+} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}
-# Part 8: Testing aliases for non-existent targets
+# Part 8: Testing aliases for non-existent or hidden targets
test interp-9.1 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-master
proc nonexistent-command-in-master {} {return i_exist!}
a eval zop
} i_exist!
+test interp-9.3 {testing aliases for hidden commands} {
+ catch {interp create a}
+ a eval {proc p {} {return ENTER_A}}
+ interp alias {} p a p
+ lappend res [list [catch p msg] $msg]
+ interp hide a p
+ lappend res [list [catch p msg] $msg]
+ rename p {}
+ interp delete a
+ set res
+ } {{0 ENTER_A} {1 {invalid command name "p"}}}
+test interp-9.4 {testing aliases and namespace commands} {
+ proc p {} {return GLOBAL}
+ namespace eval tst {
+ proc p {} {return NAMESPACE}
+ }
+ interp alias {} a {} p
+ set res [a]
+ lappend res [namespace eval tst a]
+ rename p {}
+ rename a {}
+ namespace delete tst
+ set res
+ } {GLOBAL GLOBAL}
if {[info command nonexistent-command-in-master] != ""} {
rename nonexistent-command-in-master {}
interp create {a x3 foo}
a eval x3 eval foo issafe
} 1
+test interp-13.4 {testing issafe arg checking} {
+ catch {interp create a}
+ list [catch {a issafe too many args} msg] $msg
+} {1 {wrong # args: should be "a issafe"}}
# part 14: testing interp aliases
test interp-14.1 {testing interp aliases} {
z eval close stdout
list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
-catch {removeFile file-15.2}
-test interp-15.2 {testing file sharing} {
+test interp-15.2 {testing file sharing} -body {
catch {interp delete z}
interp create z
- set f [open file-15.2 w]
+ set f [open [makeFile {} file-15.2] w]
interp share "" $f z
z eval puts $f hello
z eval close $f
close $f
-} ""
-catch {removeFile file-15.2}
+} -cleanup {
+ removeFile file-15.2
+} -result ""
test interp-15.3 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
list [catch {xsafe eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
-catch {removeFile file-15.4}
-test interp-15.4 {testing file sharing} {
+test interp-15.4 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
- set f [open file-15.4 w]
+ set f [open [makeFile {} file-15.4] w]
interp share "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
close $f
-} ""
-catch {removeFile file-15.4}
+} -cleanup {
+ removeFile file-15.4
+} -result ""
test interp-15.5 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
interp share "" stdout xsafe
list [catch {xsafe eval gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
-catch {removeFile file-15.6}
-test interp-15.6 {testing file sharing} {
+test interp-15.6 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
- set f [open file-15.6 w]
+ set f [open [makeFile {} file-15.6] w]
interp share "" $f xsafe
set x [list [catch [list xsafe eval gets $f] msg] $msg]
xsafe eval close $f
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
-} 0
-catch {removeFile file-15.6}
-catch {removeFile file-15.7}
-test interp-15.7 {testing file transferring} {
+} -cleanup {
+ removeFile file-15.6
+} -result 0
+test interp-15.7 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
- set f [open file-15.7 w]
+ set f [open [makeFile {} file-15.7] w]
interp transfer "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
-} ""
-catch {removeFile file-15.7}
-catch {removeFile file-15.8}
-test interp-15.8 {testing file transferring} {
+} -cleanup {
+ removeFile file-15.7
+} -result ""
+test interp-15.8 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
- set f [open file-15.8 w]
+ set f [open [makeFile {} file-15.8] w]
interp transfer "" $f xsafe
xsafe eval close $f
set x [list [catch {close $f} msg] $msg]
string compare [string tolower $x] \
[list 1 [format "can not find channel named \"%s\"" $f]]
-} 0
-catch {removeFile file-15.8}
+} -cleanup {
+ removeFile file-15.8
+} -result 0
#
# Torture tests for interpreter deletion order
# the bugs as a core dump.
#
-if {[info commands testinterpdelete] != ""} {
+if {[info commands testinterpdelete] == ""} {
+ puts "This application hasn't been compiled with the \"testinterpdelete\""
+ puts "command, so I can't test slave delete calls"
+} else {
test interp-18.1 {testing Tcl_DeleteInterp vs slaves} {
list [catch {testinterpdelete} msg] $msg
} {1 {wrong # args: should be "testinterpdelete path"}}
set r
} {}
-# Tests of recursionlimit
-# We need testsetrecursionlimit so we need Tcltest package
-if {[catch {package require Tcltest} msg]} {
- puts "This application hasn't been compiled with Tcltest"
- puts "skipping remining interp tests that relies on it."
-} else {
- #
-test interp-29.1 {recursion limit} {
+# Part 29: recursion limit
+# 29.1.* Argument checking
+# 29.2.* Reading and setting the recursion limit
+# 29.3.* Does the recursion limit work?
+# 29.4.* Recursion limit inheritance by sub-interpreters
+# 29.5.* Confirming the recursionlimit command does not affect the parent
+# 29.6.* Safe interpreter restriction
+
+test interp-29.1.1 {interp recursionlimit argument checking} {
+ list [catch {interp recursionlimit} msg] $msg
+} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
+
+test interp-29.1.2 {interp recursionlimit argument checking} {
+ list [catch {interp recursionlimit foo bar} msg] $msg
+} {1 {could not find interpreter "foo"}}
+
+test interp-29.1.3 {interp recursionlimit argument checking} {
+ list [catch {interp recursionlimit foo bar baz} msg] $msg
+} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}}
+
+test interp-29.1.4 {interp recursionlimit argument checking} {
+ interp create moo
+ set result [catch {interp recursionlimit moo bar} msg]
+ interp delete moo
+ list $result $msg
+} {1 {expected integer but got "bar"}}
+
+test interp-29.1.5 {interp recursionlimit argument checking} {
+ interp create moo
+ set result [catch {interp recursionlimit moo 0} msg]
+ interp delete moo
+ list $result $msg
+} {1 {recursion limit must be > 0}}
+
+test interp-29.1.6 {interp recursionlimit argument checking} {
+ interp create moo
+ set result [catch {interp recursionlimit moo -1} msg]
+ interp delete moo
+ list $result $msg
+} {1 {recursion limit must be > 0}}
+
+test interp-29.1.7 {interp recursionlimit argument checking} {
+ interp create moo
+ set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg]
+ interp delete moo
+ list $result [string range $msg 0 35]
+} {1 {integer value too large to represent}}
+
+test interp-29.1.8 {slave recursionlimit argument checking} {
+ interp create moo
+ set result [catch {moo recursionlimit foo bar} msg]
+ interp delete moo
+ list $result $msg
+} {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}}
+
+test interp-29.1.9 {slave recursionlimit argument checking} {
+ interp create moo
+ set result [catch {moo recursionlimit foo} msg]
+ interp delete moo
+ list $result $msg
+} {1 {expected integer but got "foo"}}
+
+test interp-29.1.10 {slave recursionlimit argument checking} {
+ interp create moo
+ set result [catch {moo recursionlimit 0} msg]
+ interp delete moo
+ list $result $msg
+} {1 {recursion limit must be > 0}}
+
+test interp-29.1.11 {slave recursionlimit argument checking} {
+ interp create moo
+ set result [catch {moo recursionlimit -1} msg]
+ interp delete moo
+ list $result $msg
+} {1 {recursion limit must be > 0}}
+
+test interp-29.1.12 {slave recursionlimit argument checking} {
+ interp create moo
+ set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg]
+ interp delete moo
+ list $result [string range $msg 0 35]
+} {1 {integer value too large to represent}}
+
+test interp-29.2.1 {query recursion limit} {
+ interp recursionlimit {}
+} 1000
+
+test interp-29.2.2 {query recursion limit} {
+ set i [interp create]
+ set n [interp recursionlimit $i]
+ interp delete $i
+ set n
+} 1000
+
+test interp-29.2.3 {query recursion limit} {
+ set i [interp create]
+ set n [$i recursionlimit]
+ interp delete $i
+ set n
+} 1000
+
+test interp-29.2.4 {query recursion limit} {
+ set i [interp create]
+ set r [$i eval {
+ set n1 [interp recursionlimit {} 42]
+ set n2 [interp recursionlimit {}]
+ list $n1 $n2
+ }]
+ interp delete $i
+ set r
+} {42 42}
+
+test interp-29.2.5 {query recursion limit} {
+ set i [interp create]
+ set n1 [interp recursionlimit $i 42]
+ set n2 [interp recursionlimit $i]
+ interp delete $i
+ list $n1 $n2
+} {42 42}
+
+test interp-29.2.6 {query recursion limit} {
+ set i [interp create]
+ set n1 [interp recursionlimit $i 42]
+ set n2 [$i recursionlimit]
+ interp delete $i
+ list $n1 $n2
+} {42 42}
+
+test interp-29.2.7 {query recursion limit} {
+ set i [interp create]
+ set n1 [$i recursionlimit 42]
+ set n2 [interp recursionlimit $i]
+ interp delete $i
+ list $n1 $n2
+} {42 42}
+
+test interp-29.2.8 {query recursion limit} {
+ set i [interp create]
+ set n1 [$i recursionlimit 42]
+ set n2 [$i recursionlimit]
+ interp delete $i
+ list $n1 $n2
+} {42 42}
+
+test interp-29.3.1 {recursion limit} {
set i [interp create]
- load {} Tcltest $i
set r [interp eval $i {
- testsetrecursionlimit 50
+ interp recursionlimit {} 50
proc p {} {incr ::i; p}
set i 0
- catch p
- set i
+ list [catch p msg] $msg $i
+ }]
+ interp delete $i
+ set r
+} {1 {too many nested evaluations (infinite loop?)} 48}
+
+test interp-29.3.2 {recursion limit} {
+ set i [interp create]
+ interp recursionlimit $i 50
+ set r [interp eval $i {
+ proc p {} {incr ::i; p}
+ set i 0
+ list [catch p msg] $msg $i
}]
interp delete $i
set r
-} 49
+} {1 {too many nested evaluations (infinite loop?)} 48}
-test interp-29.2 {recursion limit inheritance} {
+test interp-29.3.3 {recursion limit} {
+ set i [interp create]
+ $i recursionlimit 50
+ set r [interp eval $i {
+ proc p {} {incr ::i; p}
+ set i 0
+ list [catch p msg] $msg $i
+ }]
+ interp delete $i
+ set r
+} {1 {too many nested evaluations (infinite loop?)} 48}
+
+test interp-29.3.4 {recursion limit error reporting} {
+ interp create slave
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ interp recursionlimit {} 5
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {1 {falling back due to new recursion limit}}
+
+test interp-29.3.5 {recursion limit error reporting} {
+ interp create slave
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ interp recursionlimit {} 4
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {1 {falling back due to new recursion limit}}
+
+test interp-29.3.6 {recursion limit error reporting} {
+ interp create slave
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ interp recursionlimit {} 6
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {0 ok}
+
+test interp-29.3.7 {recursion limit error reporting} {
+ interp create slave
+ after 0 {interp recursionlimit slave 5}
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ update
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {1 {too many nested evaluations (infinite loop?)}}
+
+test interp-29.3.8 {recursion limit error reporting} {
+ interp create slave
+ after 0 {interp recursionlimit slave 4}
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ update
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {1 {too many nested evaluations (infinite loop?)}}
+
+test interp-29.3.9 {recursion limit error reporting} {
+ interp create slave
+ after 0 {interp recursionlimit slave 6}
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ update
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {0 ok}
+
+test interp-29.3.10 {recursion limit error reporting} {
+ interp create slave
+ after 0 {slave recursionlimit 4}
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ update
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {1 {too many nested evaluations (infinite loop?)}}
+
+test interp-29.3.11 {recursion limit error reporting} {
+ interp create slave
+ after 0 {slave recursionlimit 5}
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ update
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {1 {too many nested evaluations (infinite loop?)}}
+
+test interp-29.3.12 {recursion limit error reporting} {
+ interp create slave
+ after 0 {slave recursionlimit 6}
+ set r1 [slave eval {
+ catch { # nesting level 1
+ eval { # 2
+ eval { # 3
+ eval { # 4
+ eval { # 5
+ update
+ set x ok
+ }
+ }
+ }
+ }
+ } msg
+ }]
+ set r2 [slave eval { set msg }]
+ interp delete slave
+ list $r1 $r2
+} {0 ok}
+
+test interp-29.4.1 {recursion limit inheritance} {
set i [interp create]
- load {} Tcltest $i
set ii [interp eval $i {
- testsetrecursionlimit 50
+ interp recursionlimit {} 50
interp create
}]
set r [interp eval [list $i $ii] {
set r
} 49
+test interp-29.4.2 {recursion limit inheritance} {
+ set i [interp create]
+ $i recursionlimit 50
+ set ii [interp eval $i {interp create}]
+ set r [interp eval [list $i $ii] {
+ proc p {} {incr ::i; p}
+ set i 0
+ catch p
+ set i
+ }]
+ interp delete $i
+ set r
+} 49
+
+test interp-29.5.1 {does slave recursion limit affect master?} {
+ set before [interp recursionlimit {}]
+ set i [interp create]
+ interp recursionlimit $i 20000
+ set after [interp recursionlimit {}]
+ set slavelimit [interp recursionlimit $i]
+ interp delete $i
+ list [expr {$before == $after}] $slavelimit
+} {1 20000}
+
+test interp-29.5.2 {does slave recursion limit affect master?} {
+ set before [interp recursionlimit {}]
+ set i [interp create]
+ interp recursionlimit $i 20000
+ set after [interp recursionlimit {}]
+ set slavelimit [$i recursionlimit]
+ interp delete $i
+ list [expr {$before == $after}] $slavelimit
+} {1 20000}
+
+test interp-29.5.3 {does slave recursion limit affect master?} {
+ set before [interp recursionlimit {}]
+ set i [interp create]
+ $i recursionlimit 20000
+ set after [interp recursionlimit {}]
+ set slavelimit [interp recursionlimit $i]
+ interp delete $i
+ list [expr {$before == $after}] $slavelimit
+} {1 20000}
+
+test interp-29.5.4 {does slave recursion limit affect master?} {
+ set before [interp recursionlimit {}]
+ set i [interp create]
+ $i recursionlimit 20000
+ set after [interp recursionlimit {}]
+ set slavelimit [$i recursionlimit]
+ interp delete $i
+ list [expr {$before == $after}] $slavelimit
+} {1 20000}
+
+test interp-29.6.1 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n [interp recursionlimit slave]
+ interp delete slave
+ set n
+} 1000
+
+test interp-29.6.2 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n [slave recursionlimit]
+ interp delete slave
+ set n
+} 1000
+
+test interp-29.6.3 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n1 [interp recursionlimit slave 42]
+ set n2 [interp recursionlimit slave]
+ interp delete slave
+ list $n1 $n2
+} {42 42}
+
+test interp-29.6.4 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n1 [slave recursionlimit 42]
+ set n2 [interp recursionlimit slave]
+ interp delete slave
+ list $n1 $n2
+} {42 42}
+
+test interp-29.6.5 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n1 [interp recursionlimit slave 42]
+ set n2 [slave recursionlimit]
+ interp delete slave
+ list $n1 $n2
+} {42 42}
+
+test interp-29.6.6 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n1 [slave recursionlimit 42]
+ set n2 [slave recursionlimit]
+ interp delete slave
+ list $n1 $n2
+} {42 42}
+
+test interp-29.6.7 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n1 [slave recursionlimit 42]
+ set n2 [slave recursionlimit]
+ interp delete slave
+ list $n1 $n2
+} {42 42}
+
+test interp-29.6.8 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set n [catch {slave eval {interp recursionlimit {} 42}} msg]
+ interp delete slave
+ list $n $msg
+} {1 {permission denied: safe interpreters cannot change recursion limit}}
+
+test interp-29.6.9 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set result [
+ slave eval {
+ interp create slave2 -safe
+ set n [catch {
+ interp recursionlimit slave2 42
+ } msg]
+ list $n $msg
+ }
+ ]
+ interp delete slave
+ set result
+} {1 {permission denied: safe interpreters cannot change recursion limit}}
+
+test interp-29.6.10 {safe interpreter recursion limit} {
+ interp create slave -safe
+ set result [
+ slave eval {
+ interp create slave2 -safe
+ set n [catch {
+ slave2 recursionlimit 42
+ } msg]
+ list $n $msg
+ }
+ ]
+ interp delete slave
+ set result
+} {1 {permission denied: safe interpreters cannot change recursion limit}}
+
+
# # Deep recursion (into interps when the regular one fails):
# # still crashes...
# proc p {} {
#} {}
# End of stack-recursion tests
-}
# This test dumps core in Tcl 8.0.3!
test interp-30.1 {deletion of aliases inside namespaces} {
set result
} ok
+test interp-32.1 { parent's working directory should
+ be inherited by a child interp } {
+ cd [temporaryDirectory]
+ set parent [pwd]
+ set i [interp create]
+ set child [$i eval pwd]
+ interp delete $i
+ file mkdir cwd_test
+ cd cwd_test
+ lappend parent [pwd]
+ set i [interp create]
+ lappend child [$i eval pwd]
+ cd ..
+ file delete cwd_test
+ interp delete $i
+ cd [workingDirectory]
+ expr {[string equal $parent $child] ? 1 :
+ "\{$parent\} != \{$child\}"}
+} 1
+
# cleanup
foreach i [interp slaves] {
interp delete $i
}
::tcltest::cleanupTests
return
-
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
-
-if {"[info commands testchannel]" != "testchannel"} {
- puts "Skipping io tests. This application does not seem to have the"
- puts "testchannel command that is needed to run these tests."
+if {[catch {package require tcltest 2}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
+namespace eval ::tcl::test::io {
+
+ namespace import ::tcltest::cleanupTests
+ namespace import ::tcltest::interpreter
+ namespace import ::tcltest::makeFile
+ namespace import ::tcltest::removeFile
+ namespace import ::tcltest::test
+ namespace import ::tcltest::testConstraint
+ namespace import ::tcltest::viewFile
-::tcltest::saveState
+testConstraint testchannel [llength [info commands testchannel]]
+testConstraint exec [llength [info commands exec]]
+
+# You need a *very* special environment to do some tests. In
+# particular, many file systems do not support large-files...
+testConstraint largefileSupport 0
removeFile test1
removeFile pipe
-catch {unset u}
-
# set up a long data file for some of the following tests
-set f [open longfile w]
+set path(longfile) [makeFile {} longfile]
+set f [open $path(longfile) w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
}
close $f
-makeFile {
+set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open $argv]
}
}
vwait forever
-} cat
+} cat]
set thisScript [file join [pwd] [info script]]
test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
+
+set path(test1) [makeFile {} test1]
+
test io-1.6 {Tcl_WriteChars: WriteBytes} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "a\u4e4d\0"
close $f
- contents test1
+ contents $path(test1)
} "a\x4d\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts -nonewline $f "a\u4e4d\0"
close $f
- contents test1
+ contents $path(test1)
} "a\x93\xe1\x00"
+set path(test2) [makeFile {} test2]
+
+test io-1.8 {Tcl_WriteChars: WriteChars} {
+ # This test written for SF bug #506297.
+ #
+ # Executing this test without the fix for the referenced bug
+ # applied to tcl will cause tcl, more specifically WriteChars, to
+ # go into an infinite loop.
+
+ set f [open $path(test2) w]
+ fconfigure $f -encoding iso2022-jp
+ puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
+ close $f
+ contents $path(test2)
+} " \x1b\$B\$O\x1b(B"
+
test io-2.1 {WriteBytes} {
# loop until all bytes are written
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
- contents test1
+ contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-2.2 {WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-2.3 {WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation crlf
puts -nonewline $f "\n12"
- set x [contents test1]
+ set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-3.1 {WriteChars: compatibility with WriteBytes} {
# loop until all bytes are written
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
- contents test1
+ contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation crlf
puts -nonewline $f "\n12"
- set x [contents test1]
+ set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-3.4 {WriteChars: loop over stage buffer} {
# stage buffer maps to more than can be queued at once.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 16
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.5 {WriteChars: saved != 0} {
# Bytes produced by UtfToExternal from end of last channel buffer
# had to be moved to beginning of next channel buffer to preserve
# requested buffersize.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
# One incomplete UTF-8 character at end of staging buffer. Backup
# to outer loop where those two bytes will have the remaining 4 bytes
# (the last byte of \uff21 plus the all of \uff22) appended.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding shiftjis -buffersize 16
puts -nonewline $f "12345678901234\uff21\uff22"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
# When translating UTF-8 to external, the produced bytes went past end
# blocksize on flush. The truncated bytes are moved to the beginning
# of the next channel buffer.
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.8 {WriteChars: reset sawLF after each buffer} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-4.1 {TranslateOutputEOL: lf} {
# search for \n
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf
puts $f "abcde"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "abcde\n" "abcde\n"]
test io-4.2 {TranslateOutputEOL: cr} {
# search for \n, replace with \r
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffering line -translation cr
puts $f "abcde"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "abcde\r" "abcde\r"]
test io-4.3 {TranslateOutputEOL: crlf} {
# simple case: search for \n, replace with \r
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffering line -translation crlf
puts $f "abcde"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "abcde\r\n" "abcde\r\n"]
test io-4.4 {TranslateOutputEOL: crlf} {
# keep storing more bytes in output buffer until output buffer is full.
# We have 13 bytes initially that would turn into 18 bytes. Fill
# dest buffer while (dstEnd < dstMax).
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 16
puts -nonewline $f "1234567\n\n\n\n\nA"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"]
test io-4.5 {TranslateOutputEOL: crlf} {
# Check for overflow of the destination buffer
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 12
puts -nonewline $f "12345678901\n456789012345678901234"
close $f
- set x [contents test1]
+ set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test io-5.1 {CheckFlush: not full} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f
puts -nonewline $f "12345678901234567890"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.2 {CheckFlush: full} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffersize 16
puts -nonewline $f "12345678901234567890"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "1234567890123456" "12345678901234567890"]
test io-5.3 {CheckFlush: not line} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffering line
puts -nonewline $f "12345678901234567890"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.4 {CheckFlush: line} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf -encoding ascii
puts -nonewline $f "1234567890\n1234567890"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "1234567890\n1234567890" "1234567890\n1234567890"]
test io-5.5 {CheckFlush: none} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffering none
puts -nonewline $f "1234567890"
- set x [list [contents test1]]
+ set x [list [contents $path(test1)]]
close $f
- lappend x [contents test1]
+ lappend x [contents $path(test1)]
} [list "1234567890" "1234567890"]
test io-6.1 {Tcl_GetsObj: working} {
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "foo\nboo"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [gets $f]
close $f
set x
test io-6.3 {Tcl_GetsObj: how many have we used?} {
# if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f "abc\ndefg"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line]
close $f
set x
} {0 3 5 4 defg}
test io-6.4 {Tcl_GetsObj: encoding == NULL} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "\x81\u1234\0"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation binary
set x [list [gets $f line] $line]
close $f
set x
} [list 3 "\x81\x34\x00"]
test io-6.5 {Tcl_GetsObj: encoding != NULL} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "\x88\xea\x92\x9a"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
close $f
test io-6.6 {Tcl_GetsObj: loop test} {
# if (dst >= dstEnd)
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f $a
puts $f hi
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
test io-6.7 {Tcl_GetsObj: error in input} {stdio} {
# if (FilterInputBytes(chanPtr, &gs) != 0)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] cat]" w+]
puts -nonewline $f "hi\nwould"
flush $f
gets $f
set x
} {-1}
test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "abcdef\x1aghijk\nwombat"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "abcdefghijk\nwom\u001abat"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
# Comprehensive tests
test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.11 {Tcl_GetsObj: lf mode: lone \n} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\r" -1 ""]
test io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.15 {Tcl_GetsObj: lf mode: several chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
test io-6.16 {Tcl_GetsObj: cr mode: no chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.17 {Tcl_GetsObj: cr mode: lone \n} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\n" -1 ""]
test io-6.18 {Tcl_GetsObj: cr mode: lone \r} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.21 {Tcl_GetsObj: cr mode: several chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
test io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\n" -1 ""]
test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\r" -1 ""]
test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 2 "\r\r" -1 ""]
test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
-test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {
+test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
# if (eol >= dstEnd)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
-test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio} {
+test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel} {
# (FilterInputBytes() != 0)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {crlf lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
fconfigure $f -buffersize 16
close $f
set x
} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
-test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {
+test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
# not (FilterInputBytes() != 0)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\n123"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]]
close $f
test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
# eol still equals dstEnd
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [eof $f]]
close $f
test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
# not (*eol == '\n')
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\rabcd\r\nefg"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f]]
close $f
set x
} [list 20 "123456789012345\rabcd" 22]
test io-6.35 {Tcl_GetsObj: auto mode: no chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.36 {Tcl_GetsObj: auto mode: lone \n} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.37 {Tcl_GetsObj: auto mode: lone \r} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.38 {Tcl_GetsObj: auto mode: \r\r} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" 0 "" -1 ""]
test io-6.39 {Tcl_GetsObj: auto mode: \r\n} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.42 {Tcl_GetsObj: auto mode: several chars} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
-test io-6.43 {Tcl_GetsObj: input saw cr} {stdio} {
+test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel} {
# if (chanPtr->flags & INPUT_SAW_CR)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
-test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio} {
+test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel} {
# not (*eol == '\n')
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
-test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio} {
+test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel} {
# Tcl_ExternalToUtf()
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding unicode
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
close $f
set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
-test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio} {
+test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel} {
# memmove()
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
close $f
set x
} [list 15 "123456789abcdef" 1 -1 "" 0]
-test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {
+test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
# (eol == dstEnd)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel inputbuffered $f]]
close $f
set x
} [list "123456789012345" 15]
-test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {
+test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
# PeekAhead() did not get any, so (eol >= dstEnd)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel queuedcr $f]]
close $f
set x
} [list "123456789012345" 1]
-test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {
+test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
# if (*eol == '\n') {skip++}
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r\n78901"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 8 "78901"]
-test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {
+test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
# not (*eol == '\n')
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r78901"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
test io-6.51 {Tcl_GetsObj: auto mode: \n} {
# else if (*eol == '\n') {goto gotoeol;}
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\n78901"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [gets $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 7 "78901"]
-test io-6.52 {Tcl_GetsObj: saw EOF character} {
+test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
# if (eof != NULL)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\x1ak9012345\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
test io-6.53 {Tcl_GetsObj: device EOF} {
# didn't produce any bytes
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
test io-6.54 {Tcl_GetsObj: device EOF} {
# got some bytes before EOF.
- set f [open test1 w]
+ set f [open $path(test1) w]
puts -nonewline $f abc
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
test io-6.55 {Tcl_GetsObj: overconverted} {
# Tcl_ExternalToUtf(), make sure state updated
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding iso2022-jp
puts $f "there\u4e00ok\n\u4e01more bytes\nhere"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio} {
update
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -buffering none
puts -nonewline $f "foobar"
fconfigure $f -blocking 0
- set x {}
- after 500 { lappend x timeout }
- fileevent $f readable { lappend x [gets $f] }
- vwait x
- vwait x
+ variable x {}
+ after 500 [namespace code { lappend x timeout }]
+ fileevent $f readable [namespace code { lappend x [gets $f] }]
+ vwait [namespace which -variable x]
+ vwait [namespace which -variable x]
fconfigure $f -blocking 1
puts -nonewline $f "baz\n"
- after 500 { lappend x timeout }
+ after 500 [namespace code { lappend x timeout }]
fconfigure $f -blocking 0
- vwait x
- vwait x
+ vwait [namespace which -variable x]
+ vwait [namespace which -variable x]
close $f
set x
} {{} timeout foobarbaz timeout}
test io-7.1 {FilterInputBytes: split up character at end of buffer} {
# (result == TCL_CONVERT_MULTIBYTE)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -encoding shiftjis -buffersize 16
set x [gets $f]
close $f
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 10 "1234567890" 0]
-test io-7.3 {FilterInputBytes: split up character at EOF} {
- set f [open test1 w]
+test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
+ set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio} {
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
fconfigure $f -encoding shiftjis -blocking 0
- fileevent $f read "ready $f"
- set x {}
+ fileevent $f read [namespace code "ready $f"]
+ variable x {}
proc ready {f} {
- lappend ::x [gets $f line] $line [fblocked $f]
+ variable x
+ lappend x [gets $f line] $line [fblocked $f]
}
- vwait x
+ vwait [namespace which -variable x]
fconfigure $f -encoding binary -blocking 1
puts $f "\x51\x82\x52"
fconfigure $f -encoding shiftjis
- vwait x
+ vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]
-test io-8.1 {PeekAhead: only go to device if no more cached data} {
+test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
# (bufPtr->nextPtr == NULL)
- set f [open "test1" w]
+ set f [open $path(test1) w]
fconfigure $f -encoding ascii -translation lf
puts -nonewline $f "123456789012345\r\n2345678"
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
close $f
set x
} "7"
-test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio} {
+test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel} {
# not (bufPtr->nextPtr == NULL)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
- set x {}
- fileevent $f read "ready $f"
+ variable x {}
+ fileevent $f read [namespace code "ready $f"]
proc ready {f} {
- lappend ::x [gets $f line] $line [testchannel inputbuffered $f]
+ variable x
+ lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
fconfigure $f -encoding unicode -buffersize 16 -blocking 0
- vwait x
+ vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
- vwait x
+ vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 42 15 "123456789012345" 25]
-test io-8.3 {PeekAhead: no cached data available} {stdio} {
+test io-8.3 {PeekAhead: no cached data available} {stdio testchannel} {
# (bytesLeft == 0)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
test io-8.4 {PeekAhead: cached data available in this buffer} {
# not (bytesLeft == 0)
- set f [open test1 w+]
+ set f [open $path(test1) w+]
fconfigure $f -translation binary
puts $f "${a}\r\nabcdef"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -encoding binary -translation auto
# "${a}\r" was converted in one operation (because ENCODING_LINESIZE
set x
} $a
unset a
-test io-8.5 {PeekAhead: don't peek if last read was short} {stdio} {
+test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel} {
# (bufPtr->nextAdded < bufPtr->length)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
close $f
set x
} {15 abcdefghijklmno 1}
-test io-8.6 {PeekAhead: change to non-blocking mode} {stdio} {
+test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel} {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
puts -nonewline $f "abcdefghijklmno\r"
flush $f
close $f
set x
} {15 abcdefghijklmno 1}
-test io-8.7 {PeekAhead: cleanup} {stdio} {
+test io-8.7 {PeekAhead: cleanup} {stdio testchannel} {
# Make sure bytes are removed from buffer.
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffering none
puts -nonewline $f "abcdefghijklmno\r"
# here
# one time
# for (copied = 0; (unsigned) toRead > 0; )
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
set x [read $f 5]
close $f
set x
# multiple times
# for (copied = 0; (unsigned) toRead > 0; )
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f 19]
test io-10.4 {Tcl_ReadChars: no more in channel buffer} {
# (copiedNow < 0)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
test io-10.5 {Tcl_ReadChars: stop on EOF} {
# (chanPtr->flags & CHANNEL_EOF)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
test io-11.1 {ReadBytes: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f 1000]
test io-11.2 {ReadBytes: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f]
test io-11.3 {ReadBytes: allocate more space} {
# (toRead > length - offset - 1)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
fconfigure $f -buffersize 16 -encoding binary
# here
set x [read $f]
test io-11.4 {ReadBytes: EOF char found} {
# (TranslateInputEOL() != 0)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
fconfigure $f -eofchar m -encoding binary
# here
set x [list [read $f] [eof $f] [read $f] [eof $f]]
test io-12.1 {ReadChars: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
test io-12.2 {ReadChars: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
# here
set x [read $f]
close $f
test io-12.3 {ReadChars: allocate more space} {
# (toRead > length - offset - 1)
- set f [open "test1" w]
+ set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
- set f [open "test1"]
+ set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
-test io-12.4 {ReadChars: split-up char} {stdio} {
+test io-12.4 {ReadChars: split-up char} {stdio testchannel} {
# (srcRead == 0)
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345\x96"
fconfigure $f -encoding shiftjis -blocking 0
- fileevent $f read "ready $f"
+ fileevent $f read [namespace code "ready $f"]
proc ready {f} {
- lappend ::x [read $f] [testchannel inputbuffered $f]
+ variable x
+ lappend x [read $f] [testchannel inputbuffered $f]
}
- set x {}
+ variable x {}
fconfigure $f -encoding shiftjis
- vwait x
+ vwait [namespace which -variable x]
fconfigure $f -encoding binary -blocking 1
puts -nonewline $f "\x7b"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
- vwait x
+ vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "\u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio} {
- makeFile {
+ set path(test1) [makeFile {
fconfigure stdout -encoding binary -buffering none
gets stdin; puts -nonewline "\xe7"
gets stdin; puts -nonewline "\x89"
gets stdin; puts -nonewline "\xa6"
- } test1
- set f [open "|[list $::tcltest::tcltest test1]" r+]
- fileevent $f readable {
+ } test1]
+ set f [open "|[list [interpreter] $path(test1)]" r+]
+ fileevent $f readable [namespace code {
lappend x [read $f]
if {[eof $f]} {
lappend x eof
}
- }
+ }]
puts $f "go1"
flush $f
fconfigure $f -blocking 0 -encoding utf-8
- set x {}
- vwait x
- after 500 { lappend x timeout }
- vwait x
+ variable x {}
+ vwait [namespace which -variable x]
+ after 500 [namespace code { lappend x timeout }]
+ vwait [namespace which -variable x]
puts $f "go2"
flush $f
- vwait x
- after 500 { lappend x timeout }
- vwait x
+ vwait [namespace which -variable x]
+ after 500 [namespace code { lappend x timeout }]
+ vwait [namespace which -variable x]
puts $f "go3"
flush $f
- vwait x
- vwait x
+ vwait [namespace which -variable x]
+ vwait [namespace which -variable x]
lappend x [catch {close $f} msg] $msg
set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"
test io-13.1 {TranslateInputEOL: cr mode} {} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "abcd\ndef\n"
test io-13.2 {TranslateInputEOL: crlf mode} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
# (src >= srcMax)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
# (src >= srcMax)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\rfgh"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
# (src >= srcMax)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\nfgh"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
-test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio} {
+test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel} {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
- set f [open "|[list $::tcltest::tcltest cat]" w+]
+ set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -blocking 0 -buffering none -translation {auto lf}
- fileevent $f read "ready $f"
+ fileevent $f read [namespace code "ready $f"]
proc ready {f} {
- lappend ::x [read $f] [testchannel queuedcr $f]
+ variable x
+ lappend x [read $f] [testchannel queuedcr $f]
}
- set x {}
+ variable x {}
+ variable y {}
puts -nonewline $f "abcdefghj\r"
- after 500 {set y ok}
- vwait y
+ after 500 [namespace code {set y ok}]
+ vwait [namespace which -variable y]
puts -nonewline $f "\n01234"
- after 500 {set y ok}
- vwait y
+ after 500 [namespace code {set y ok}]
+ vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
-test io-13.7 {TranslateInputEOL: auto mode: naked \r} {
+test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel} {
# (src >= srcMax)
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [read $f] [testchannel queuedcr $f]]
close $f
test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
# (*src == '\n')
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
test io-13.10 {TranslateInputEOL: auto mode: \n} {
# not (*src == '\r')
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndef"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
test io-13.11 {TranslateInputEOL: EOF char} {
# (*chanPtr->inEofChar != '\0')
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndefgh"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
test io-13.12 {TranslateInputEOL: find EOF char in src} {
# (*chanPtr->inEofChar != '\0')
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n"
close $f
- set f [open test1]
+ set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
# Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are
# also testing channel table management.
-if {$tcl_platform(platform) == "macintosh"} {
- set consoleFileNames [list console0 console1 console2]
+if {[info commands testchannel] != ""} {
+ if {$tcl_platform(platform) == "macintosh"} {
+ set consoleFileNames [list console0 console1 console2]
+ } else {
+ set consoleFileNames [lsort [testchannel open]]
+ }
} else {
- set consoleFileNames [lsort [testchannel open]]
+ # just to avoid an error
+ set consoleFileNames [list]
}
-test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {
+
+test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} {
set l ""
lappend l [fconfigure stdin -buffering]
lappend l [fconfigure stdout -buffering]
interp delete x
set l
} {line line none}
-test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {stdio} {
- set f [open test1 w]
- puts $f {
+
+set path(test3) [makeFile {} test3]
+
+test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} {
+ set f [open $path(test1) w]
+ puts $f [format {
close stdin
close stdout
close stderr
- set f [open test1 r]
- set f2 [open test2 w]
- set f3 [open test3 w]
+ set f [open "%s" r]
+ set f2 [open "%s" w]
+ set f3 [open "%s" w]
puts stdout [gets stdin]
puts stdout out
puts stderr err
close $f
close $f2
close $f3
- }
+ } $path(test1) $path(test2) $path(test3)]
close $f
- set result [exec $::tcltest::tcltest test1]
- set f [open test2 r]
- set f2 [open test3 r]
+ set result [exec [interpreter] $path(test1)]
+ set f [open $path(test2) r]
+ set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
} {err
}}
# This test relies on the fact that the smallest available fd is used first.
-test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {unixOnly} {
- set f [open test1 w]
- puts $f { close stdin
+test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} {
+ set f [open $path(test1) w]
+ puts $f [format { close stdin
close stdout
close stderr
- set f [open test1 r]
- set f2 [open test2 w]
- set f3 [open test3 w]
+ set f [open "%s" r]
+ set f2 [open "%s" w]
+ set f3 [open "%s" w]
puts stdout [gets stdin]
puts stdout $f2
puts stderr $f3
close $f
close $f2
close $f3
- }
+ } $path(test1) $path(test2) $path(test3)]
close $f
- set result [exec $::tcltest::tcltest test1]
- set f [open test2 r]
- set f2 [open test3 r]
+ set result [exec [interpreter] $path(test1)]
+ set f [open $path(test2) r]
+ set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
+
+set path(script) [makeFile {} script]
+
test io-14.8 {reuse of stdio special channels} {stdio} {
removeFile script
removeFile test1
- set f [open script w]
- puts $f {
+ set f [open $path(script) w]
+ puts $f [format {
close stderr
- set f [open test1 w]
+ set f [open "%s" w]
puts stderr hello
close $f
- set f [open test1 r]
+ set f [open "%s" r]
puts [gets $f]
- }
+ } $path(test1) $path(test1)]
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
+
test io-14.9 {reuse of stdio special channels} {stdio} {
removeFile script
removeFile test1
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- set f [open test1 w]
+ array set path [lindex $argv 0]
+ set f [open $path(test1) w]
puts $f hello
close $f
close stderr
- set f [open "|[list [info nameofexecutable] cat test1]" r]
+ set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
puts [gets $f]
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script) [array get path]]" r]
set c [gets $f]
close $f
set c
# These functions use "eof stdin" to ensure that the standard
# channels are added to the channel table of the interpreter.
-test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {
+test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stdin]
eof stdin
interp create x
lappend l [expr [testchannel refcount stdin] - $l1]
set l
} {0 1 0}
-test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {
+test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stdout]
eof stdin
interp create x
lappend l [expr [testchannel refcount stdout] - $l1]
set l
} {0 1 0}
-test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {
+test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} {
set l1 [testchannel refcount stderr]
eof stdin
interp create x
set l
} {0 1 0}
-test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {
+test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
removeFile test1
set l ""
- set f [open test1 w]
+ set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
string compare [string tolower $l] \
[list 1 [format "can not find channel named \"%s\"" $f]]
} 0
-test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {
+test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
removeFile test1
set l ""
- set f [open test1 w]
+ set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
string compare [string tolower $l] \
[list 1 2 1 1 [format "can not find channel named \"%s\"" $f]]
} 0
-test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {
+test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
removeFile test1
set l ""
- set f [open test1 w]
+ set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
set x [eof $f]
close $f
set x
test io-19.3 {Tcl_GetChannel, channel not found} {
list [catch {eof file34} msg] $msg
} {1 {can not find channel named "file34"}}
-test io-19.4 {Tcl_CreateChannel, insertion into channel table} {
+test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
set l ""
lappend l [eof $f]
close $f
} 0
test io-20.1 {Tcl_CreateChannel: initial settings} {
- set a [open test2 w]
+ set a [open $path(test2) w]
set old [encoding system]
encoding system ascii
- set f [open test1 w]
+ set f [open $path(test1) w]
set x [fconfigure $f -encoding]
close $f
encoding system $old
set x
} {ascii}
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
- set f [open test1 w+]
+ set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
- set f [open test1 w+]
+ set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
- set f [open test1 w+]
+ set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto cr}}
+
+set path(stdout) [makeFile {} stdout]
+
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio} {
- set f [open script w]
- puts $f {
+ set f [open $path(script) w]
+ puts $f [format {
close stdout
- set f1 [open stdout w]
+ set f1 [open "%s" w]
fconfigure $f1 -buffersize 777
puts stderr [fconfigure stdout -buffersize]
- }
+ } $path(stdout)]
close $f
- set f [open "|[list $::tcltest::tcltest script]"]
+ set f [open "|[list [interpreter] $path(script)]"]
catch {close $f} msg
set msg
} {777}
# Not used anywhere in Tcl.
} {}
-test io-23.1 {Tcl_GetChannelName} {
+test io-23.1 {Tcl_GetChannelName} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
set n [testchannel name $f]
close $f
string compare $n $f
} 0
-test io-24.1 {Tcl_GetChannelType} {
+test io-24.1 {Tcl_GetChannelType} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
set t [testchannel type $f]
close $f
string compare $t file
} 0
-test io-25.1 {Tcl_GetChannelHandle, input} {
- set f [open test1 w]
+test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f "1234567890\n098765432"
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
gets $f
set l ""
lappend l [testchannel inputbuffered $f]
close $f
set l
} {10 11}
-test io-25.2 {Tcl_GetChannelHandle, output} {
+test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello
set l ""
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
- set f [open "|[list $::tcltest::tcltest << exit]"]
+ set f [open "|[list [interpreter] << exit]"]
expr [pid $f]
close $f
} {}
test io-27.1 {FlushChannel, no output buffered} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
flush $f
- set s [file size test1]
+ set s [file size $path(test1)]
close $f
set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
flush $f
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
fconfigure $f -buffersize 60
set l ""
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
flush $f
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
{unixOrPc} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60 -eofchar {}
set l ""
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
set l
} {0 60 72}
+
+set path(pipe) [makeFile {} pipe]
+set path(output) [makeFile {} output]
+
test io-27.6 {FlushChannel, async flushing, async close} \
{stdio asyncPipeClose } {
removeFile pipe
removeFile output
- set f [open pipe w]
- puts $f {
- set f [open output w]
+ set f [open $path(pipe) w]
+ puts $f [format {
+ set f [open "%s" w]
fconfigure $f -translation lf -buffering none -eofchar {}
while {![eof stdin]} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
- }
+ } $path(output)]
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
- set f [open output w]
+ set f [open $path(output) w]
close $f
- set f [open "|[list $::tcltest::tcltest pipe]" w]
+ set f [open "|[list [interpreter] $path(pipe)]" w]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
- while {([file size output] < 65536) && ($counter < 1000)} {
+ while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
- set result "file size only [file size output]"
+ set result "file size only [file size $path(output)]"
} else {
set result ok
}
# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.
-test io-28.1 {CloseChannel called when all references are dropped} {
+test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
interp create x
interp share "" $f x
set l ""
} {2 1}
test io-28.2 {CloseChannel called when all references are dropped} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
interp create x
interp share "" $f x
puts -nonewline $f abc
x eval puts $f def
x eval close $f
interp delete x
- set f [open test1 r]
+ set f [open $path(test1) r]
set l [gets $f]
close $f
set l
{stdio asyncPipeClose nonPortable} {
removeFile pipe
removeFile output
- set f [open pipe w]
+ set f [open $path(pipe) w]
puts $f {
# Need to not have eof char appended on close, because the other
fconfigure stdout -eofchar {}
fconfigure stderr -eofchar {}
- set f [open output w]
+ set f [open $path(output) w]
fconfigure $f -translation lf -buffering none
for {set x 0} {$x < 20} {incr x} {
after 20
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
- set f [open output w]
+ set f [open $path(output) w]
close $f
- set f [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f [open "|[list [interpreter] pipe]" r+]
fconfigure $f -blocking off -eofchar {}
puts -nonewline $f $x
close $f
set counter 0
- while {([file size output] < 20480) && ($counter < 1000)} {
+ while {([file size $path(output)] < 20480) && ($counter < 1000)} {
incr counter
after 20
update
set result ok
}
} ok
-test io-28.4 {Tcl_Close} {
+test io-28.4 {Tcl_Close} {testchannel} {
removeFile test1
set l ""
lappend l [lsort [testchannel open]]
- set f [open test1 w]
+ set f [open $path(test1) w]
lappend l [lsort [testchannel open]]
close $f
lappend l [lsort [testchannel open]]
$consoleFileNames]
string compare $l $x
} 0
-test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly} {
+test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
close stdin
puts [testchannel open]
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
set l [gets $f]
close $f
set l
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f ""
close $f
- file size test1
+ file size $path(test1)
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f hello
close $f
- file size test1
+ file size $path(test1)
} 5
-test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {
+test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
set l
} {6 0 0 6}
-test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {
+test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 11}
-test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {
+test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -buffering none -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
set l
} {0 5 0 11}
-test io-29.7 {Tcl_Flush, full buffering} {
+test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
set l
} {5 0 11 0 0 11}
-test io-29.8 {Tcl_Flush, full buffering} {
+test io-29.8 {Tcl_Flush, full buffering} {testchannel} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 5 0 11 0 11}
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
- set f2 [open longfile r]
+ set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts $f1 [gets $f2]
}
close $f2
close $f1
- file size test1
+ file size $path(test1)
} 387
test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -eofchar {}
- set f2 [open longfile r]
+ set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
- file size test1
+ file size $path(test1)
} 377
test io-29.12 {Tcl_WriteChars on a pipe} {stdio} {
removeFile test1
removeFile pipe
- set f1 [open pipe w]
- puts $f1 {
- set f1 [open longfile r]
+ set f1 [open $path(pipe) w]
+ puts $f1 [format {
+ set f1 [open "%s" r]
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
}
- }
+ } $path(longfile)]
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r]
- set f2 [open longfile r]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r]
+ set f2 [open $path(longfile) r]
set y ok
for {set x 0} {$x < 10} {incr x} {
set l1 [gets $f1]
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio} {
removeFile test1
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {
puts [gets stdin]
puts [gets stdin]
}
close $f1
set y ok
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -buffering line
- set f2 [open longfile r]
+ set f2 [open $path(longfile) r]
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
puts -nonewline $f "Text1"
puts -nonewline $f " Text 2"
puts $f " Text 3"
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {Text1 Text 2 Text 3}
test io-29.15 {Tcl_Flush, channel not open for writing} {
removeFile test1
- set fd [open test1 w]
+ set fd [open $path(test1) w]
close $fd
- set fd [open test1 r]
+ set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio} {
- set fd [open "|[list $::tcltest::tcltest cat longfile]" r]
+ set fd [open "|[list [interpreter] cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
- set x [file size test1]
+ set x [file size $path(test1)]
close $f1
set x
} 18
test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
removeFile test1
set x ""
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
close $f1
set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set x ""
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
puts $f1 hello
close $f1
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
set x
} {18 24 30}
test io-29.20 {Implicit flush when buffer is full} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
set z ""
- lappend z [file size test1]
+ lappend z [file size $path(test1)]
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
- lappend z [file size test1]
+ lappend z [file size $path(test1)]
close $f1
- lappend z [file size test1]
+ lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {
fconfigure stdout -buffering full
puts hello
flush stdout
}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {
puts hello
puts hello
puts bye
}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
set x
} {hello hello bye}
test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
- set f [open test3 w]
+ set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
- set f2 [open test3]
+ set f2 [open $path(test3)]
set x {}
lappend x [read -nonewline $f2]
close $f2
flush $f
- set f2 [open test3]
+ set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
} "{} {Line 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio} {
removeFile test3
- set f [open "|[list $::tcltest::tcltest cat | $::tcltest::tcltest cat > test3]" w]
+ set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
after 100
- set f [open test3 r]
+ set f [open $path(test3) r]
set x [read $f]
close $f
set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} {stdio} {
removeFile pipe
- set f [open pipe w]
+ set f [open $path(pipe) w]
puts $f {exit}
close $f
- set f [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f [open "|[list [interpreter] $path(pipe)]" r+]
gets $f
puts $f output
after 50
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f hello\nthere\nand\nhere
flush $f
- set s [file size test1]
+ set s [file size $path(test1)]
close $f
set s
} 21
test io-29.29 {Tcl_WriteChars, cr mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
- file size test1
+ file size $path(test1)
} 21
test io-29.30 {Tcl_WriteChars, crlf mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
- file size test1
+ file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} {stdio} {
removeFile pipe
removeFile output
- set f [open pipe w]
- puts $f {set f [open output w]}
+ set f [open $path(pipe) w]
+ puts $f [format {set f [open "%s" w]} $path(output)]
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x {"
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
- set f [open output w]
+ set f [open $path(output) w]
close $f
- set f [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
- while {([file size output] < 65536) && ($counter < 1000)} {
+ while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 5
update
}
if {$counter == 1000} {
- set result "file size only [file size output]"
+ set result "file size only [file size $path(output)]"
} else {
set result ok
}
{stdio asyncPipeClose} {
removeFile pipe
removeFile output
- set f [open pipe w]
- puts $f {set f [open output w]}
+ set f [open $path(pipe) w]
+ puts $f [format {set f [open "%s" w]} $path(output)]
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x {"
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
- set f [open output w]
+ set f [open $path(output) w]
close $f
- set f [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
- while {([file size output] < 65536) && ($counter < 1000)} {
+ while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
- set result "file size only [file size output]"
+ set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
-test io-29.33 {Tcl_Flush, implicit flush on exit} {stdio} {
- set f [open script w]
- puts $f {
- set f [open test1 w]
+test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
+ set f [open $path(script) w]
+ puts $f [format {
+ set f [open "%s" w]
fconfigure $f -translation lf
puts $f hello
puts $f bye
puts $f strange
- }
+ } $path(test1)]
close $f
- exec $::tcltest::tcltest script
- set f [open test1 r]
+ exec [interpreter] $path(script)
+ set f [open $path(test1) r]
set r [read $f]
close $f
set r
} "hello\nbye\nstrange\n"
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac} {
set c 0
- set x running
+ variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
}
}
proc accept {s a p} {
- global x
- fileevent $s readable [list readit $s]
+ variable x
+ fileevent $s readable [namespace code [list readit $s]]
fconfigure $s -blocking off
set x accepted
}
proc readit {s} {
- global c x
+ variable c
+ variable x
set l [gets $s]
if {[eof $s]} {
incr c
}
}
- set ss [socket -server accept 2828]
- set cs [socket [info hostname] 2828]
- vwait x
+ set ss [socket -server [namespace code accept] 0]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
+ vwait [namespace which -variable x]
fconfigure $cs -blocking off
writelots $cs $l
close $cs
close $ss
- vwait x
+ vwait [namespace which -variable x]
set c
} 2000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac} {
catch {interp delete y}
interp create x
interp create y
- set s [socket -server accept 2828]
+ set s [socket -server [namespace code accept] 0]
proc accept {s a p} {
puts $s hello
close $s
}
- set c [socket [info hostname] 2828]
+ set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
interp share {} $c x
interp share {} $c y
close $c
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
} "hello\nthere\nand\nhere\n"
test io-30.2 {Tcl_Write lf, Tcl_Read cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
} "hello\nthere\nand\nhere\n"
test io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
} "hello\nthere\nand\nhere\n"
test io-30.4 {Tcl_Write cr, Tcl_Read cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
} "hello\nthere\nand\nhere\n"
test io-30.5 {Tcl_Write cr, Tcl_Read lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
} "hello\rthere\rand\rhere\r"
test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
} "hello\rthere\rand\rhere\r"
test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
} "hello\nthere\nand\nhere\n"
test io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
} "hello\r\nthere\r\nand\r\nhere\r\n"
test io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
} "hello\n\nthere\n\nand\n\nhere\n\n"
test io-30.10 {Tcl_Write lf, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
} auto}
test io-30.11 {Tcl_Write cr, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
} auto}
test io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
puts $f $line
}
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
puts $f $line
}
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set c [read $f]
close $f
test io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\rhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\nand\rhere\n\x1a
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set c [read $f]
close $f
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -eofchar \x1a -translation lf
puts $f hello\nthere\nand\rhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set c [read $f]
close $f
}
test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
} {abc def 0 {} 1 {} 1}
test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar {}
set l ""
lappend l [gets $f]
} "abc def 0 \x1aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
set l ""
set x [gets $f]
} {0 1 {} 1}
test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
set l ""
set x [gets $f]
} {0 1 {} 1}
test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
} {8 1}
test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
} {8 1}
test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
} {8 1}
test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
} {8 1}
test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
} {8 1}
test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
test io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
} {hello 6 auto there 12 auto}
test io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
} {hello 6 auto there 12 auto}
test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
} {hello 7 auto there 14 auto}
test io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [gets $f]
} {hello 6 lf there 12 lf}
test io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [string length [gets $f]]
} {21 21 cr 1 {} 21 cr 1}
test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
} {hello 6 cr 0 there 12 cr 0}
test io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
} {21 21 lf 1 {} 21 lf 1}
test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [gets $f]
} {hello 7 crlf 0 there 14 crlf 0}
test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
} {hello 6 cr 0 6 13 cr 0}
test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
} {6 7 lf 0 6 14 lf 0}
test io-31.13 {binary mode is synonym of lf mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation binary
set x [fconfigure $f -translation]
close $f
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\rand\r\nhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
} {hello there and here 0 {} 1}
test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\r
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
} {hello there and here 0 {} 1}
test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\n
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [gets $f]
} {hello there and here 0 {} 1}
test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\r\n
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
} {hello there and here 0 {} 1}
test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "hello\nthere\nand\rhere\n\%c" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
} {hello there and here 0 {} 1}
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -eofchar \x1a -translation lf
puts $f hello\nthere\nand\rhere
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
} {hello there and here 0 {} 1}
test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a
fconfigure $f -translation auto
set l ""
} {abc def 0 {} 1}
test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
} {abc def 0 {} 1}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar {}
set l ""
lappend l [gets $f]
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
set l ""
lappend l [gets $f]
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
set l ""
lappend l [gets $f]
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
} {abc def 0 {} 1}
test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l ""
lappend l [gets $f]
} {abc def 0 {} 1}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
} {abc def 0 {} 1}
test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l ""
lappend l [gets $f]
} {abc def 0 {} 1}
test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
} {abc def 0 {} 1}
test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l ""
lappend l [gets $f]
} {abc def 0 {} 1}
test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
puts $f $line
}
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf
set c ""
while {[gets $f line] >= 0} {
} [expr 700*15+1]
test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
puts $f $line
}
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto
set c ""
while {[gets $f line] >= 0} {
read stdin 0
} ""
test io-32.3 {Tcl_Read, negative byte count} {
- set f [open longfile r]
+ set f [open $path(longfile) r]
set l [list [catch {read $f -1} msg] $msg]
close $f
set l
} {1 {bad argument "-1": should be "nonewline"}}
test io-32.4 {Tcl_Read, positive byte count} {
- set f [open longfile r]
+ set f [open $path(longfile) r]
set x [read $f 1024]
set s [string length $x]
unset x
set s
} 1024
test io-32.5 {Tcl_Read, multiple buffers} {
- set f [open longfile r]
+ set f [open $path(longfile) r]
fconfigure $f -buffersize 100
set x [read $f 1024]
set s [string length $x]
set s
} 1024
test io-32.6 {Tcl_Read, very large read} {
- set f1 [open longfile r]
+ set f1 [open $path(longfile) r]
set z [read $f1 1000000]
close $f1
set l [string length $z]
set x ok
- set z [file size longfile]
+ set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
- set f1 [open longfile r]
+ set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 20]
close $f1
set x
} ok
test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
- set f1 [open longfile r]
+ set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 1000000]
close $f1
set x ok
- set l [string length $z]]
- set z [file size longfile]]
+ set l [string length $z]
+ set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
- set x
+ set x
} ok
test io-32.9 {Tcl_Read, read to end of file} {
- set f1 [open longfile r]
+ set f1 [open $path(longfile) r]
set z [read $f1]
close $f1
set l [string length $z]
set x ok
- set z [file size longfile]
+ set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
} ok
test io-32.10 {Tcl_Read from a pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
}}
test io-32.12 {Tcl_Read, -nonewline} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
set c
bye}
test io-32.13 {Tcl_Read, -nonewline} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
list [string length $c] $c
bye}}
test io-32.14 {Tcl_Read, reading in small chunks} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [read $f 1] [read $f 2] [read $f]]
close $f
set x
}}
test io-32.15 {Tcl_Read, asking for more input than available} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [read $f 100]
close $f
set x
}
test io-32.16 {Tcl_Read, read to end of file with -nonewline} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [read -nonewline $f]
close $f
set x
test io-33.1 {Tcl_Gets, reading what was written} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set y "first line"
puts $f1 $y
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
set x [gets $f1]
set z ok
if {"$x" != "$y"} {
set z
} ok
test io-33.2 {Tcl_Gets into variable} {
- set f1 [open longfile r]
+ set f1 [open $path(longfile) r]
set c [gets $f1 x]
set l [string length x]
set z ok
} ok
test io-33.3 {Tcl_Gets from pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
} ok
test io-33.4 {Tcl_Gets with long line} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
- set f [open test3]
+ set f [open $path(test3)]
set x [gets $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.5 {Tcl_Gets with long line} {
- set f [open test3]
+ set f [open $path(test3)]
set x [gets $f y]
close $f
list $x $y
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.6 {Tcl_Gets and end of file} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
puts -nonewline $f "Test1\nTest2"
close $f
- set f [open test3]
+ set f [open $path(test3)]
set x {}
set y {}
lappend x [gets $f y] $y
set x
} {5 Test1 5 Test2 -1 {}}
test io-33.7 {Tcl_Gets and bad variable} {
- set f [open test3 w]
+ set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
close $f
catch {unset x}
set x 24
- set f [open test3 r]
+ set f [open $path(test3) r]
set result [list [catch {gets $f x(0)} msg] $msg]
close $f
set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 100} {incr y} {puts $f $x}
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 100} {incr y} {gets $f}
close $f
set y
} 100
test io-33.9 {Tcl_Gets, exercising double buffering} {
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 200} {incr y} {puts $f $x}
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 200} {incr y} {gets $f}
close $f
set y
} 200
test io-33.10 {Tcl_Gets, exercising double buffering} {
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 300} {incr y} {puts $f $x}
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 300} {incr y} {gets $f}
close $f
# Test Tcl_Seek and Tcl_Tell.
test io-34.1 {Tcl_Seek to current position at start of file} {
- set f1 [open longfile r]
+ set f1 [open $path(longfile) r]
seek $f1 0 current
set c [tell $f1]
close $f1
} 0
test io-34.2 {Tcl_Seek to offset from start} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 10 start
set c [tell $f1]
close $f1
} 10
test io-34.3 {Tcl_Seek to end of file} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 0 end
set c [tell $f1]
close $f1
} 54
test io-34.4 {Tcl_Seek to offset from end of file} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
close $f1
} 44
test io-34.5 {Tcl_Seek to offset from current position} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 10 current
seek $f1 10 current
set c [tell $f1]
} 20
test io-34.6 {Tcl_Seek to offset from end of file} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
set r [read $f1]
}}
test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 -10 end
set c1 [tell $f1]
set r1 [read $f1 5]
list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} {stdio} {
- set f1 [open "|[list $::tcltest::tcltest]" r+]
+ set f1 [open "|[list [interpreter]]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
close $f1
regsub {".*":} $x {"":} x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
- set f [open test3 RDWR]
+ set f [open $path(test3) RDWR]
set x [read $f 1]
seek $f 3
lappend x [read $f 1]
close $f
set x
} {a d a l Y {} b}
+
+set path(test3) [makeFile {} test3]
+
test io-34.10 {Tcl_Seek testing flushing of buffered input} {
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyz\n123
close $f
- set f [open test3 r+]
+ set f [open $path(test3) r+]
fconfigure $f -translation lf
set x [gets $f]
seek $f 0 current
} "xyz {xyz
456}"
test io-34.11 {Tcl_Seek testing flushing of buffered output} {
- set f [open test3 w]
+ set f [open $path(test3) w]
puts $f xyz\n123
close $f
- set f [open test3 w+]
+ set f [open $path(test3) w+]
puts $f xyzzy
seek $f 2
set x [gets $f]
list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f xyz\n123
close $f
- set f [open test3 a+]
+ set f [open $path(test3) a+]
fconfigure $f -translation lf -eofchar {}
puts $f xyzzy
flush $f
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set p [tell $f1]
close $f1
set p
} 0
test io-34.14 {Tcl_Tell after seek to end of file} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 0 end
set c1 [tell $f1]
close $f1
} 54
test io-34.15 {Tcl_Tell combined with seeking} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
list $c1 $c2
} {10 20}
test io-34.16 {Tcl_tell on pipe: always -1} {stdio} {
- set f1 [open "|[list $::tcltest::tcltest]" r+]
+ set f1 [open "|[list [interpreter]]" r+]
set c [tell $f1]
close $f1
set c
} -1
test io-34.17 {Tcl_Tell on pipe: always -1} {stdio} {
- set f1 [open "|[list $::tcltest::tcltest]" r+]
+ set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
removeFile test2
- set f [open test2 w]
+ set f [open $path(test2) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
close $f
- set f [open test2]
+ set f [open $path(test2)]
fconfigure $f -translation lf
set x [tell $f]
read $f 3
set x
} {0 3 2 12 30}
test io-34.19 {Tcl_Tell combined with opening in append mode} {
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f "abcdefghijklmnopqrstuvwxyz"
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
- set f [open test3 a]
+ set f [open $path(test3) a]
set c [tell $f]
close $f
set c
} 54
test io-34.20 {Tcl_Tell combined with writing} {
- set f [open test3 w]
+ set f [open $path(test3) w]
set l ""
seek $f 29 start
lappend l [tell $f]
close $f
set l
} {29 39 40 447}
+test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
+ removeFile test3
+ set f [open $path(test3) w]
+ fconfigure $f -encoding binary
+ set l ""
+ lappend l [tell $f]
+ puts -nonewline $f abcdef
+ lappend l [tell $f]
+ flush $f
+ lappend l [tell $f]
+ # 4GB offset!
+ seek $f 0x100000000
+ lappend l [tell $f]
+ puts -nonewline $f abcdef
+ lappend l [tell $f]
+ close $f
+ lappend l [file size $f]
+ # truncate...
+ close [open $path(test3) w]
+ lappend l [file size $f]
+ set l
+} {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
test io-35.1 {Tcl_Eof} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f hello
puts $f hello
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [eof $f]
lappend x [eof $f]
gets $f
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
} {0 0 0 1 1 1}
test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio} {
removeFile pipe
- set f [open pipe w]
+ set f [open $path(pipe) w]
puts $f {
exit
}
close $f
- set f [open "|[list $::tcltest::tcltest pipe]" r]
+ set f [open "|[list [interpreter] $path(pipe)]" r]
set l ""
lappend l [gets $f]
lappend l [eof $f]
} {{} 1}
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1a
puts $f abc\ndef
close $f
- set s [file size test1]
- set f [open test1 r]
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {9 8 1}
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1a
puts $f abc\ndef
close $f
- set s [file size test1]
- set f [open test1 r]
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {9 8 1}
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1a
puts $f abc\ndef
close $f
- set s [file size test1]
- set f [open test1 r]
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {9 8 1}
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1a
puts $f abc\ndef
close $f
- set s [file size test1]
- set f [open test1 r]
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {9 8 1}
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1a
puts $f abc\ndef
close $f
- set s [file size test1]
- set f [open test1 r]
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {11 8 1}
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1a
puts $f abc\ndef
close $f
- set s [file size test1]
- set f [open test1 r]
+ set s [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {11 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
- set c [file size test1]
- set f [open test1 r]
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {17 8 1}
test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
- set c [file size test1]
- set f [open test1 r]
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {17 8 1}
test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
- set c [file size test1]
- set f [open test1 r]
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {17 8 1}
test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
- set c [file size test1]
- set f [open test1 r]
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {17 8 1}
test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
- set c [file size test1]
- set f [open test1 r]
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
} {21 8 1}
test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
- set c [file size test1]
- set f [open test1 r]
+ set c [file size $path(test1)]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
# Test Tcl_InputBlocked
test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio} {
- set f1 [open "|[list $::tcltest::tcltest]" r+]
+ set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio} {
- set f1 [open "|[list $::tcltest::tcltest]" r+]
+ set f1 [open "|[list [interpreter]]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
} {hello_from_pipe 0 {} 0 1}
test io-36.3 {Tcl_InputBlocked vs files, short read} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
lappend l [fblocked $f]
lappend l [read $f 3]
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {
proc in {f} {
- global l x
+ variable l
+ variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
- fileevent $f readable [list in $f]
- vwait x
+ fileevent $f readable [namespace code [list in $f]]
+ variable x
+ vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [fblocked $f]
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles} {
proc in {f} {
- global l x
+ variable l
+ variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
- fileevent $f readable [list in $f]
- vwait x
+ fileevent $f readable [namespace code [list in $f]]
+ variable x
+ vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
# Test Tcl_InputBuffered
-test io-37.1 {Tcl_InputBuffered} {
- set f [open longfile r]
+test io-37.1 {Tcl_InputBuffered} {testchannel} {
+ set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
close $f
set l
} {4093 3}
-test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {
- set f [open longfile r]
+test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
+ set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
- set f [open longfile r]
+ set f [open $path(longfile) r]
set s [fconfigure $f -buffersize]
close $f
set s
} 4096
test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
- set f [open longfile r]
+ set f [open $path(longfile) r]
set l ""
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000
set l
} {4096 10000 4096 4096 4096 100000 4096}
+test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
+ # This test crashes the interp if Bug #427196 is not fixed
+
+ set chan [open [info script] r]
+ fconfigure $chan -buffersize 10
+ set var [read $chan 2]
+ fconfigure $chan -buffersize 32
+ append var [read $chan]
+ close $chan
+} {}
+
# Test Tcl_SetChannelOption, Tcl_GetChannelOption
test io-39.1 {Tcl_GetChannelOption} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set x [fconfigure $f1 -blocking]
close $f1
set x
#
test io-39.2 {Tcl_GetChannelOption} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set x [fconfigure $f1 -buffering]
close $f1
set x
} full
test io-39.3 {Tcl_GetChannelOption} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -buffering line
set x [fconfigure $f1 -buffering]
close $f1
} line
test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering line
} {full line none line full}
test io-39.5 {Tcl_GetChannelOption, invariance} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
test io-39.6 {Tcl_SetChannelOption, multiple options} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line
puts $f1 hello
puts $f1 bye
- set x [file size test1]
+ set x [file size $path(test1)]
close $f1
set x
} 10
test io-39.7 {Tcl_SetChannelOption, buffering, translation} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 bye
set x ""
fconfigure $f1 -buffering line
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
puts $f1 really_bye
- lappend x [file size test1]
+ lappend x [file size $path(test1)]
close $f1
set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set l ""
fconfigure $f1 -translation lf -buffering none -eofchar {}
puts -nonewline $f1 hello
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
puts -nonewline $f1 hello
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
fconfigure $f1 -buffering full
puts -nonewline $f1 hello
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
fconfigure $f1 -buffering none
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
puts -nonewline $f1 hello
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
close $f1
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
set l
} {5 10 10 10 20 20}
test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
close $f1
- set f1 [open test1 r]
+ set f1 [open $path(test1) r]
set x ""
lappend x [fconfigure $f1 -blocking]
fconfigure $f1 -blocking off
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio} {
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {
gets stdin
after 100
}
close $f1
set x ""
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -blocking off -buffering line
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffersize -10
set x [fconfigure $f -buffersize]
close $f
} 4096
test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffersize 10000000
set x [fconfigure $f -buffersize]
close $f
} 4096
test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -buffersize 40000
set x [fconfigure $f -buffersize]
close $f
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding {}
puts -nonewline $f \xe7\x89\xa6
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
} \u7266
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f \xe7\x89\xa6
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
} \u7266
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
close $f
set result
} {1 {unknown encoding "foobar"}}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio} {
- set f [open "|[list $::tcltest::tcltest cat]" r+]
+ set f [open "|[list [interpreter] $path(cat)]" r+]
fconfigure $f -encoding binary
puts -nonewline $f "\xe7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
- set x {}
- fileevent $f readable { lappend x [read $f] }
- vwait x
- after 300 { lappend x timeout }
- vwait x
+ variable x {}
+ fileevent $f readable [namespace code { lappend x [read $f] }]
+ vwait [namespace which -variable x]
+ after 300 [namespace code { lappend x timeout }]
+ vwait [namespace which -variable x]
fconfigure $f -encoding utf-8
- vwait x
- after 300 { lappend x timeout }
- vwait x
+ vwait [namespace which -variable x]
+ after 300 [namespace code { lappend x timeout }]
+ vwait [namespace which -variable x]
fconfigure $f -encoding binary
- vwait x
- after 300 { lappend x timeout }
- vwait x
+ vwait [namespace which -variable x]
+ after 300 [namespace code { lappend x timeout }]
+ vwait [namespace which -variable x]
close $f
set x
} "{} timeout {} timeout \xe7 timeout"
test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
- set s1 [socket -server accept 0]
+ set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
test io-39.19 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
- set s1 [socket -server accept 0]
+ set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
test io-39.20 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
- set s1 [socket -server accept 0]
+ set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \
{socket} {
proc accept {s a p} {close $s}
- set s1 [socket -server accept 0]
+ set s1 [socket -server [namespace code accept] 0]
set port [lindex [fconfigure $s1 -sockname] 2]
set s2 [socket 127.0.0.1 $port]
update
set modes
} {auto crlf}
+test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
+ removeFile test1
+ set f1 [open $path(test1) w+]
+ set l ""
+ lappend l [fconfigure $f1 -eofchar]
+ fconfigure $f1 -eofchar {ON GO}
+ lappend l [fconfigure $f1 -eofchar]
+ fconfigure $f1 -eofchar D
+ lappend l [fconfigure $f1 -eofchar]
+ close $f1
+ set l
+} {{{} {}} {O G} {D D}}
+
+test io-39.22a {Tcl_SetChannelOption, invariance} {
+ removeFile test1
+ set f1 [open $path(test1) w+]
+ set l [list]
+ fconfigure $f1 -eofchar {ON GO}
+ lappend l [fconfigure $f1 -eofchar]
+ fconfigure $f1 -eofchar D
+ lappend l [fconfigure $f1 -eofchar]
+ lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
+ close $f1
+ set l
+} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}}
+
+
+test io-39.23 {Tcl_GetChannelOption, server socket is not readable or
+ writeable, it should still have valid -eofchar and -translation options } {
+ set l [list]
+ set sock [socket -server [namespace code accept] 0]
+ lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
+ close $sock
+ set l
+} {{{}} auto}
+test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
+ writable so we can't change -eofchar or -translation } {
+ set l [list]
+ set sock [socket -server [namespace code accept] 0]
+ fconfigure $sock -eofchar D -translation lf
+ lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
+ close $sock
+ set l
+} {{{}} auto}
+
test io-40.1 {POSIX open access modes: RDWR} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
puts $f xyzzy
close $f
- set f [open test3 RDWR]
+ set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
removeFile test3
- set f [open test3 {WRONLY CREAT} 0600]
- file stat test3 stats
+ set f [open $path(test3) {WRONLY CREAT} 0600]
+ file stat $path(test3) stats
set x [format "0%o" [expr $stats(mode)&0777]]
puts $f "line 1"
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
-catch {set ::tcltest::testConstraints(umask2) [expr {[exec umask] == 2}]}
+catch {testConstraint umask2 [expr {[exec umask] == 2}]}
test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
# This test only works if your umask is 2, like ouster's.
removeFile test3
- set f [open test3 {WRONLY CREAT}]
+ set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat test3 stats
format "0%o" [expr $stats(mode)&0777]
} 0664
test io-40.4 {POSIX open access modes: CREAT} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts $f xyzzy
close $f
- set f [open test3 {WRONLY CREAT}]
+ set f [open $path(test3) {WRONLY CREAT}]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abzzy
test io-40.5 {POSIX open access modes: APPEND} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f xyzzy
close $f
- set f [open test3 {WRONLY APPEND}]
+ set f [open $path(test3) {WRONLY APPEND}]
fconfigure $f -translation lf
puts $f "new line"
seek $f 0
puts $f "abc"
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
fconfigure $f -translation lf
set x ""
seek $f 6 current
} {{new line} abc}
test io-40.6 {POSIX open access modes: EXCL} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
puts $f xyzzy
close $f
- set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg]
+ set msg [list [catch {open $path(test3) {WRONLY CREAT EXCL}} msg] $msg]
regsub " already " $msg " " msg
+ regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {couldn't open "test3": file exists}}
test io-40.7 {POSIX open access modes: EXCL} {
removeFile test3
- set f [open test3 {WRONLY CREAT EXCL}]
+ set f [open $path(test3) {WRONLY CREAT EXCL}]
fconfigure $f -eofchar {}
puts $f "A test line"
close $f
} {A test line}
test io-40.8 {POSIX open access modes: TRUNC} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
puts $f xyzzy
close $f
- set f [open test3 {WRONLY TRUNC}]
+ set f [open $path(test3) {WRONLY TRUNC}]
puts $f abc
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abc
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
removeFile test3
- set f [open test3 {WRONLY NONBLOCK CREAT}]
+ set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
puts $f "NONBLOCK test"
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {NONBLOCK test}
test io-40.10 {POSIX open access modes: RDONLY} {
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "two lines: this one"
puts $f "and this"
close $f
- set f [open test1 RDONLY]
+ set f [open $path(test1) RDONLY]
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
close $f
string compare [string tolower $x] \
} 0
test io-40.11 {POSIX open access modes: RDONLY} {
removeFile test3
- string tolower [list [catch {open test3 RDONLY} msg] $msg]
+ set msg [list [catch {open $path(test3) RDONLY} msg] $msg]
+ regsub [file join {} $path(test3)] $msg "test3" msg
+ string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.12 {POSIX open access modes: WRONLY} {
removeFile test3
- string tolower [list [catch {open test3 WRONLY} msg] $msg]
+ set msg [list [catch {open $path(test3) WRONLY} msg] $msg]
+ regsub [file join {} $path(test3)] $msg "test3" msg
+ string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.13 {POSIX open access modes: WRONLY} {
makeFile xyzzy test3
- set f [open test3 WRONLY]
+ set f [open $path(test3) WRONLY]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
seek $f 0 current
} 0
test io-40.14 {POSIX open access modes: RDWR} {
removeFile test3
- string tolower [list [catch {open test3 RDWR} msg] $msg]
+ set msg [list [catch {open $path(test3) RDWR} msg] $msg]
+ regsub [file join {} $path(test3)] $msg "test3" msg
+ string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.15 {POSIX open access modes: RDWR} {
makeFile xyzzy test3
- set f [open test3 RDWR]
+ set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
# Test fileevent on a file
#
-set f [open foo w+]
+set path(foo) [makeFile {} foo]
+set f [open $path(foo) w+]
test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {
list [fileevent $f readable] [fileevent $f writable]
} {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}
test io-44.1 {FileEventProc procedure: normal read event} {stdio unixExecs} {
- fileevent $f2 readable {
+ fileevent $f2 readable [namespace code {
set x [gets $f2]; fileevent $f2 readable {}
- }
+ }]
puts $f2 text; flush $f2
- set x initial
- vwait x
+ variable x initial
+ vwait [namespace which -variable x]
set x
} {text}
test io-44.2 {FileEventProc procedure: error in read event} {stdio unixExecs} {
- proc bgerror args {
- global x
- set x $args
- }
+ proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 readable {error bogus}
puts $f2 text; flush $f2
- set x initial
- vwait x
- rename bgerror {}
+ variable x initial
+ vwait [namespace which -variable x]
+ rename ::bgerror {}
list $x [fileevent $f2 readable]
} {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} {stdio unixExecs} {
- fileevent $f2 writable {
+ fileevent $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
fileevent $f2 writable {}
}
- }
- set x initial
+ }]
+ variable x initial
set count 3
- vwait x
- vwait x
- vwait x
+ vwait [namespace which -variable x]
+ vwait [namespace which -variable x]
+ vwait [namespace which -variable x]
set x
} {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} {stdio unixExecs} {
- proc bgerror args {
- global x
- set x $args
- }
+ proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 writable {error bad-write}
- set x initial
- vwait x
- rename bgerror {}
+ variable x initial
+ vwait [namespace which -variable x]
+ rename ::bgerror {}
list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} {
- set f4 [open "|[list $::tcltest::tcltest cat << foo]" r]
- fileevent $f4 readable {
+ set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
+ fileevent $f4 readable [namespace code {
if {[gets $f4 line] < 0} {
lappend x eof
fileevent $f4 readable {}
} else {
lappend x $line
}
- }
- set x initial
- vwait x
- vwait x
+ }]
+ variable x initial
+ vwait [namespace which -variable x]
+ vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
- set f [open foo r]
- fileevent $f readable {
+ set f [open $path(foo) r]
+ fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
- }
+ }]
close $f
set x initial
- after 100 { set y done }
- vwait y
+ after 100 [namespace code { set y done }]
+ variable y
+ vwait [namespace which -variable y]
set x
} {initial}
test io-45.2 {DeleteFileEvent, cleanup on close} {
- set f [open foo r]
- set f2 [open foo r]
- fileevent $f readable {
+ set f [open $path(foo) r]
+ set f2 [open $path(foo) r]
+ fileevent $f readable [namespace code {
lappend x "f triggered: \"[gets $f]\""
fileevent $f readable {}
- }
- fileevent $f2 readable {
+ }]
+ fileevent $f2 readable [namespace code {
lappend x "f2 triggered: \"[gets $f2]\""
fileevent $f2 readable {}
- }
+ }]
close $f
- set x initial
- vwait x
+ variable x initial
+ vwait [namespace which -variable x]
close $f2
set x
} {initial {f2 triggered: "foo bar"}}
test io-45.3 {DeleteFileEvent, cleanup on close} {
- set f [open foo r]
- set f2 [open foo r]
- set f3 [open foo r]
+ set f [open $path(foo) r]
+ set f2 [open $path(foo) r]
+ set f3 [open $path(foo) r]
fileevent $f readable {f script}
fileevent $f2 readable {f2 script}
fileevent $f3 readable {f3 script}
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
+testConstraint testfevent [llength [info commands testfevent]]
-if {[info commands testfevent] == "testfevent"} {
-
- test io-46.1 {Tcl event loop vs multiple interpreters} {} {
+test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent} {
testfevent create
- testfevent cmd {
- set f [open foo r]
+ testfevent cmd [format {
+ set f [open %s r]
set x "no event"
- fileevent $f readable {
+ fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
- }
- }
+ }]
+ } $path(foo)]
after 1 ;# We must delay because Windows takes a little time to notice
update
testfevent cmd {close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
-test io-46.2 {Tcl event loop vs multiple interpreters} {
+test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
- set x 0
+ variable x 0
after 100 {set x triggered}
- vwait x
+ vwait [namespace which -variable x]
set x
}
} {triggered}
-test io-46.3 {Tcl event loop vs multiple interpreters} {
+test io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
testfevent cmd {
set x 0
}
} {0 0 {0 timer}}
-test io-47.1 {fileevent vs multiple interpreters} {
- set f [open foo r]
- set f2 [open foo r]
- set f3 [open foo r]
+test io-47.1 {fileevent vs multiple interpreters} testfevent {
+ set f [open $path(foo) r]
+ set f2 [open $path(foo) r]
+ set f3 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
close $f3
set x
} {{} {script 1} {} {sript 3}}
-test io-47.2 {deleting fileevent on interpreter delete} {
- set f [open foo r]
- set f2 [open foo r]
- set f3 [open foo r]
- set f4 [open foo r]
+test io-47.2 {deleting fileevent on interpreter delete} testfevent {
+ set f [open $path(foo) r]
+ set f2 [open $path(foo) r]
+ set f3 [open $path(foo) r]
+ set f4 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
close $f4
set x
} {{script 1} {} {} {script 4}}
-test io-47.3 {deleting fileevent on interpreter delete} {
- set f [open foo r]
- set f2 [open foo r]
- set f3 [open foo r]
- set f4 [open foo r]
+test io-47.3 {deleting fileevent on interpreter delete} testfevent {
+ set f [open $path(foo) r]
+ set f2 [open $path(foo) r]
+ set f3 [open $path(foo) r]
+ set f4 [open $path(foo) r]
testfevent create
testfevent share $f3
testfevent share $f4
close $f4
set x
} {{script 1} {script 2} {} {}}
-test io-47.4 {file events on shared files and multiple interpreters} {
- set f [open foo r]
- set f2 [open foo r]
+test io-47.4 {file events on shared files and multiple interpreters} testfevent {
+ set f [open $path(foo) r]
+ set f2 [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
close $f2
set x
} {{script 3} {script 1} {script 2}}
-test io-47.5 {file events on shared files, deleting file events} {
- set f [open foo r]
+test io-47.5 {file events on shared files, deleting file events} testfevent {
+ set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
close $f
set x
} {{} {script 2}}
-test io-47.6 {file events on shared files, deleting file events} {
- set f [open foo r]
+test io-47.6 {file events on shared files, deleting file events} testfevent {
+ set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
set x
} {{script 1} {}}
-}
-
-# The above curly closes the test for presence of the "testfevent" command.
+set path(bar) [makeFile {} bar]
test io-48.1 {testing readability conditions} {
- set f [open bar w]
+ set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
- set f [open bar r]
- fileevent $f readable [list consume $f]
+ set f [open $path(bar) r]
+ fileevent $f readable [namespace code [list consume $f]]
proc consume {f} {
- global x l
+ variable l
+ variable x
lappend l called
if {[eof $f]} {
close $f
}
}
set l ""
- set x not_done
- vwait x
+ variable x not_done
+ vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
test io-48.2 {testing readability conditions} {nonBlockFiles} {
- set f [open bar w]
+ set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
- set f [open bar r]
- fileevent $f readable [list consume $f]
+ set f [open $path(bar) r]
+ fileevent $f readable [namespace code [list consume $f]]
fconfigure $f -blocking off
proc consume {f} {
- global x l
+ variable x
+ variable l
lappend l called
if {[eof $f]} {
close $f
}
}
set l ""
- set x not_done
- vwait x
+ variable x not_done
+ vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
-test io-48.3 {testing readability conditions} {unixOnly nonBlockFiles} {
- set f [open bar w]
+
+set path(my_script) [makeFile {} my_script]
+
+test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles} {
+ set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
- set f [open my_script w]
+ set f [open $path(my_script) w]
puts $f {
proc copy_slowly {f} {
while {![eof $f]} {
}
}
close $f
- set f [open "|[list $::tcltest::tcltest]" r+]
- fileevent $f readable [list consume $f]
+ set f [open "|[list [interpreter]]" r+]
+ fileevent $f readable [namespace code [list consume $f]]
fconfigure $f -buffering line
fconfigure $f -blocking off
proc consume {f} {
- global x l
+ variable l
+ variable x
if {[eof $f]} {
set x done
} else {
}
}
set l ""
- set x not_done
- puts $f {source my_script}
- puts $f {set f [open bar r]}
+ variable x not_done
+ puts $f [format {source %s} $path(my_script)]
+ puts $f [format {set f [open %s r]} $path(bar)]
puts $f {copy_slowly $f}
puts $f {exit}
- vwait x
+ vwait [namespace which -variable x]
close $f
list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable c
+ variable x
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable x
+ variable c
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable x
+ variable c
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable c
+ variable x
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable x
+ variable c
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable c
+ variable x
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable c
+ variable x
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation lf
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable x
+ variable c
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable l
+ variable x
+ variable c
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation cr
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable c
+ variable x
+ variable l
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable c
+ variable x
+ variable l
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation crlf
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
- global c x l
+ variable c
+ variable x
+ variable l
if {[eof $f]} {
set x done
close $f
}
set c 0
set l ""
- set f [open test1 r]
+ set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
- fileevent $f readable [list consume $f]
- vwait x
+ fileevent $f readable [namespace code [list consume $f]]
+ variable x
+ vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-49.1 {testing crlf reading, leftover cr disgorgment} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 1]
lappend l [tell $f]
} 7 0 {} 1"
test io-49.2 {testing crlf reading, leftover cr disgorgment} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 2]
lappend l [tell $f]
} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
test io-49.3 {testing crlf reading, leftover cr disgorgment} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
test io-49.4 {testing crlf reading, leftover cr disgorgment} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
test io-49.5 {testing crlf reading, leftover cr disgorgment} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set l ""
- lappend l [file size test1]
+ lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [set x [gets $f]]
lappend l [tell $f]
set l
} [list 7 a\rb\rc 7 {} 7 1]
-test io-50.1 {testing handler deletion} {} {
+testConstraint testchannelevent [llength [info commands testchannelevent]]
+test io-50.1 {testing handler deletion} {testchannelevent} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1 r]
- testchannelevent $f add readable [list delhandler $f]
+ set f [open $path(test1) r]
+ testchannelevent $f add readable [namespace code [list delhandler $f]]
proc delhandler {f} {
- global z
+ variable z
set z called
testchannelevent $f delete 0
}
close $f
set z
} called
-test io-50.2 {testing handler deletion with multiple handlers} {} {
+test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1 r]
- testchannelevent $f add readable [list delhandler $f 1]
- testchannelevent $f add readable [list delhandler $f 0]
+ set f [open $path(test1) r]
+ testchannelevent $f add readable [namespace code [list delhandler $f 1]]
+ testchannelevent $f add readable [namespace code [list delhandler $f 0]]
proc delhandler {f i} {
- global z
+ variable z
lappend z "called delhandler $f $i"
testchannelevent $f delete 0
}
string compare [string tolower $z] \
[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
-test io-50.3 {testing handler deletion with multiple handlers} {} {
+test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1 r]
- testchannelevent $f add readable [list notcalled $f 1]
- testchannelevent $f add readable [list delhandler $f 0]
+ set f [open $path(test1) r]
+ testchannelevent $f add readable [namespace code [list notcalled $f 1]]
+ testchannelevent $f add readable [namespace code [list delhandler $f 0]]
set z ""
proc notcalled {f i} {
- global z
+ variable z
lappend z "notcalled was called!! $f $i"
}
proc delhandler {f i} {
- global z
+ variable z
testchannelevent $f delete 1
lappend z "delhandler $f $i called"
testchannelevent $f delete 0
[list [list delhandler $f 0 called] \
[list delhandler $f 0 deleted myself]]
} 0
-test io-50.4 {testing handler deletion vs reentrant calls} {} {
+test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1 r]
- testchannelevent $f add readable [list delrecursive $f]
+ set f [open $path(test1) r]
+ testchannelevent $f add readable [namespace code [list delrecursive $f]]
proc delrecursive {f} {
- global z u
+ variable z
+ variable u
if {"$u" == "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
string compare [string tolower $z] \
{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
-test io-50.5 {testing handler deletion vs reentrant calls} {} {
+test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1 r]
- testchannelevent $f add readable [list notcalled $f]
- testchannelevent $f add readable [list del $f]
+ set f [open $path(test1) r]
+ testchannelevent $f add readable [namespace code [list notcalled $f]]
+ testchannelevent $f add readable [namespace code [list del $f]]
proc notcalled {f} {
- global z
+ variable z
lappend z "notcalled was called!! $f"
}
proc del {f} {
- global z u
+ variable u
+ variable z
if {"$u" == "recursive"} {
testchannelevent $f delete 1
testchannelevent $f delete 0
[list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after update}]
} 0
-test io-50.6 {testing handler deletion vs reentrant calls} {} {
+test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
close $f
- set f [open test1 r]
- testchannelevent $f add readable [list second $f]
- testchannelevent $f add readable [list first $f]
+ set f [open $path(test1) r]
+ testchannelevent $f add readable [namespace code [list second $f]]
+ testchannelevent $f add readable [namespace code [list first $f]]
proc first {f} {
- global u z
+ variable u
+ variable z
if {"$u" == "toplevel"} {
lappend z "first called"
set u first
}
}
proc second {f} {
- global u z
+ variable u
+ variable z
if {"$u" == "first"} {
lappend z "second called, first time"
set u second
set x 0
set result ""
proc accept {s a p} {
- global x wait
+ variable x
+ variable wait
fconfigure $s -blocking off
puts $s "sock[incr x]"
close $s
set wait done
}
- set ss [socket -server accept 2831]
- set wait ""
- set cs [socket [info hostname] 2831]
- vwait wait
+ set ss [socket -server [namespace code accept] 0]
+ variable wait ""
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
+ vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
- set cs [socket [info hostname] 2831]
- vwait wait
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
+ vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
- set cs [socket [info hostname] 2831]
- vwait wait
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
+ vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
set wait ""
- set cs [socket [info hostname] 2831]
- vwait wait
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
+ vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
close $ss
test io-52.1 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fcopy $f1 $f2 -command { # }
catch { fcopy $f1 $f2 } msg
close $f1
test io-52.2 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
set f3 [open $thisScript]
fcopy $f1 $f2 -command { # }
catch { fcopy $f3 $f2 } msg
test io-52.3 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
set s0 [fcopy $f1 $f2]
close $f1
close $f2
set s1 [file size $thisScript]
- set s2 [file size test1]
+ set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
test io-52.4 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- lappend result [file size test1]
+ lappend result [file size $path(test1)]
} {0 0 40}
test io-52.5 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2 -size -1
close $f1
close $f2
set s1 [file size $thisScript]
- set s2 [file size test1]
+ set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
test io-52.6 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]]
close $f1
close $f2
set s1 [file size $thisScript]
- set s2 [file size test1]
+ set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
test io-52.7 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
set s1 [file size $thisScript]
- set s2 [file size test1]
+ set s2 [file size $path(test1)]
close $f1
close $f2
if {"$s1" == "$s2"} {
test io-52.8 {TclCopyChannel} {stdio} {
removeFile test1
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
close \$f1
"
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f2 -translation lf
set s0 [fcopy $f1 $f2 -size 40]
catch {close $f1}
close $f2
- list $s0 [file size test1]
+ list $s0 [file size $path(test1)]
} {40 40}
+# Empty files, to register them with the test facility
+set path(kyrillic.txt) [makeFile {} kyrillic.txt]
+set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
+set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
+
+# Create kyrillic file, use lf translation to avoid os eol issues
+set out [open $path(kyrillic.txt) w]
+fconfigure $out -encoding koi8-r -translation lf
+puts $out "\u0410\u0410"
+close $out
+
+test io-52.9 {TclCopyChannel & encodings} {
+ # Copy kyrillic to UTF-8, using fcopy.
+
+ set in [open $path(kyrillic.txt) r]
+ set out [open $path(utf8-fcopy.txt) w]
+
+ fconfigure $in -encoding koi8-r -translation lf
+ fconfigure $out -encoding utf-8 -translation lf
+
+ fcopy $in $out
+ close $in
+ close $out
+
+ # Do the same again, but differently (read/puts).
+
+ set in [open $path(kyrillic.txt) r]
+ set out [open $path(utf8-rp.txt) w]
+
+ fconfigure $in -encoding koi8-r -translation lf
+ fconfigure $out -encoding utf-8 -translation lf
+
+ puts -nonewline $out [read $in]
+
+ close $in
+ close $out
+
+ list [file size $path(kyrillic.txt)] \
+ [file size $path(utf8-fcopy.txt)] \
+ [file size $path(utf8-rp.txt)]
+} {3 5 5}
+
+test io-52.10 {TclCopyChannel & encodings} {
+ # encoding to binary (=> implies that the
+ # internal utf-8 is written)
+
+ set in [open $path(kyrillic.txt) r]
+ set out [open $path(utf8-fcopy.txt) w]
+
+ fconfigure $in -encoding koi8-r -translation lf
+ # -translation binary is also -encoding binary
+ fconfigure $out -translation binary
+
+ fcopy $in $out
+ close $in
+ close $out
+
+ file size $path(utf8-fcopy.txt)
+} 5
+
+test io-52.11 {TclCopyChannel & encodings} {
+ # binary to encoding => the input has to be
+ # in utf-8 to make sense to the encoder
+
+ set in [open $path(utf8-fcopy.txt) r]
+ set out [open $path(kyrillic.txt) w]
+
+ # -translation binary is also -encoding binary
+ fconfigure $in -translation binary
+ fconfigure $out -encoding koi8-r -translation lf
+
+ fcopy $in $out
+ close $in
+ close $out
+
+ file size $path(kyrillic.txt)
+} 3
+
+
test io-53.1 {CopyData} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 0
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
- lappend result [file size test1]
+ lappend result [file size $path(test1)]
} {0 0 0}
test io-53.2 {CopyData} {
removeFile test1
set f1 [open $thisScript]
- set f2 [open test1 w]
+ set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
- fcopy $f1 $f2 -command {set s0}
+ fcopy $f1 $f2 -command [namespace code {set s0}]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
- vwait s0
+ variable s0
+ vwait [namespace which -variable s0]
close $f1
close $f2
set s1 [file size $thisScript]
- set s2 [file size test1]
+ set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
-test io-53.3 {CopyData: background read underflow} {unixOnly} {
+test io-53.3 {CopyData: background read underflow} {stdio unixOnly} {
removeFile test1
removeFile pipe
- set f1 [open pipe w]
- puts $f1 {
+ set f1 [open $path(pipe) w]
+ puts $f1 [format {
puts ready
flush stdout ;# Don't assume line buffered!
fcopy stdin stdout -command { set x }
vwait x
- set f [open test1 w]
+ set f [open "%s" w]
fconfigure $f -translation lf
puts $f "done"
close $f
- }
+ } $path(test1)]
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
puts $f1 line1
flush $f1
lappend result [gets $f1]
close $f1
after 500
- set f [open test1]
+ set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
-test io-53.4 {CopyData: background write overflow} {unixOnly} {
+test io-53.4 {CopyData: background write overflow} {stdio unixOnly} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
+ variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
removeFile test1
removeFile pipe
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 {
puts ready
fcopy stdin stdout -command { set x }
vwait x
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f "done"
close $f
}
close $f1
- set f1 [open "|[list $::tcltest::tcltest pipe]" r+]
+ set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
fconfigure $f1 -blocking 0
puts $f1 $big
flush $f1
after 500
set result ""
- fileevent $f1 read {
+ fileevent $f1 read [namespace code {
append result [read $f1 1024]
if {[string length $result] >= [string length $big]} {
set x done
}
- }
- vwait x
+ }]
+ vwait [namespace which -variable x]
close $f1
set big {}
set x
after 1000 "close $sock"
}
proc FcopyTestDone {bytes {error {}}} {
- global fcopyTestDone
+ variable fcopyTestDone
if {[string length $error]} {
set fcopyTestDone 1
} else {
}
test io-53.5 {CopyData: error during fcopy} {socket} {
- set listen [socket -server FcopyTestAccept 2828]
+ variable fcopyTestDone
+ set listen [socket -server [namespace code FcopyTestAccept] 0]
set in [open $thisScript] ;# 126 K
- set out [socket 127.0.0.1 2828]
+ set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
- fcopy $in $out -command FcopyTestDone
+ fcopy $in $out -command [namespace code FcopyTestDone]
+ variable fcopyTestDone
if ![info exists fcopyTestDone] {
- vwait fcopyTestDone ;# The error occurs here in the b.g.
+ vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
close $in
close $out
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio} {
+ variable fcopyTestDone
removeFile pipe
removeFile test1
catch {unset fcopyTestDone}
- set f1 [open pipe w]
+ set f1 [open $path(pipe) w]
puts $f1 "exit 1"
close $f1
- set in [open "|[list $::tcltest::tcltest pipe]" r+]
- set out [open test1 w]
- fcopy $in $out -command [list FcopyTestDone]
+ set in [open "|[list [interpreter] $path(pipe)]" r+]
+ set out [open $path(test1) w]
+ fcopy $in $out -command [namespace code FcopyTestDone]
+ variable fcopyTestDone
if ![info exists fcopyTestDone] {
- vwait fcopyTestDone
+ vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
set fcopyTestDone ;# 0 for plain end of file
} {0}
+proc doFcopy {in out {bytes 0} {error {}}} {
+ variable fcopyTestDone
+ variable fcopyTestCount
+ incr fcopyTestCount $bytes
+ if {[string length $error]} {
+ set fcopyTestDone 1
+ } elseif {[eof $in]} {
+ set fcopyTestDone 0
+ } else {
+ # Delay next fcopy to wait for size>0 input bytes
+ after 100 [list
+ fcopy $in $out -size 1000 \
+ -command [namespace code [list doFcopy $in $out]]
+ ]
+ }
+}
+
+test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
+ variable fcopyTestDone
+ removeFile pipe
+ removeFile test1
+ catch {unset fcopyTestDone}
+ set fcopyTestCount 0
+ set f1 [open $path(pipe) w]
+ puts $f1 {
+ # Write 10 bytes / 10 msec
+ proc Write {count} {
+ puts -nonewline "1234567890"
+ if {[incr count -1]} {
+ after 10 [list Write $count]
+ } else {
+ set ::ready 1
+ }
+ }
+ fconfigure stdout -buffering none
+ Write 345 ;# 3450 bytes ~3.45 sec
+ vwait ready
+ exit 0
+ }
+ close $f1
+ set in [open "|[list [interpreter] $path(pipe) &]" r+]
+ set out [open $path(test1) w]
+ doFcopy $in $out
+ variable fcopyTestDone
+ if ![info exists fcopyTestDone] {
+ vwait [namespace which -variable fcopyTestDone]
+ }
+ catch {close $in}
+ close $out
+ # -1=error 0=script error N=number of bytes
+ expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
+} {3450}
+
test io-54.1 {Recursive channel events} {socket} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
- global as
+ variable as
fconfigure $s -translation lf
puts $s "line 1\nline2\nline3"
flush $s
set as $s
}
proc readit {s next} {
- global result x
+ variable x
+ variable result
lappend result $next
if {$next == 1} {
- fileevent $s readable [list readit $s 2]
- vwait x
+ fileevent $s readable [namespace code [list readit $s 2]]
+ vwait [namespace which -variable x]
}
incr x
}
- set ss [socket -server accept 2828]
+ set ss [socket -server [namespace code accept] 0]
# We need to delay on some systems until the creation of the
# server socket completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
- if {![catch {set cs [socket [info hostname] 2828]}]} {
+ if {![catch {set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]}]} {
set done 1
break
}
close $ss
error "failed to connect to server"
}
- set result {}
- set x 0
- vwait as
+ variable result {}
+ variable x 0
+ variable as
+ vwait [namespace which -variable as]
fconfigure $cs -translation lf
lappend result [gets $cs]
fconfigure $cs -blocking off
- fileevent $cs readable [list readit $cs 1]
- set a [after 2000 { set x failure }]
- vwait x
+ fileevent $cs readable [namespace code [list readit $cs 1]]
+ set a [after 2000 [namespace code { set x failure }]]
+ vwait [namespace which -variable x]
after cancel $a
close $as
close $ss
test io-54.2 {Testing for busy-wait in recursive channel events} {socket} {
set accept {}
set after {}
- set s [socket -server accept 3939]
+ variable s [socket -server [namespace code accept] 0]
proc accept {s a p} {
- global counter accept
+ variable counter
+ variable accept
set accept $s
set counter 0
fconfigure $s -blocking off -buffering line -translation lf
- fileevent $s readable "doit $s"
+ fileevent $s readable [namespace code "doit $s"]
}
proc doit {s} {
- global counter after
+ variable counter
+ variable after
incr counter
set l [gets $s]
if {"$l" == ""} {
- fileevent $s readable "doit1 $s"
- set after [after 1000 newline]
+ fileevent $s readable [namespace code "doit1 $s"]
+ set after [after 1000 [namespace code newline]]
}
}
proc doit1 {s} {
- global counter accept
+ variable counter
+ variable accept
incr counter
set l [gets $s]
set accept {}
}
proc producer {} {
- global writer
+ variable s
+ variable writer
- set writer [socket 127.0.0.1 3939]
+ set writer [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
fconfigure $writer -buffering line
puts -nonewline $writer hello
flush $writer
}
proc newline {} {
- global writer done
+ variable done
+ variable writer
puts $writer hello
flush $writer
set done 1
}
producer
- vwait done
+ variable done
+ vwait [namespace which -variable done]
close $writer
close $s
after cancel $after
set counter
} 1
+set path(fooBar) [makeFile {} fooBar]
+
test io-55.1 {ChannelEventScriptInvoker: deletion} {
+ variable x
proc eventScript {fd} {
+ variable x
close $fd
error "planned error"
- set ::x whoops
+ set x whoops
}
- proc bgerror {args} {
- set ::x got_error
- }
- set f [open fooBar w]
- fileevent $f writable [list eventScript $f]
- set x not_done
- vwait x
+ proc ::bgerror {args} "set [namespace which -variable x] got_error"
+ set f [open $path(fooBar) w]
+ fileevent $f writable [namespace code [list eventScript $f]]
+ variable x not_done
+ vwait [namespace which -variable x]
set x
} {got_error}
-test io-56.1 {ChannelTimerProc} {
- set f [open fooBar w]
+test io-56.1 {ChannelTimerProc} {testchannelevent} {
+ set f [open $path(fooBar) w]
puts $f "this is a test"
close $f
- set f [open fooBar r]
- testchannelevent $f add readable {
+ set f [open $path(fooBar) r]
+ testchannelevent $f add readable [namespace code {
read $f 1
incr x
- }
- set x 0
- vwait x
- vwait x
+ }]
+ variable x 0
+ vwait [namespace which -variable x]
+ vwait [namespace which -variable x]
set result $x
testchannelevent $f set 0 none
- after idle {set y done}
- vwait y
+ after idle [namespace code {set y done}]
+ variable y
+ vwait [namespace which -variable y]
close $f
lappend result $y
} {2 done}
test io-57.1 {buffered data and file events, gets} {
proc accept {sock args} {
- set ::s2 $sock
+ variable s2
+ set s2 $sock
}
- set server [socket -server accept 4040]
- set s [socket 127.0.0.1 4040]
- vwait s2
+ set server [socket -server [namespace code accept] 0]
+ set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
+ variable s2
+ vwait [namespace which -variable s2]
update
- fileevent $s2 readable {lappend result readable}
+ fileevent $s2 readable [namespace code {lappend result readable}]
puts $s "12\n34567890"
flush $s
- set result [gets $s2]
- after 1000 {lappend result timer}
- vwait result
+ variable result [gets $s2]
+ after 1000 [namespace code {lappend result timer}]
+ vwait [namespace which -variable result]
lappend result [gets $s2]
- vwait result
+ vwait [namespace which -variable result]
close $s
close $s2
close $server
} {12 readable 34567890 timer}
test io-57.2 {buffered data and file events, read} {
proc accept {sock args} {
- set ::s2 $sock
+ variable s2
+ set s2 $sock
}
- set server [socket -server accept 4041]
- set s [socket 127.0.0.1 4041]
- vwait s2
+ set server [socket -server [namespace code accept] 0]
+ set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
+ variable s2
+ vwait [namespace which -variable s2]
update
- fileevent $s2 readable {lappend result readable}
+ fileevent $s2 readable [namespace code {lappend result readable}]
puts -nonewline $s "1234567890"
flush $s
- set result [read $s2 1]
- after 1000 {lappend result timer}
- vwait result
+ variable result [read $s2 1]
+ after 1000 [namespace code {lappend result timer}]
+ vwait [namespace which -variable result]
lappend result [read $s2 9]
- vwait result
+ vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
-test io-58.1 {Tcl_NotifyChannel and error when closing} {unixOrPc} {
- set out [open script w]
+test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc} {
+ set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
- global x result
+ variable x
+ variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
lappend result catch $line
}
}
close $out
- set pipe [open "|[list $::tcltest::tcltest] script" r]
- fileevent $pipe readable [list readit $pipe]
- set x ""
+ set pipe [open "|[list [interpreter] $path(script)]" r]
+ fileevent $pipe readable [namespace code [list readit $pipe]]
+ variable x ""
set result ""
- vwait x
+ vwait [namespace which -variable x]
list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}
-# cleanup
-foreach file [list fooBar longfile script output test1 pipe my_script foo \
- bar test2 test3 cat stdout] {
- ::tcltest::removeFile $file
-}
-::tcltest::restoreState
-::tcltest::cleanupTests
-return
-
-
-
-
+testConstraint testmainthread [llength [info commands testmainthread]]
+test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
+ # TIP #10
+ # More complicated tests (like that the reference changes as a
+ # channel is moved from thread to thread) can be done only in the
+ # extension which fully implements the moving of channels between
+ # threads, i.e. 'Threads'. Or we have to extend [testthread] as well.
+ set f [open $path(longfile) r]
+ set result [testchannel mthread $f]
+ close $f
+ string equal $result [testmainthread]
+} {1}
+test io-60.1 {writing illegal utf sequences} {
+ # This test will hang in older revisions of the core.
+ set out [open $path(script) w]
+ puts $out {
+ puts [encoding convertfrom identity \xe2]
+ exit 1
+ }
+ proc readit {pipe} {
+ variable x
+ variable result
+ if {[eof $pipe]} {
+ set x [catch {close $pipe} line]
+ lappend result catch $line
+ } else {
+ gets $pipe line
+ lappend result gets $line
+ }
+ }
+ close $out
+ set pipe [open "|[list [interpreter] $path(script)]" r]
+ fileevent $pipe readable [namespace code [list readit $pipe]]
+ variable x ""
+ set result ""
+ vwait [namespace which -variable x]
+ # cut of the remainder of the error stack, especially the filename
+ set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
+ list $x $result
+} {1 {gets {} catch {error writing "stdout": invalid argument}}}
+# cleanup
+foreach file [list fooBar longfile script output test1 pipe my_script foo \
+ bar test2 test3 cat stdout] {
+ removeFile $file
+}
+cleanupTests
+}
+namespace delete ::tcl::test::io
+return
removeFile test1
removeFile pipe
-set executable [list [info nameofexecutable]]
-
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.5 {puts command} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
+
+set path(test1) [makeFile {} test1]
+
test iocmd-1.6 {puts command} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f foobar
close $f
- file size test1
+ file size $path(test1)
} 6
test iocmd-1.7 {puts command} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f foobar
close $f
- file size test1
+ file size $path(test1)
} 7
test iocmd-1.8 {puts command} {
- set f [open test1 w]
+ set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f [binary format a4a5 foo bar]
close $f
- file size test1
+ file size $path(test1)
} 9
list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f [binary format a4a5 foo bar]
close $f
- set f [open test1 r]
+ set f [open $path(test1) r]
set result [gets $f]
close $f
set x foo\x00
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
- set f [open test1]
+ set f [open $path(test1)]
set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode]
close $f
set x
test iocmd-4.10 {read command} {
list [catch {read file107} msg] $msg $errorCode
} {1 {can not find channel named "file107"} NONE}
+
+set path(test3) [makeFile {} test3]
+
test iocmd-4.11 {read command} {
- set f [open test3 w]
+ set f [open $path(test3) w]
set x [list [catch {read $f} msg] $msg $errorCode]
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} {
- set f [open test1]
+ set f [open $path(test1)]
set x [list [catch {read $f 12z} msg] $msg $errorCode]
close $f
set x
} {1 {can not find channel named "a"}}
test iocmd-8.4 {fconfigure command} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
set x [list [catch {fconfigure $f1 froboz} msg] $msg]
close $f1
set x
} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}}
test iocmd-8.7 {fconfigure command} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {} -encoding unicode
set x [fconfigure $f1]
close $f1
} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-eofchar {} -encoding unicode
set x ""
} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} {
removeFile test1
- set f1 [open test1 w]
+ set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary
set x [fconfigure $f1]
test iocmd-8.10 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
+
+set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
+
test iocmd-8.11 {fconfigure command} {
- list [catch {fconfigure stdout -froboz blarfo} msg] $msg
+ set chan [open $path(fconfigure.dummy) r]
+ set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
+ close $chan
+ set res
} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+
test iocmd-8.12 {fconfigure command} {
- list [catch {fconfigure stdout -b blarfo} msg] $msg
+ set chan [open $path(fconfigure.dummy) r]
+ set res [list [catch {fconfigure $chan -b blarfo} msg] $msg]
+ close $chan
+ set res
} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+
test iocmd-8.13 {fconfigure command} {
- list [catch {fconfigure stdout -buffer blarfo} msg] $msg
+ set chan [open $path(fconfigure.dummy) r]
+ set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg]
+ close $chan
+ set res
} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
+
+removeFile fconfigure.dummy
+
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
+
proc iocmdSSETUP {} {
- uplevel {
- set srv [socket -server iocmdSRV 0];
- set port [lindex [fconfigure $srv -sockname] 2];
+ uplevel {
+ set srv [socket -server iocmdSRV 0]
+ set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
- set cli [socket 127.0.0.1 $port];
- }
+ set cli [socket 127.0.0.1 $port]
+ }
}
proc iocmdSSHTDWN {} {
- uplevel {
- close $cli;
- close $srv;
+ uplevel {
+ close $cli
+ close $srv
unset cli srv port
rename iocmdSRV {}
- }
+ }
}
-test iocmd-8.15 {fconfigure command / tcp channel} {socket} {
+test iocmd-8.15.0 {fconfigure command / tcp channel} {socket macOnly} {
iocmdSSETUP
- set r [list [catch {fconfigure $cli -blah} msg] $msg];
+ set r [list [catch {fconfigure $cli -blah} msg] $msg]
iocmdSSHTDWN
- set r;
+ set r
+} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -error, -peername, or -sockname}}
+test iocmd-8.15.1 {fconfigure command / tcp channel} {socket unixOrPc} {
+ iocmdSSETUP
+ set r [list [catch {fconfigure $cli -blah} msg] $msg]
+ iocmdSSHTDWN
+ set r
} {1 {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname}}
test iocmd-8.16 {fconfigure command / tcp channel} {socket} {
iocmdSSETUP
- set r [expr [lindex [fconfigure $cli -peername] 2]==$port];
+ set r [expr [lindex [fconfigure $cli -peername] 2]==$port]
iocmdSSHTDWN
set r
} 1
fblocked stdin
} 0
+set path(test4) [makeFile {} test4]
+set path(test5) [makeFile {} test5]
+
removeFile test5
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
- set f [open test4 w]
+ set f [open $path(test4) w]
close $f
- list [catch {open "| cat < test4 > test5" w} msg] $msg $errorCode
+ list [catch {open "| cat < $path(test4) > $path(test5)" w} msg] $msg $errorCode
} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
- list [catch {open "| echo > test5" r} msg] $msg $errorCode
+ list [catch {open "| echo > $path(test5)" r} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
- list [catch {open "| echo > test5" r+} msg] $msg $errorCode
+ list [catch {open "| echo > $path(test5)" r+} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-12.1 {POSIX open access modes: RDONLY} {
removeFile test1
- set f [open test1 w]
+ set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
- set f [open test1 RDONLY]
+ set f [open $path(test1) RDONLY]
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
close $f
string compare $x \
} 0
test iocmd-12.2 {POSIX open access modes: RDONLY} {
removeFile test3
- string tolower [list [catch {open test3 RDONLY} msg] $msg]
+ set msg [list [catch {open $path(test3) RDONLY} msg] $msg]
+ regsub [file join {} $path(test3)] $msg "test3" msg
+ string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test iocmd-12.3 {POSIX open access modes: WRONLY} {
removeFile test3
- string tolower [list [catch {open test3 WRONLY} msg] $msg]
+ set msg [list [catch {open $path(test3) WRONLY} msg] $msg]
+ regsub [file join {} $path(test3)] $msg "test3" msg
+ string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} {
removeFile test3
- set f [open test3 w]
+ set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts $f xyzzy
close $f
- set f [open test3 WRONLY]
+ set f [open $path(test3) WRONLY]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
- set f [open test3 r]
+ set f [open $path(test3) r]
fconfigure $f -eofchar {}
lappend x [gets $f]
close $f
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} {
removeFile test3
- string tolower [list [catch {open test3 RDWR} msg] $msg]
+ set msg [list [catch {open $path(test3) RDWR} msg] $msg]
+ regsub [file join {} $path(test3)] $msg "test3" msg
+ string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test iocmd-12.6 {POSIX open access modes: errors} {
- concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
+ concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
while processing open access modes \"FOO {BAR BAZ\"
invoked from within
-\"open test3 \"FOO \\{BAR BAZ\"\""
+\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
- list [catch {open test3 {FOO BAR BAZ}} msg] $msg
+ list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
- list [catch {open test3 {TRUNC CREAT}} msg] $msg
+ list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
test iocmd-13.1 {errors in open command} {
list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.3 {errors in open command} {
- list [catch {open test1 x} msg] $msg
+ list [catch {open $path(test1) x} msg] $msg
} {1 {illegal access mode "x"}}
test iocmd-13.4 {errors in open command} {
- list [catch {open test1 rw} msg] $msg
+ list [catch {open $path(test1) rw} msg] $msg
} {1 {illegal access mode "rw"}}
test iocmd-13.5 {errors in open command} {
- list [catch {open test1 r+1} msg] $msg
+ list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
- string tolower [list [catch {open _non_existent_} msg] $msg $errorCode]
+ set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
+ regsub [file join {} _non_existent_] $msg "_non_existent_" msg
+ string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
test iocmd-14.1 {file id parsing errors} {
test iocmd-14.9 {file id parsing errors} {
list [catch {eof stderr1} msg] $msg
} {1 {can not find channel named "stderr1"}}
-set f [open test1 w]
+
+set f [open $path(test1) w]
close $f
+
set expect "1 {can not find channel named \"$f\"}"
test iocmd-14.10 {file id parsing errors} {
list [catch {eof $f} msg] $msg
test iocmd-15.5 {Tcl_FcopyObjCmd} {
list [catch {fcopy 1 2 3 4 5} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
-set f [open test1 w]
+
+set path(test2) [makeFile {} test2]
+
+set f [open $path(test1) w]
close $f
-set rfile [open test1 r]
-set wfile [open test2 w]
+
+set rfile [open $path(test1) r]
+set wfile [open $path(test2) w]
+
test iocmd-15.6 {Tcl_FcopyObjCmd} {
list [catch {fcopy foo $wfile} msg] $msg
} {1 {can not find channel named "foo"}}
# cleanup
foreach file [list test1 test2 test3 test4] {
- ::tcltest::removeFile $file
+ catch {::tcltest::removeFile $file}
}
# delay long enough for background processes to finish
after 500
foreach file [list test5 pipe output] {
- ::tcltest::removeFile $file
+ catch {::tcltest::removeFile $file}
}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
+::tcltest::testConstraint testopenfilechannelproc \
+ [llength [info commands testopenfilechannelproc]]
+::tcltest::testConstraint testaccessproc \
+ [llength [info commands testaccessproc]]
+::tcltest::testConstraint teststatproc \
+ [llength [info commands teststatproc]]
+
set unsetScript {
catch {unset testStat1(size)}
catch {unset testStat2(size)}
catch {unset testStat3(size)}
}
-test ioUtil-1.1 {TclStat: Check that none of the test procs are there.} {knownBug} {
+test ioUtil-1.1 {TclStat: Check that none of the test procs are there.} {} {
catch {file stat testStat1%.fil testStat1} err1
catch {file stat testStat2%.fil testStat2} err2
catch {file stat testStat3%.fil testStat3} err3
list $err1 $err2 $err3
-} {{couldn't stat "testStat1%.fil": no such file or directory} {couldn't stat "testStat2%.fil": no such file or directory} {couldn't stat "testStat3%.fil": no such file or directory}}
+} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}}
-if {[info commands teststatproc] == {}} {
- puts "This application hasn't been compiled with the \"teststatproc\""
- puts "command, so I can't test Tcl_Stat_* etc."
-} else {
-test ioUtil-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} {
+test ioUtil-1.2 {TclStatInsertProc: Insert the 3 test TclStat_ procedures.} {teststatproc} {
catch {teststatproc insert TclpStat} err1
teststatproc insert TestStatProc1
teststatproc insert TestStatProc2
set err1
} {bad arg "insert": must be TestStatProc1, TestStatProc2, or TestStatProc3}
-test ioUtil-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} {knownBug} {
+test ioUtil-1.3 {TclStat: Use "file stat ?" to invoke each procedure.} {teststatproc} {
file stat testStat2%.fil testStat2
file stat testStat1%.fil testStat1
file stat testStat3%.fil testStat3
eval $unsetScript
-test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletedable.} {
+test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletable.} {teststatproc} {
catch {teststatproc delete TclpStat} err2
set err2
} {"TclpStat": could not be deleteed}
-test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {knownBug} {
+test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {teststatproc} {
# Delete the 2nd procedure and test that it longer exists but that
# the others do actually return a result.
file stat testStat3%.fil testStat3
list $testStat1(size) $err3 $testStat3(size)
-} {1234 {couldn't stat "testStat2%.fil": no such file or directory} 3456}
+} {1234 {could not read "testStat2%.fil": no such file or directory} 3456}
eval $unsetScript
-test ioUtil-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} {knownBug} {
+test ioUtil-1.6 {TclStatDeleteProc: Delete the 1st TclStat procedure.} {teststatproc} {
# Next delete the 1st procedure and test that only the 3rd procedure
# is the only one that exists.
file stat testStat3%.fil testStat3
list $err4 $err5 $testStat3(size)
-} {{couldn't stat "testStat1%.fil": no such file or directory} {couldn't stat "testStat2%.fil": no such file or directory} 3456}
+} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} 3456}
eval $unsetScript
-test ioUtil-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone.} {knownBug} {
+test ioUtil-1.7 {TclStatDeleteProc: Delete the 3rd procedure & verify all are gone.} {teststatproc} {
# Finally delete the 3rd procedure and check that none of the
# procedures exist.
catch {file stat testStat3%.fil testStat3} err8
list $err6 $err7 $err8
-} {{couldn't stat "testStat1%.fil": no such file or directory} {couldn't stat "testStat2%.fil": no such file or directory} {couldn't stat "testStat3%.fil": no such file or directory}}
+} {{could not read "testStat1%.fil": no such file or directory} {could not read "testStat2%.fil": no such file or directory} {could not read "testStat3%.fil": no such file or directory}}
eval $unsetScript
-test ioUtil-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} {knownBug} {
+test ioUtil-1.8 {TclStatDeleteProc: Verify that all procs have been deleted.} {teststatproc} {
# Attempt to delete all the Stat procs. again to ensure they no longer
# exist and an error is returned.
list $err9 $err10 $err11
} {{"TestStatProc1": could not be deleteed} {"TestStatProc2": could not be deleteed} {"TestStatProc3": could not be deleteed}}
-}
eval $unsetScript
-
-test access-1.1 {TclAccess: Check that none of the test procs are there.} {
+test ioUtil-1.1 {TclAccess: Check that none of the test procs are there.} {
catch {file exists testAccess1%.fil} err1
catch {file exists testAccess2%.fil} err2
catch {file exists testAccess3%.fil} err3
list $err1 $err2 $err3
} {0 0 0}
-if {[info commands testaccessproc] == {}} {
- puts "This application hasn't been compiled with the \"testaccessproc\""
- puts "command, so I can't test Tcl_Access_* etc."
-} else {
-test ioUtil-1.2 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {
+test ioUtil-1.2 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {testaccessproc} {
catch {testaccessproc insert TclpAccess} err1
testaccessproc insert TestAccessProc1
testaccessproc insert TestAccessProc2
set err1
} {bad arg "insert": must be TestAccessProc1, TestAccessProc2, or TestAccessProc3}
-test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {
- list \
- [file exists testAccess2%.fil] \
- [file exists testAccess1%.fil] \
- [file exists testAccess3%.fil]
+test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} {
+ list [file exists testAccess2%.fil] \
+ [file exists testAccess1%.fil] \
+ [file exists testAccess3%.fil]
} {1 1 1}
-test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletedable.} {
+test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletable.} {testaccessproc} {
catch {testaccessproc delete TclpAccess} err2
set err2
} {"TclpAccess": could not be deleteed}
-test accesst-1.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {
+test ioUtil-2.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {testaccessproc} {
# Delete the 2nd procedure and test that it longer exists but that
- # the others do actually return a result.
+ # the others do actually return a result.
testaccessproc delete TestAccessProc2
set res1 [file exists testAccess1%.fil]
list $res1 $err3 $res2
} {1 0 1}
-test ioUtil-2.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} {
+test ioUtil-2.6 {TclAccessDeleteProc: Delete the 1st TclAccess procedure.} {testaccessproc} {
# Next delete the 1st procedure and test that only the 3rd procedure
# is the only one that exists.
list $err4 $err5 $res3
} {0 0 1}
-test ioUtil-2.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are gone.} {
+test ioUtil-2.7 {TclAccessDeleteProc: Delete the 3rd procedure & verify all are gone.} {testaccessproc} {
# Finally delete the 3rd procedure and check that none of the
# procedures exist.
list $err6 $err7 $err8
} {0 0 0}
-test ioUtil-2.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} {
+test ioUtil-2.8 {TclAccessDeleteProc: Verify that all procs have been deleted.} {testaccessproc} {
# Attempt to delete all the Access procs. again to ensure they no longer
# exist and an error is returned.
list $err9 $err10 $err11
} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}}
-}
-test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {
- catch {file exists __testOpenFileChannel1%__.fil} err1
- catch {file exists __testOpenFileChannel2%__.fil} err2
- catch {file exists __testOpenFileChannel3%__.fil} err3
+# Some of the following tests require a writable current directory
+set oldpwd [pwd]
+cd [temporaryDirectory]
+
+test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} {
+ catch {eval [list file delete -force] [glob *testOpenFileChannel*]}
+ catch {file exists testOpenFileChannel1%.fil} err1
+ catch {file exists testOpenFileChannel2%.fil} err2
+ catch {file exists testOpenFileChannel3%.fil} err3
catch {file exists __testOpenFileChannel1%__.fil} err4
catch {file exists __testOpenFileChannel2%__.fil} err5
catch {file exists __testOpenFileChannel3%__.fil} err6
list $err1 $err2 $err3 $err4 $err5 $err6
} {0 0 0 0 0 0}
-if {[info commands testopenfilechannelproc] == {}} {
- puts "This application hasn't been compiled with the \"testopenfilechannelproc\""
- puts "command, so I can't test Tcl_OpenFileChannelInsert"
-} else {
-test ioUtil-3.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpenFileChannel_ procedures.} {
+test ioUtil-3.2 {TclOpenFileChannelInsertProc: Insert the 3 test TclOpenFileChannel_ procedures.} {testopenfilechannelproc} {
catch {testopenfilechannelproc insert TclpOpenFileChannel} err1
testopenfilechannelproc insert TestOpenFileChannelProc1
testopenfilechannelproc insert TestOpenFileChannelProc2
set err1
} {bad arg "insert": must be TestOpenFileChannelProc1, TestOpenFileChannelProc2, or TestOpenFileChannelProc3}
-test ioUtil-3.3 {TclOpenFileChannel: Use "file openfilechannel ?" to invoke each procedure.} {
- close [open __testOpenFileChannel1%__.fil w]
- close [open __testOpenFileChannel2%__.fil w]
- close [open __testOpenFileChannel3%__.fil w]
+test ioUtil-3.3 {TclOpenFileChannel: Use "file openfilechannel ?" to invoke each procedure.} {testopenfilechannelproc} {
+ close [open __testOpenFileChannel1%__.fil w]
+ close [open __testOpenFileChannel2%__.fil w]
+ close [open __testOpenFileChannel3%__.fil w]
- catch {
- close [open testOpenFileChannel1%.fil r]
- close [open testOpenFileChannel2%.fil r]
- close [open testOpenFileChannel3%.fil r]
- } err
+ catch {
+ close [open testOpenFileChannel1%.fil r]
+ close [open testOpenFileChannel2%.fil r]
+ close [open testOpenFileChannel3%.fil r]
+ } err
- file delete __testOpenFileChannel1%__.fil
- file delete __testOpenFileChannel2%__.fil
- file delete __testOpenFileChannel3%__.fil
+ file delete __testOpenFileChannel1%__.fil
+ file delete __testOpenFileChannel2%__.fil
+ file delete __testOpenFileChannel3%__.fil
- set err
+ set err
} {}
-test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletedable.} {
+test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletable.} {testopenfilechannelproc} {
catch {testopenfilechannelproc delete TclpOpenFileChannel} err2
set err2
} {"TclpOpenFileChannel": could not be deleteed}
-test openfilechannelt-1.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {
+test ioUtil-3.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {testopenfilechannelproc} {
# Delete the 2nd procedure and test that it longer exists but that
# the others do actually return a result.
testopenfilechannelproc delete TestOpenFileChannelProc2
- close [open __testOpenFileChannel1%__.fil w]
- close [open __testOpenFileChannel3%__.fil w]
+ close [open __testOpenFileChannel1%__.fil w]
+ close [open __testOpenFileChannel3%__.fil w]
- catch {
- close [open testOpenFileChannel1%.fil r]
- catch {close [open testOpenFileChannel2%.fil r]}
- close [open testOpenFileChannel3%.fil r]
- } err3
+ catch {
+ close [open testOpenFileChannel1%.fil r]
+ catch {close [open testOpenFileChannel2%.fil r]} msg1
+ close [open testOpenFileChannel3%.fil r]
+ } err3
- file delete __testOpenFileChannel1%__.fil
- file delete __testOpenFileChannel3%__.fil
+ file delete __testOpenFileChannel1%__.fil
+ file delete __testOpenFileChannel3%__.fil
- set err3
-} {}
+ list $err3 $msg1
+} {{} {couldn't open "testOpenFileChannel2%.fil": no such file or directory}}
-test ioUtil-3.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFileChannel procedure.} {
+test ioUtil-3.6 {TclOpenFileChannelDeleteProc: Delete the 1st TclOpenFileChannel procedure.} {testopenfilechannelproc} {
# Next delete the 1st procedure and test that only the 3rd procedure
# is the only one that exists.
testopenfilechannelproc delete TestOpenFileChannelProc1
- close [open __testOpenFileChannel3%__.fil w]
+ close [open __testOpenFileChannel3%__.fil w]
- catch {
- catch {close [open testOpenFileChannel1%.fil r]}
- catch {close [open testOpenFileChannel2%.fil r]}
- close [open testOpenFileChannel3%.fil r]
- } err4
+ catch {
+ catch {close [open testOpenFileChannel1%.fil r]} msg2
+ catch {close [open testOpenFileChannel2%.fil r]} msg3
+ close [open testOpenFileChannel3%.fil r]
+ } err4
- file delete __testOpenFileChannel3%__.fil
+ file delete __testOpenFileChannel3%__.fil
- set err4
-} {}
+ list $err4 $msg2 $msg3
+} [list {} \
+ {couldn't open "testOpenFileChannel1%.fil": no such file or directory}\
+ {couldn't open "testOpenFileChannel2%.fil": no such file or directory}]
-test ioUtil-3.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure & verify all are gone.} {
+test ioUtil-3.7 {TclOpenFileChannelDeleteProc: Delete the 3rd procedure & verify all are gone.} {testopenfilechannelproc} {
# Finally delete the 3rd procedure and check that none of the
# procedures exist.
testopenfilechannelproc delete TestOpenFileChannelProc3
- catch {
- catch [open testOpenFileChannel1%.fil r]
- catch [open testOpenFileChannel2%.fil r]
- catch [open testOpenFileChannel3%.fil r]
- } err5
+ catch {
+ catch {close [open testOpenFileChannel1%.fil r]} msg4
+ catch {close [open testOpenFileChannel2%.fil r]} msg5
+ catch {close [open testOpenFileChannel3%.fil r]} msg6
+ } err5
- set err5
-} {1}
+ list $err5 $msg4 $msg5 $msg6
+} [list 1 \
+ {couldn't open "testOpenFileChannel1%.fil": no such file or directory}\
+ {couldn't open "testOpenFileChannel2%.fil": no such file or directory}\
+ {couldn't open "testOpenFileChannel3%.fil": no such file or directory}]
-test ioUtil-3.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been deleted.} {
- # Attempt to delete all the OpenFileChannel procs. again to ensure they no longer
- # exist and an error is returned.
+test ioUtil-3.8 {TclOpenFileChannelDeleteProc: Verify that all procs have been deleted.} {testopenfilechannelproc} {
+
+ # Attempt to delete all the OpenFileChannel procs. again to ensure they no
+ # longer exist and an error is returned.
catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9
catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10
list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
-}
+
+cd $oldpwd
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
#
# RCS: @(#) $Id$
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
-
-if {[info commands testchannel] == ""} {
- puts "Skipping io tests. This application does not seem to have the"
- puts "testchannel command that is needed to run these tests."
+if {[catch {package require tcltest 2.1}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
+namespace eval ::tcl::test::iogt {
-::tcltest::saveState
+ namespace import ::tcltest::cleanupTests
+ namespace import ::tcltest::makeFile
+ namespace import ::tcltest::removeFile
+ namespace import ::tcltest::test
+ namespace import ::tcltest::testConstraint
-#::tcltest::makeFile contents name
+ testConstraint testchannel [llength [info commands testchannel]]
-::tcltest::makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=} dummy
+set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
+} dummy]
# " capture coloring of quotes
-::tcltest::makeFile {} dummyout
+set path(dummyout) [makeFile {} dummyout]
-::tcltest::makeFile {
+set path(__echo_srv__.tcl) [makeFile {
#!/usr/local/bin/tclsh
# -*- tcl -*-
# echo server
set c 0
proc newconn {sock rhost rport} {
- global c fdelay
+ variable fdelay
+ variable c
incr c
+ variable c$c
#puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout
- upvar #0 c$c conn
+ upvar 0 c$c conn
set conn(after) {}
set conn(state) 0
set conn(size) 0
}
proc echoGet {c sock} {
- global fdelay
- upvar #0 c$c conn
+ variable fdelay
+ variable c$c
+ upvar 0 c$c conn
if {[eof $sock]} {
# one-shot echo
}
proc echoPut {c sock} {
- global idelay fdelay bsizes
- upvar #0 c$c conn
+ variable idelay
+ variable fdelay
+ variable bsizes
+ variable c$c
+ upvar 0 c$c conn
if {[string length $conn(data)] == 0} {
#puts stdout "C $c $sock" ; flush stdout
# main
socket -server newconn $port
vwait forever
-} __echo_srv__.tcl
+} __echo_srv__.tcl]
########################################################################
}
proc id_optrail {var op data} {
- upvar #0 $var trail
+ variable $var
+ upvar 0 $var trail
lappend trail $op
proc id_fulltrail {var op data} {
- upvar #0 $var trail
+ variable $var
+ upvar 0 $var trail
#puts stdout ">> $var $op $data" ; flush stdout
}
proc counter {var op data} {
- upvar #0 $var n
+ variable $var
+ upvar 0 $var n
switch -- $op {
create/write - create/read -
proc counter_audit {var vtrail op data} {
- upvar #0 $var n $vtrail trail
+ variable $var
+ variable $vtrail
+ upvar 0 $var n $vtrail trail
switch -- $op {
create/write - create/read -
proc rblocks {var vtrail n op data} {
- upvar #0 $var buf $vtrail trail
+ variable $var
+ variable $vtrail
+ upvar 0 $var buf $vtrail trail
set res {}
# ... and convenience procedures to stack them
proc identity {-attach channel} {
- testchannel transform $channel -command id
+ testchannel transform $channel -command [namespace code id]
}
proc audit_ops {var -attach channel} {
- testchannel transform $channel -command [list id_optrail $var]
+ testchannel transform $channel -command [namespace code [list id_optrail $var]]
}
proc audit_flow {var -attach channel} {
- testchannel transform $channel -command [list id_fulltrail $var]
+ testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
}
proc stopafter {var n -attach channel} {
- upvar #0 $var vn
+ variable $var
+ upvar 0 $var vn
set vn $n
- testchannel transform $channel -command [list counter $var]
+ testchannel transform $channel -command [namespace code [list counter $var]]
}
proc stopafter_audit {var trail n -attach channel} {
- upvar #0 $var vn
+ variable $var
+ upvar 0 $var vn
set vn $n
- testchannel transform $channel -command [list counter_audit $var $trail]
+ testchannel transform $channel -command [namespace code [list counter_audit $var $trail]]
}
proc rblocks_t {var trail n -attach channel} {
- testchannel transform $channel -command [list rblocks $var $trail $n]
+ testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]]
}
# --------------------------------------------------------------
########################################################################
-
-test iogt-1.1 {stack/unstack} {
- set fh [open dummy r]
+test iogt-1.1 {stack/unstack} testchannel {
+ set fh [open $path(dummy) r]
identity -attach $fh
testchannel unstack $fh
close $fh
} {}
-test iogt-1.2 {stack/close} {
- set fh [open dummy r]
+test iogt-1.2 {stack/close} testchannel {
+ set fh [open $path(dummy) r]
identity -attach $fh
close $fh
} {}
-test iogt-1.3 {stack/unstack, configuration, options} {
- set fh [open dummy r]
+test iogt-1.3 {stack/unstack, configuration, options} testchannel {
+ set fh [open $path(dummy) r]
set ca [asort [fconfigure $fh]]
identity -attach $fh
set cb [asort [fconfigure $fh]]
list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc]
} {1 1 1}
-test iogt-1.4 {stack/unstack, configuration} {
- set fh [open dummy r]
+test iogt-1.4 {stack/unstack, configuration} testchannel {
+ set fh [open $path(dummy) r]
set ca [asort [fconfigure $fh]]
identity -attach $fh
fconfigure $fh \
set res
} {0 line cr shiftjis}
-test iogt-2.0 {basic I/O going through transform} {
- set fin [open dummy r]
- set fout [open dummyout w]
+test iogt-2.0 {basic I/O going through transform} testchannel {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
identity -attach $fin
identity -attach $fout
close $fin
close $fout
- set fin [open dummy r]
- set fout [open dummyout r]
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) r]
set res [string equal [set in [read $fin]] [set out [read $fout]]]
lappend res [string length $in] [string length $out]
} {1 71 71}
-test iogt-2.1 {basic I/O, operation trail} {unixOnly} {
- set fin [open dummy r]
- set fout [open dummyout w]
+test iogt-2.1 {basic I/O, operation trail} {testchannel unixOnly} {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
set ain [list] ; set aout [list]
audit_ops ain -attach $fin
read
query/maxRead
flush/read
-query/maxRead
delete/read
--------
create/write
flush/write
delete/write}
-test iogt-2.2 {basic I/O, data trail} {unixOnly} {
- set fin [open dummy r]
- set fout [open dummyout w]
+test iogt-2.2 {basic I/O, data trail} {testchannel unixOnly} {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
set ain [list] ; set aout [list]
audit_flow ain -attach $fin
}
query/maxRead {} -1
flush/read {} {}
-query/maxRead {} -1
delete/read {} *ignored*
--------
create/write {} *ignored*
delete/write {} *ignored*}
-test iogt-2.3 {basic I/O, mixed trail} {unixOnly} {
- set fin [open dummy r]
- set fout [open dummyout w]
+test iogt-2.3 {basic I/O, mixed trail} {testchannel unixOnly} {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
set trail [list]
audit_flow trail -attach $fin
write {
} {
}
-query/maxRead {} -1
delete/read {} *ignored*
flush/write {} {}
delete/write {} *ignored*}
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \
- {unknownFailure} {
+ {testchannel unknownFailure} {
# This test to check the validity of aquired Tcl_Channel references is
# not possible because even a backgrounded fcopy will immediately start
# to copy data, without waiting for the event loop. This is done only in
# delay, causing the fcopy to underflow immediately.
proc DoneCopy {n {err {}}} {
- global copy ; set copy 1
+ variable copy ; set copy 1
}
- set fin [open dummy r]
+ set fin [open $path(dummy) r]
fevent 1000 500 {20 20 20 10 1 1} {
close $fin
# But the 1 second delay should be enough to
# initialize everything else here.
- fcopy $sock $fout -command DoneCopy
+ fcopy $sock $fout -command [namespace code DoneCopy]
# transform after fcopy got its handles !
# They should be still valid for fcopy.
set trail [list]
audit_ops trail -attach $fout
- vwait copy
+ vwait [namespace which -variable copy]
} [read $fin] ; # {}
close $fout
# Check result of copy.
- set fin [open dummy r]
- set fout [open dummyout r]
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) r]
set res [string equal [read $fin] [read $fout]]
} {1 {create/write create/read write flush/write flush/read delete/write delete/read}}
-test iogt-4.0 {fileevent readable, after transform} {unknownFailure} {
- set fin [open dummy r]
+test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} {
+ set fin [open $path(dummy) r]
set data [read $fin]
close $fin
set got [list]
proc Done {args} {
- global stop
+ variable stop
set stop 1
}
proc Get {sock} {
- global trail got
+ variable trail
+ variable got
if {[eof $sock]} {
Done
lappend trail "xxxxxxxxxxxxx"
# But the 1 second delay should be enough to
# initialize everything else here.
- vwait stop
+ vwait [namespace which -variable stop]
} $data
delete/read {} *ignored*} ; # catch unescaped quote "
-test iogt-5.0 {EOF simulation} {unknownFailure} {
- set fin [open dummy r]
- set fout [open dummyout w]
+test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
set trail [list]
}
proc constx {-attach channel} {
- testchannel transform $channel -command constX
+ testchannel transform $channel -command [namespace code constX]
}
-test iogt-6.0 {Push back} {
- set f [open dummy r]
+test iogt-6.0 {Push back} testchannel {
+ set f [open $path(dummy) r]
# contents of dummy = "abcdefghi..."
read $f 3 ; # skip behind "abc"
set res
} {xxx}
-test iogt-6.1 {Push back and up} {knownBug} {
- set f [open dummy r]
+test iogt-6.1 {Push back and up} {testchannel knownBug} {
+ set f [open $path(dummy) r]
# contents of dummy = "abcdefghi..."
read $f 3 ; # skip behind "abc"
# cleanup
foreach file [list dummy dummyout __echo_srv__.tcl] {
- ::tcltest::removeFile $file
+ removeFile $file
+}
+cleanupTests
}
-::tcltest::restoreState
-::tcltest::cleanupTests
+namespace delete ::tcl::test::iogt
return
This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation and other parties. The following terms apply to all files
+associated with the software unless explicitly disclaimed in
+individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace import -force ::tcltest::*
}
-test lindex-1.1 {basic tests} {
- lindex {a b c} 0} a
-test lindex-1.2 {basic tests} {
- lindex {a {b c d} x} 1} {b c d}
-test lindex-1.3 {basic tests} {
- lindex {a b\ c\ d x} 1} {b c d}
-test lindex-1.4 {basic tests} {
- lindex {a b c} 3} {}
-test lindex-1.5 {basic tests} {
- list [catch {lindex {a b c} -1} msg] $msg
-} {0 {}}
-test lindex-1.6 {basic tests} {
- lindex {a b c d} end
-} d
-test lindex-1.7 {basic tests} {
- lindex {a b c d} 100
+set lindex lindex
+set minus -
+
+# Tests of Tcl_LindexObjCmd, NOT COMPILED
+
+test lindex-1.1 {wrong # args} {
+ list [catch {eval $lindex} result] $result
+} "1 {wrong # args: should be \"lindex list ?index...?\"}"
+
+# Indices that are lists or convertible to lists
+
+test lindex-2.1 {empty index list} {
+ set x {}
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {{a b c} {a b c}}
+
+test lindex-2.2 {singleton index list} {
+ set x { 1 }
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {b b}
+
+test lindex-2.3 {multiple indices in list} {
+ set x {1 2}
+ list [eval [list $lindex {{a b c} {d e f}} $x]] \
+ [eval [list $lindex {{a b c} {d e f}} $x]]
+} {f f}
+
+test lindex-2.4 {malformed index list} {
+ set x \{
+ list [catch { eval [list $lindex {a b c} $x] } result] $result
+} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?}
+
+# Indices that are integers or convertible to integers
+
+test lindex-3.1 {integer -1} {
+ set x ${minus}1
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {{} {}}
+
+test lindex-3.2 {integer 0} {
+ set x [string range 00 0 0]
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {a a}
+
+test lindex-3.3 {integer 2} {
+ set x [string range 22 0 0]
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {c c}
+
+test lindex-3.4 {integer 3} {
+ set x [string range 33 0 0]
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {{} {}}
+
+test lindex-3.5 {bad octal} {
+ set x 08
+ list [catch { eval [list $lindex {a b c} $x] } result] $result
+} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}"
+
+test lindex-3.6 {bad octal} {
+ set x -09
+ list [catch { eval [list $lindex {a b c} $x] } result] $result
+} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}"
+
+test lindex-3.7 {indexes don't shimmer wide ints} {
+ set x [expr {(wide(1)<<31) - 2}]
+ list $x [lindex {1 2 3} $x] [incr x] [incr x]
+} {2147483646 {} 2147483647 2147483648}
+
+# Indices relative to end
+
+test lindex-4.1 {index = end} {
+ set x end
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {c c}
+
+test lindex-4.2 {index = end--1} {
+ set x end--1
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {{} {}}
+
+test lindex-4.3 {index = end-0} {
+ set x end-0
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {c c}
+
+test lindex-4.4 {index = end-2} {
+ set x end-2
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {a a}
+
+test lindex-4.5 {index = end-3} {
+ set x end-3
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {{} {}}
+
+test lindex-4.6 {bad octal} {
+ set x end-08
+ list [catch { eval [list $lindex {a b c} $x] } result] $result
+} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}"
+
+test lindex-4.7 {bad octal} {
+ set x end--09
+ list [catch { eval [list $lindex {a b c} $x] } result] $result
+} "1 {bad index \"end--09\": must be integer or end?-integer?}"
+
+test lindex-4.8 {bad integer, not octal} {
+ set x end-0a2
+ list [catch { eval [list $lindex {a b c} $x] } result] $result
+} "1 {bad index \"end-0a2\": must be integer or end?-integer?}"
+
+test lindex-4.9 {incomplete end} {
+ set x en
+ list [eval [list $lindex {a b c} $x]] [eval [list $lindex {a b c} $x]]
+} {c c}
+
+test lindex-4.10 {incomplete end-} {
+ set x end-
+ list [catch { eval [list $lindex {a b c} $x] } result] $result
+} "1 {bad index \"end-\": must be integer or end?-integer?}"
+
+test lindex-5.1 {bad second index} {
+ list [catch { eval [list $lindex {a b c} 0 0a2] } result] $result
+} "1 {bad index \"0a2\": must be integer or end?-integer?}"
+
+test lindex-5.2 {good second index} {
+ eval [list $lindex {{a b c} {d e f} {g h i}} 1 2]
+} f
+
+test lindex-5.3 {three indices} {
+ eval [list $lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1]
+} f
+test lindex-6.1 {error conditions in parsing list} {
+ list [catch {eval [list $lindex "a \{" 2]} msg] $msg
+} {1 {unmatched open brace in list}}
+test lindex-6.2 {error conditions in parsing list} {
+ list [catch {eval [list $lindex {a {b c}d e} 2]} msg] $msg
+} {1 {list element in braces followed by "d" instead of space}}
+test lindex-6.3 {error conditions in parsing list} {
+ list [catch {eval [list $lindex {a "b c"def ghi} 2]} msg] $msg
+} {1 {list element in quotes followed by "def" instead of space}}
+
+test lindex-7.1 {quoted elements} {
+ eval [list $lindex {a "b c" d} 1]
+} {b c}
+test lindex-7.2 {quoted elements} {
+ eval [list $lindex {"{}" b c} 0]
+} {{}}
+test lindex-7.3 {quoted elements} {
+ eval [list $lindex {ab "c d \" x" y} 1]
+} {c d " x}
+test lindex-7.4 {quoted elements} {
+ lindex {a b {c d "e} {f g"}} 2
+} {c d "e}
+
+test lindex-8.1 {data reuse} {
+ set x 0
+ eval [list $lindex $x $x]
+} {0}
+
+test lindex-8.2 {data reuse} {
+ set a 0
+ eval [list $lindex $a $a $a]
+} 0
+test lindex-8.3 {data reuse} {
+ set a 1
+ eval [list $lindex $a $a $a]
} {}
-test lindex-1.8 {basic tests} {
- lindex {a} e
-} a
-test lindex-1.9 {basic tests} {
- lindex {} end
+
+test lindex-8.4 {data reuse} {
+ set x [list 0 0]
+ eval [list $lindex $x $x]
+} {0}
+
+test lindex-8.5 {data reuse} {
+ set x 0
+ eval [list $lindex $x [list $x $x]]
+} {0}
+
+test lindex-8.6 {data reuse} {
+ set x [list 1 1]
+ eval [list $lindex $x $x]
} {}
-test lindex-1.10 {basic tests} {
- lindex {a b c d} 3
-} d
-
-test lindex-2.1 {error conditions} {
- list [catch {lindex msg} msg] $msg
-} {1 {wrong # args: should be "lindex list index"}}
-test lindex-2.2 {error conditions} {
- list [catch {lindex 1 2 3 4} msg] $msg
-} {1 {wrong # args: should be "lindex list index"}}
-test lindex-2.3 {error conditions} {
- list [catch {lindex 1 2a2} msg] $msg
-} {1 {bad index "2a2": must be integer or end?-integer?}}
-test lindex-2.4 {error conditions} {
- list [catch {lindex "a \{" 2} msg] $msg
+
+test lindex-8.7 {data reuse} {
+ set x 1
+ eval [list lindex $x [list $x $x]]
+} {}
+
+#----------------------------------------------------------------------
+
+# Compilation tests for lindex
+
+test lindex-9.1 {wrong # args} {
+ list [catch {lindex} result] $result
+} "1 {wrong # args: should be \"lindex list ?index...?\"}"
+
+# Indices that are lists or convertible to lists
+
+test lindex-10.1 {empty index list} {
+ set x {}
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {{a b c} {a b c}}
+
+test lindex-10.2 {singleton index list} {
+ set x { 1 }
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {b b}
+
+test lindex-10.3 {multiple indices in list} {
+ set x {1 2}
+ catch {
+ list [lindex {{a b c} {d e f}} $x] [lindex {{a b c} {d e f}} $x]
+ } result
+ set result
+} {f f}
+
+test lindex-10.4 {malformed index list} {
+ set x \{
+ list [catch { lindex {a b c} $x } result] $result
+} {1 bad\ index\ \"\{\":\ must\ be\ integer\ or\ end?-integer?}
+
+# Indices that are integers or convertible to integers
+
+test lindex-11.1 {integer -1} {
+ set x ${minus}1
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {{} {}}
+
+test lindex-11.2 {integer 0} {
+ set x [string range 00 0 0]
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {a a}
+
+test lindex-11.3 {integer 2} {
+ set x [string range 22 0 0]
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {c c}
+
+test lindex-11.4 {integer 3} {
+ set x [string range 33 0 0]
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {{} {}}
+
+test lindex-11.5 {bad octal} {
+ set x 08
+ list [catch { lindex {a b c} $x } result] $result
+} "1 {bad index \"08\": must be integer or end?-integer? (looks like invalid octal number)}"
+
+test lindex-11.6 {bad octal} {
+ set x -09
+ list [catch { lindex {a b c} $x } result] $result
+} "1 {bad index \"-09\": must be integer or end?-integer? (looks like invalid octal number)}"
+
+# Indices relative to end
+
+test lindex-12.1 {index = end} {
+ set x end
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {c c}
+
+test lindex-12.2 {index = end--1} {
+ set x end--1
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {{} {}}
+
+test lindex-12.3 {index = end-0} {
+ set x end-0
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {c c}
+
+test lindex-12.4 {index = end-2} {
+ set x end-2
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {a a}
+
+test lindex-12.5 {index = end-3} {
+ set x end-3
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {{} {}}
+
+test lindex-12.6 {bad octal} {
+ set x end-08
+ list [catch { lindex {a b c} $x } result] $result
+} "1 {bad index \"end-08\": must be integer or end?-integer? (looks like invalid octal number)}"
+
+test lindex-12.7 {bad octal} {
+ set x end--09
+ list [catch { lindex {a b c} $x } result] $result
+} "1 {bad index \"end--09\": must be integer or end?-integer?}"
+
+test lindex-12.8 {bad integer, not octal} {
+ set x end-0a2
+ list [catch { lindex {a b c} $x } result] $result
+} "1 {bad index \"end-0a2\": must be integer or end?-integer?}"
+
+test lindex-12.9 {incomplete end} {
+ set x en
+ catch {
+ list [lindex {a b c} $x] [lindex {a b c} $x]
+ } result
+ set result
+} {c c}
+
+test lindex-12.10 {incomplete end-} {
+ set x end-
+ list [catch { lindex {a b c} $x } result] $result
+} "1 {bad index \"end-\": must be integer or end?-integer?}"
+
+test lindex-13.1 {bad second index} {
+ list [catch { lindex {a b c} 0 0a2 } result] $result
+} "1 {bad index \"0a2\": must be integer or end?-integer?}"
+
+test lindex-13.2 {good second index} {
+ catch {
+ lindex {{a b c} {d e f} {g h i}} 1 2
+ } result
+ set result
+} f
+
+test lindex-13.3 {three indices} {
+ catch {
+ lindex {{{a b} {c d}} {{e f} {g h}}} 1 0 1
+ } result
+ set result
+} f
+
+test lindex-14.1 {error conditions in parsing list} {
+ list [catch { lindex "a \{" 2 } msg] $msg
} {1 {unmatched open brace in list}}
-test lindex-2.5 {error conditions} {
- list [catch {lindex {a {b c}d e} 2} msg] $msg
+test lindex-14.2 {error conditions in parsing list} {
+ list [catch { lindex {a {b c}d e} 2 } msg] $msg
} {1 {list element in braces followed by "d" instead of space}}
-test lindex-2.6 {error conditions} {
- list [catch {lindex {a "b c"def ghi} 2} msg] $msg
+test lindex-14.3 {error conditions in parsing list} {
+ list [catch { lindex {a "b c"def ghi} 2 } msg] $msg
} {1 {list element in quotes followed by "def" instead of space}}
-test lindex-3.1 {quoted elements} {
- lindex {a "b c" d} 1
+test lindex-15.1 {quoted elements} {
+ catch {
+ lindex {a "b c" d} 1
+ } result
+ set result
} {b c}
-test lindex-3.2 {quoted elements} {
- lindex {"{}" b c} 0
+test lindex-15.2 {quoted elements} {
+ catch {
+ lindex {"{}" b c} 0
+ } result
+ set result
} {{}}
-test lindex-3.3 {quoted elements} {
- lindex {ab "c d \" x" y} 1
+test lindex-15.3 {quoted elements} {
+ catch {
+ lindex {ab "c d \" x" y} 1
+ } result
+ set result
} {c d " x}
-test lindex-3.4 {quoted elements} {
- lindex {a b {c d "e} {f g"}} 2
+test lindex-15.4 {quoted elements} {
+ catch {
+ lindex {a b {c d "e} {f g"}} 2
+ } result
+ set result
} {c d "e}
+test lindex-16.1 {data reuse} {
+ set x 0
+ catch {
+ lindex $x $x
+ } result
+ set result
+} {0}
+
+test lindex-16.2 {data reuse} {
+ set a 0
+ catch {
+ lindex $a $a $a
+ } result
+ set result
+} 0
+test lindex-16.3 {data reuse} {
+ set a 1
+ catch {
+ lindex $a $a $a
+ } result
+ set result
+} {}
+
+test lindex-16.4 {data reuse} {
+ set x [list 0 0]
+ catch {
+ lindex $x $x
+ } result
+ set result
+} {0}
+
+test lindex-16.5 {data reuse} {
+ set x 0
+ catch {
+ lindex $x [list $x $x]
+ } result
+ set result
+} {0}
+
+test lindex-16.6 {data reuse} {
+ set x [list 1 1]
+ catch {
+ lindex $x $x
+ } result
+ set result
+} {}
+
+test lindex-16.7 {data reuse} {
+ set x 1
+ catch {
+ lindex $x [list $x $x]
+ } result
+ set result
+} {}
+
+catch { unset lindex}
+catch { unset minus }
+
# cleanup
::tcltest::cleanupTests
return
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
-if {[info commands testlink] == {}} {
- puts "This application hasn't been compiled with the \"testlink\""
- puts "command, so I can't test Tcl_LinkVar et al."
- ::tcltest::cleanupTests
- return
-}
+::tcltest::testConstraint testlink \
+ [expr {[info commands testlink] != {}}]
foreach i {int real bool string} {
catch {unset $i}
}
-test link-1.1 {reading C variables from Tcl} {
+test link-1.1 {reading C variables from Tcl} {testlink} {
testlink delete
- testlink set 43 1.23 4 -
- testlink create 1 1 1 1
- list $int $real $bool $string
-} {43 1.23 1 NULL}
-test link-1.2 {reading C variables from Tcl} {
+ testlink set 43 1.23 4 - 12341234
+ testlink create 1 1 1 1 1
+ list $int $real $bool $string $wide
+} {43 1.23 1 NULL 12341234}
+test link-1.2 {reading C variables from Tcl} {testlink} {
testlink delete
- testlink create 1 1 1 1
- testlink set -3 2 0 "A long string with spaces"
- list $int $real $bool $string $int $real $bool $string
-} {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}}
+ testlink create 1 1 1 1 1
+ testlink set -3 2 0 "A long string with spaces" 43214321
+ list $int $real $bool $string $wide $int $real $bool $string $wide
+} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321}
-test link-2.1 {writing C variables from Tcl} {
+test link-2.1 {writing C variables from Tcl} {testlink} {
testlink delete
- testlink set 43 1.21 4 -
- testlink create 1 1 1 1
+ testlink set 43 1.21 4 - 56785678
+ testlink create 1 1 1 1 1
set int "00721"
set real -10.5
set bool true
set string abcdef
- concat [testlink get] $int $real $bool $string
-} {465 -10.5 1 abcdef 00721 -10.5 true abcdef}
-test link-2.2 {writing bad values into variables} {
+ set wide 135135
+ concat [testlink get] $int $real $bool $string $wide
+} {465 -10.5 1 abcdef 135135 00721 -10.5 true abcdef 135135}
+test link-2.2 {writing bad values into variables} {testlink} {
testlink delete
- testlink set 43 1.23 4 -
- testlink create 1 1 1 1
+ testlink set 43 1.23 4 - 56785678
+ testlink create 1 1 1 1 1
list [catch {set int 09a} msg] $msg $int
} {1 {can't set "int": variable must have integer value} 43}
-test link-2.3 {writing bad values into variables} {
+test link-2.3 {writing bad values into variables} {testlink} {
testlink delete
- testlink set 43 1.23 4 -
- testlink create 1 1 1 1
+ testlink set 43 1.23 4 - 56785678
+ testlink create 1 1 1 1 1
list [catch {set real 1.x3} msg] $msg $real
} {1 {can't set "real": variable must have real value} 1.23}
-test link-2.4 {writing bad values into variables} {
+test link-2.4 {writing bad values into variables} {testlink} {
testlink delete
- testlink set 43 1.23 4 -
- testlink create 1 1 1 1
+ testlink set 43 1.23 4 - 56785678
+ testlink create 1 1 1 1 1
list [catch {set bool gorp} msg] $msg $bool
} {1 {can't set "bool": variable must have boolean value} 1}
+test link-2.5 {writing bad values into variables} {testlink} {
+ testlink delete
+ testlink set 43 1.23 4 - 56785678
+ testlink create 1 1 1 1 1
+ list [catch {set wide gorp} msg] $msg $bool
+} {1 {can't set "wide": variable must have integer value} 1}
-test link-3.1 {read-only variables} {
+test link-3.1 {read-only variables} {testlink} {
testlink delete
- testlink set 43 1.23 4 -
- testlink create 0 1 1 0
+ testlink set 43 1.23 4 - 56785678
+ testlink create 0 1 1 0 0
list [catch {set int 4} msg] $msg $int \
[catch {set real 10.6} msg] $msg $real \
[catch {set bool no} msg] $msg $bool \
- [catch {set string "new value"} msg] $msg $string
-} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL}
-test link-3.2 {read-only variables} {
+ [catch {set string "new value"} msg] $msg $string \
+ [catch {set wide 12341234} msg] $msg $wide
+} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678}
+test link-3.2 {read-only variables} {testlink} {
testlink delete
- testlink set 43 1.23 4 -
- testlink create 1 0 0 1
+ testlink set 43 1.23 4 - 56785678
+ testlink create 1 0 0 1 1
list [catch {set int 4} msg] $msg $int \
[catch {set real 10.6} msg] $msg $real \
[catch {set bool no} msg] $msg $bool \
- [catch {set string "new value"} msg] $msg $string
-} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}}
+ [catch {set string "new value"} msg] $msg $string\
+ [catch {set wide 12341234} msg] $msg $wide
+} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234}
-test link-4.1 {unsetting linked variables} {
+test link-4.1 {unsetting linked variables} {testlink} {
testlink delete
- testlink set -6 -2.5 0 stringValue
- testlink create 1 1 1 1
- unset int real bool string
+ testlink set -6 -2.5 0 stringValue 13579
+ testlink create 1 1 1 1 1
+ unset int real bool string wide
list [catch {set int} msg] $msg [catch {set real} msg] $msg \
- [catch {set bool} msg] $msg [catch {set string} msg] $msg
-} {0 -6 0 -2.5 0 0 0 stringValue}
-test link-4.2 {unsetting linked variables} {
+ [catch {set bool} msg] $msg [catch {set string} msg] $msg \
+ [catch {set wide} msg] $msg
+} {0 -6 0 -2.5 0 0 0 stringValue 0 13579}
+test link-4.2 {unsetting linked variables} {testlink} {
testlink delete
- testlink set -6 -2.1 0 stringValue
- testlink create 1 1 1 1
- unset int real bool string
+ testlink set -6 -2.1 0 stringValue 97531
+ testlink create 1 1 1 1 1
+ unset int real bool string wide
set int 102
set real 16
set bool true
set string newValue
+ set wide 333555
testlink get
-} {102 16.0 1 newValue}
+} {102 16.0 1 newValue 333555}
-test link-5.1 {unlinking variables} {
+test link-5.1 {unlinking variables} {testlink} {
testlink delete
- testlink set -6 -2.25 0 stringValue
+ testlink set -6 -2.25 0 stringValue 13579
testlink delete
set int xx1
set real qrst
set bool bogus
set string 12345
+ set wide 875421
testlink get
-} {-6 -2.25 0 stringValue}
-test link-5.2 {unlinking variables} {
+} {-6 -2.25 0 stringValue 13579}
+test link-5.2 {unlinking variables} {testlink} {
testlink delete
- testlink set -6 -2.25 0 stringValue
- testlink create 1 1 1 1
+ testlink set -6 -2.25 0 stringValue 97531
+ testlink create 1 1 1 1 1
testlink delete
- testlink set 25 14.7 7 -
- list $int $real $bool $string
-} {-6 -2.25 0 stringValue}
+ testlink set 25 14.7 7 - 999999
+ list $int $real $bool $string $wide
+} {-6 -2.25 0 stringValue 97531}
-test link-6.1 {errors in setting up link} {
+test link-6.1 {errors in setting up link} {testlink} {
testlink delete
catch {unset int}
set int(44) 1
- list [catch {testlink create 1 1 1 1} msg] $msg
+ list [catch {testlink create 1 1 1 1 1} msg] $msg
} {1 {can't set "int": variable is array}}
catch {unset int}
-test link-7.1 {access to linked variables via upvar} {
+test link-7.1 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
unset y
}
testlink delete
- testlink create 1 0 0 0
- testlink set 14 {} {} {}
+ testlink create 1 0 0 0 0
+ testlink set 14 {} {} {} {}
x
list [catch {set int} msg] $msg
} {0 14}
-test link-7.2 {access to linked variables via upvar} {
+test link-7.2 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
return [set y]
}
testlink delete
- testlink create 1 0 0 0
- testlink set 0 {} {} {}
+ testlink create 1 0 0 0 0
+ testlink set 0 {} {} {} {}
set int
- testlink set 23 {} {} {}
+ testlink set 23 {} {} {} {}
x
list [x] $int
} {23 23}
-test link-7.3 {access to linked variables via upvar} {
+test link-7.3 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
set y 44
}
testlink delete
- testlink create 0 0 0 0
- testlink set 11 {} {} {}
+ testlink create 0 0 0 0 0
+ testlink set 11 {} {} {} {}
list [catch x msg] $msg $int
} {1 {can't set "y": linked variable is read-only} 11}
-test link-7.4 {access to linked variables via upvar} {
+test link-7.4 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar int y
set y abc
}
testlink delete
- testlink create 1 1 1 1
- testlink set -4 {} {} {}
+ testlink create 1 1 1 1 1
+ testlink set -4 {} {} {} {}
list [catch x msg] $msg $int
} {1 {can't set "y": variable must have integer value} -4}
-test link-7.5 {access to linked variables via upvar} {
+test link-7.5 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar real y
set y abc
}
testlink delete
- testlink create 1 1 1 1
- testlink set -4 16.75 {} {}
+ testlink create 1 1 1 1 1
+ testlink set -4 16.75 {} {} {}
list [catch x msg] $msg $real
} {1 {can't set "y": variable must have real value} 16.75}
-test link-7.6 {access to linked variables via upvar} {
+test link-7.6 {access to linked variables via upvar} {testlink} {
proc x {} {
upvar bool y
set y abc
}
testlink delete
- testlink create 1 1 1 1
- testlink set -4 16.3 1 {}
+ testlink create 1 1 1 1 1
+ testlink set -4 16.3 1 {} {}
list [catch x msg] $msg $bool
} {1 {can't set "y": variable must have boolean value} 1}
+test link-7.7 {access to linked variables via upvar} {testlink} {
+ proc x {} {
+ upvar wide y
+ set y abc
+ }
+ testlink delete
+ testlink create 1 1 1 1 1
+ testlink set -4 16.3 1 {} 778899
+ list [catch x msg] $msg $wide
+} {1 {can't set "y": variable must have integer value} 778899}
-test link-8.1 {Tcl_UpdateLinkedVar procedure} {
+test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
- global x int real bool string
- lappend x $args $int $real $bool $string
+ global x int real bool string wide
+ lappend x $args $int $real $bool $string $wide
}
set x {}
- testlink create 1 1 1 1
- testlink set 14 -2.0 0 xyzzy
+ testlink create 1 1 1 1 1
+ testlink set 14 -2.0 0 xyzzy 995511
trace var int w x
- testlink update 32 4.0 3 abcd
+ testlink update 32 4.0 3 abcd 113355
trace vdelete int w x
set x
-} {{int {} w} 32 -2.0 0 xyzzy}
-test link-8.2 {Tcl_UpdateLinkedVar procedure} {
+} {{int {} w} 32 -2.0 0 xyzzy 995511}
+test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} {
proc x args {
- global x int real bool string
- lappend x $args $int $real $bool $string
+ global x int real bool string wide
+ lappend x $args $int $real $bool $string $wide
}
set x {}
- testlink create 1 1 1 1
- testlink set 14 -2.0 0 xyzzy
+ testlink create 1 1 1 1 1
+ testlink set 14 -2.0 0 xyzzy 995511
testlink delete
trace var int w x
- testlink update 32 4.0 6 abcd
+ testlink update 32 4.0 6 abcd 113355
trace vdelete int w x
set x
} {}
-test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {
- testlink create 0 0 0 0
- list [catch {testlink update 47 {} {} {}} msg] $msg $int
+test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
+ testlink create 0 0 0 0 0
+ list [catch {testlink update 47 {} {} {} {}} msg] $msg $int
} {0 {} 47}
-testlink set 0 0 0 -
-testlink delete
-foreach i {int real bool string} {
+catch {testlink set 0 0 0 - 0}
+catch {testlink delete}
+foreach i {int real bool string wide} {
catch {unset $i}
}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
catch {rename p ""}
::tcltest::cleanupTests
return
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkga$ext]
set dll "[file tail $x]Required"
-set ::tcltest::testConstraints($dll) [file readable $x]
+::tcltest::testConstraint $dll [file readable $x]
# Tests also require that this DLL has not already been loaded.
set loaded "[file tail $x]Loaded"
set alreadyLoaded [info loaded]
-set ::tcltest::testConstraints($loaded) \
+::tcltest::testConstraint $loaded \
[expr {![string match *pkga* $alreadyLoaded]}]
set alreadyTotalLoaded [info loaded]
} {0 {}}
test load-4.2 {reloading package into same interpreter} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
-} "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}"
+} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
test load-5.1 {file name not specified and no static package: pick default} \
[list $dll $loaded] {
set result [info loaded x]
interp delete x
set result
-} "{[file join $testDir pkga$ext] Pkga}"
+} [list [list [file join $testDir pkga$ext] Pkga]]
# On some platforms, like SunOS 4.1.3, these tests can't be run because
# they cause the process to exit.
teststaticpkg Double 0 1
teststaticpkg Double 0 1
info loaded
- } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
+ } [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
test load-8.1 {TclGetLoadedPackages procedure} [list $dll $loaded] {
info loaded
- } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
+ } [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
test load-8.2 {TclGetLoadedPackages procedure} [list $dll $loaded] {
list [catch {info loaded gorp} msg] $msg
} {1 {could not find interpreter "gorp"}}
test load-8.3 {TclGetLoadedPackages procedure} [list $dll $loaded] {
list [info loaded {}] [info loaded child]
- } "{{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}"
+ } [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded] {
load [file join $testDir pkgb$ext] pkgb
list [info loaded {}] [lsort [info commands pkgb_*]]
- } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}"
+ } [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}]
interp delete child
}
-
# cleanup
::tcltest::cleanupTests
return
-
catch {unset foo}
::tcltest::cleanupTests
return
-
} 1
test lsearch-2.10 {search modes} {
list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg
-} {1 {bad search mode "-glib": must be -exact, -glob, or -regexp}}
+} {1 {bad option "-glib": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}}
test lsearch-3.1 {lsearch errors} {
list [catch lsearch msg] $msg
-} {1 {wrong # args: should be "lsearch ?mode? list pattern"}}
+} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.2 {lsearch errors} {
list [catch {lsearch a} msg] $msg
-} {1 {wrong # args: should be "lsearch ?mode? list pattern"}}
+} {1 {wrong # args: should be "lsearch ?options? list pattern"}}
test lsearch-3.3 {lsearch errors} {
list [catch {lsearch a b c} msg] $msg
-} {1 {bad search mode "a": must be -exact, -glob, or -regexp}}
+} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}}
test lsearch-3.4 {lsearch errors} {
list [catch {lsearch a b c d} msg] $msg
-} {1 {wrong # args: should be "lsearch ?mode? list pattern"}}
+} {1 {bad option "a": must be -all, -ascii, -decreasing, -dictionary, -exact, -glob, -increasing, -inline, -integer, -not, -real, -regexp, -sorted, or -start}}
test lsearch-3.5 {lsearch errors} {
list [catch {lsearch "\{" b} msg] $msg
} {1 {unmatched open brace in list}}
lsearch -exact [list foo one\000two bar] $x
} 1
-# cleanup
-::tcltest::cleanupTests
-return
+# Make a sorted list
+set l {}
+set l2 {}
+for {set i 0} {$i < 100} {incr i} {
+ lappend l $i
+ lappend l2 [expr {double($i)/2}]
+}
+set increasingIntegers [lsort -integer $l]
+set decreasingIntegers [lsort -decreasing -integer $l]
+set increasingDoubles [lsort -real $l2]
+set decreasingDoubles [lsort -decreasing -real $l2]
+set increasingStrings [lsort {48 6a 18b 22a 21aa 35 36}]
+set decreasingStrings [lsort -decreasing {48 6a 18b 22a 21aa 35 36}]
+set increasingDictionary [lsort -dictionary {48 6a 18b 22a 21aa 35 36}]
+set decreasingDictionary [lsort -dictionary -decreasing $increasingDictionary]
+set l {}
+for {set i 0} {$i < 10} {incr i} {
+ lappend l $i $i $i $i $i
+}
+set repeatingIncreasingIntegers [lsort -integer $l]
+set repeatingDecreasingIntegers [lsort -integer -decreasing $l]
+test lsearch-5.1 {binary search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -integer -sorted $increasingIntegers $i]
+ }
+ set res
+} $increasingIntegers
+test lsearch-5.2 {binary search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -integer -decreasing -sorted \
+ $decreasingIntegers $i]
+ }
+ set res
+} $decreasingIntegers
+test lsearch-5.3 {binary search finds leftmost occurances} {
+ set res {}
+ for {set i 0} {$i < 10} {incr i} {
+ lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i]
+ }
+ set res
+} [list 0 5 10 15 20 25 30 35 40 45]
+test lsearch-5.4 {binary search -decreasing finds leftmost occurances} {
+ set res {}
+ for {set i 9} {$i >= 0} {incr i -1} {
+ lappend res [lsearch -sorted -integer -decreasing \
+ $repeatingDecreasingIntegers $i]
+ }
+ set res
+} [list 0 5 10 15 20 25 30 35 40 45]
+test lsearch-6.1 {integer search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -exact -integer $increasingIntegers $i]
+ }
+ set res
+} [lrange $increasingIntegers 0 99]
+test lsearch-6.2 {decreasing integer search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -exact -integer -decreasing \
+ $decreasingIntegers $i]
+ }
+ set res
+} [lrange $decreasingIntegers 0 99]
+test lsearch-6.3 {sorted integer search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -sorted -integer $increasingIntegers $i]
+ }
+ set res
+} [lrange $increasingIntegers 0 99]
+test lsearch-6.4 {sorted decreasing integer search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -integer -sorted -decreasing \
+ $decreasingIntegers $i]
+ }
+ set res
+} [lrange $decreasingIntegers 0 99]
+test lsearch-7.1 {double search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -exact -real $increasingDoubles \
+ [expr {double($i)/2}]]
+ }
+ set res
+} [lrange $increasingIntegers 0 99]
+test lsearch-7.2 {decreasing double search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -exact -real -decreasing \
+ $decreasingDoubles [expr {double($i)/2}]]
+ }
+ set res
+} [lrange $decreasingIntegers 0 99]
+test lsearch-7.3 {sorted double search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -sorted -real \
+ $increasingDoubles [expr {double($i)/2}]]
+ }
+ set res
+} [lrange $increasingIntegers 0 99]
+test lsearch-7.4 {sorted decreasing double search} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -sorted -real -decreasing \
+ $decreasingDoubles [expr {double($i)/2}]]
+ }
+ set res
+} [lrange $decreasingIntegers 0 99]
+test lsearch-8.1 {dictionary search} {
+ set res {}
+ foreach val {6a 18b 21aa 22a 35 36 48} {
+ lappend res [lsearch -exact -dictionary $increasingDictionary $val]
+ }
+ set res
+} [list 0 1 2 3 4 5 6]
+test lsearch-8.2 {decreasing dictionary search} {
+ set res {}
+ foreach val {6a 18b 21aa 22a 35 36 48} {
+ lappend res [lsearch -exact -dictionary $decreasingDictionary $val]
+ }
+ set res
+} [list 6 5 4 3 2 1 0]
+test lsearch-8.3 {sorted dictionary search} {
+ set res {}
+ foreach val {6a 18b 21aa 22a 35 36 48} {
+ lappend res [lsearch -sorted -dictionary $increasingDictionary $val]
+ }
+ set res
+} [list 0 1 2 3 4 5 6]
+test lsearch-8.4 {decreasing sorted dictionary search} {
+ set res {}
+ foreach val {6a 18b 21aa 22a 35 36 48} {
+ lappend res [lsearch -decreasing -sorted -dictionary \
+ $decreasingDictionary $val]
+ }
+ set res
+} [list 6 5 4 3 2 1 0]
+test lsearch-9.1 {ascii search} {
+ set res {}
+ foreach val {18b 21aa 22a 35 36 48 6a} {
+ lappend res [lsearch -exact -ascii $increasingStrings $val]
+ }
+ set res
+} [list 0 1 2 3 4 5 6]
+test lsearch-9.2 {decreasing ascii search} {
+ set res {}
+ foreach val {18b 21aa 22a 35 36 48 6a} {
+ lappend res [lsearch -exact -ascii $decreasingStrings $val]
+ }
+ set res
+} [list 6 5 4 3 2 1 0]
+test lsearch-9.3 {sorted ascii search} {
+ set res {}
+ foreach val {18b 21aa 22a 35 36 48 6a} {
+ lappend res [lsearch -sorted -ascii $increasingStrings $val]
+ }
+ set res
+} [list 0 1 2 3 4 5 6]
+test lsearch-9.4 {decreasing sorted ascii search} {
+ set res {}
+ foreach val {18b 21aa 22a 35 36 48 6a} {
+ lappend res [lsearch -decreasing -sorted -ascii \
+ $decreasingStrings $val]
+ }
+ set res
+} [list 6 5 4 3 2 1 0]
+test lsearch-10.1 {offset searching} {
+ lsearch -start 2 {a b c a b c} a
+} 3
+test lsearch-10.2 {offset searching} {
+ lsearch -start 2 {a b c d e f} a
+} -1
+test lsearch-10.3 {offset searching} {
+ lsearch -start end-4 {a b c a b c} a
+} 3
+test lsearch-10.4 {offset searching} {
+ list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg
+} {1 {bad index "foobar": must be integer or end?-integer?}}
+test lsearch-10.5 {offset searching} {
+ list [catch {lsearch -start 1 2} msg] $msg
+} {1 {missing starting index}}
+test lsearch-10.6 {binary search with offset} {
+ set res {}
+ for {set i 0} {$i < 100} {incr i} {
+ lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i]
+ }
+ set res
+} [concat -1 -1 [lrange $increasingIntegers 2 end]]
+test lsearch-11.1 {negated searches} {
+ lsearch -not {a a a b a a a} a
+} 3
+test lsearch-11.2 {negated searches} {
+ lsearch -not {a a a a a a a} a
+} -1
+test lsearch-12.1 {return values instead of indices} {
+ lsearch -glob -inline {a1 b2 c3 d4} c*
+} c3
+test lsearch-12.2 {return values instead of indices} {
+ lsearch -glob -inline {a1 b2 c3 d4} e*
+} {}
+test lsearch-13.1 {search for all matches} {
+ lsearch -all {a b a c a d} 1
+} {}
+test lsearch-13.2 {search for all matches} {
+ lsearch -all {a b a c a d} a
+} {0 2 4}
+test lsearch-13.1 {combinations: -all and -inline} {
+ lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
+} {a1 a3 a5}
+test lsearch-13.2 {combinations: -all, -inline and -not} {
+ lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
+} {b2 c4 d6}
+test lsearch-13.3 {combinations: -all and -not} {
+ lsearch -all -not -glob {a1 b2 a3 c4 a5 d6} a*
+} {1 3 5}
+test lsearch-13.4 {combinations: -inline and -not} {
+ lsearch -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
+} {b2}
+test lsearch-13.5 {combinations: -start, -all and -inline} {
+ lsearch -start 2 -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
+} {a3 a5}
+test lsearch-13.6 {combinations: -start, -all, -inline and -not} {
+ lsearch -start 2 -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
+} {c4 d6}
+test lsearch-13.7 {combinations: -start, -all and -not} {
+ lsearch -start 2 -all -not -glob {a1 b2 a3 c4 a5 d6} a*
+} {3 5}
+test lsearch-13.8 {combinations: -start, -inline and -not} {
+ lsearch -start 2 -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
+} {c4}
+test lsearch-14.1 {make sure no shimmering occurs} {
+ set x [expr int(sin(0))]
+ lsearch -start $x $x $x
+} 0
+# cleanup
+catch {unset res}
+catch {unset increasingIntegers}
+catch {unset decreasingIntegers}
+catch {unset increasingDoubles}
+catch {unset decreasingDoubles}
+catch {unset increasingStrings}
+catch {unset decreasingStrings}
+catch {unset increasingDictionary}
+catch {unset decreasingDictionary}
+::tcltest::cleanupTests
+return
namespace import -force ::tcltest::*
}
+# These tests really need to be run from a writable directory, which
+# it is assumed [temporaryDirectory] is.
+set oldcwd [pwd]
+cd [temporaryDirectory]
+
catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
test macFCmd-1.1 {GetFileFinderAttributes - no file} {macOnly} {
catch {file delete -force foo.file}
list [catch {file attributes foo.file -creator} msg] $msg
-} {1 {could not read ":foo.file": no such file or directory}}
+} {1 {could not read "foo.file": no such file or directory}}
test macFCmd-1.2 {GetFileFinderAttributes - creator} {macOnly} {
catch {file delete -force foo.file}
catch {close [open foo.file w]}
- list [catch {file attributes foo.file -creator} msg] $msg \
- [file delete -force foo.file]
-} {0 {MPW } {}}
+ list [catch {file attributes foo.file -creator} msg] \
+ [regexp {MPW |CWIE} $msg] [file delete -force foo.file]
+} {0 1 {}}
test macFCmd-1.3 {GetFileFinderAttributes - type} {macOnly} {
catch {file delete -force foo.file}
catch {close [open foo.file w]}
test macFCmd-2.1 {GetFileReadOnly - bad file} {macOnly} {
catch {file delete -force foo.file}
list [catch {file attributes foo.file -readonly} msg] $msg
-} {1 {could not read ":foo.file": no such file or directory}}
+} {1 {could not read "foo.file": no such file or directory}}
test macFCmd-2.2 {GetFileReadOnly - file not read only} {macOnly} {
catch {file delete -force foo.file}
close [open foo.file w]
test macFCmd-3.1 {SetFileFinderAttributes - bad file} {macOnly} {
catch {file delete -force foo.file}
list [catch {file attributes foo.file -creator FOOO} msg] $msg
-} {1 {could not read ":foo.file": no such file or directory}}
+} {1 {could not read "foo.file": no such file or directory}}
test macFCmd-3.2 {SetFileFinderAttributes - creator} {macOnly} {
catch {file delete -force foo.file}
close [open foo.file w]
file mkdir foo.dir
list [catch {file attributes foo.dir -creator FOOO} msg] \
$msg [file delete -force foo.dir]
-} {1 {cannot set -creator: ":foo.dir" is a directory} {}}
+} {1 {cannot set -creator: "foo.dir" is a directory} {}}
test macFCmd-4.1 {SetFileReadOnly - bad file} {macOnly} {
catch {file delete -force foo.file}
list [catch {file attributes foo.file -readonly 1} msg] $msg
-} {1 {could not read ":foo.file": no such file or directory}}
+} {1 {could not read "foo.file": no such file or directory}}
test macFCmd-4.2 {SetFileReadOnly - file not readonly} {macOnly} {
catch {file delete -force foo.file}
close [open foo.file w]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
# cleanup
+cd $oldcwd
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-# Commands covered: ::msgcat::mc ::msgcat::mclocale
-# ::msgcat::mcpreferences ::msgcat::mcload
-# ::msgcat::mcset ::msgcat::mcunknown
-#
-# This file contains a collection of tests for the msgcat script library.
+# This file contains a collection of tests for the msgcat package.
# Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1998 Mark Harrison.
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
+# Note that after running these tests, entries will be left behind in the
+# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
+#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
+package require Tcl 8.2
+if {[catch {package require tcltest 2}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2 required."
+ return
}
+if {[catch {package require msgcat 1.3}]} {
+ puts stderr "Skipping tests in [info script]. No msgcat 1.3 found to test."
+ return
+}
+
+namespace eval ::msgcat::test {
+ namespace import ::msgcat::*
+ namespace import ::tcltest::test
+ namespace import ::tcltest::cleanupTests
+ namespace import ::tcltest::temporaryDirectory
+ namespace import ::tcltest::make*
+ namespace import ::tcltest::remove*
-if {[catch {package require msgcat 1.0}]} {
- if {[info exist msgcat1]} {
- catch {puts "Cannot load msgcat 1.0 package"}
- return
- } else {
- catch {puts "Running msgcat 1.0 tests in slave interp"}
- set interp [interp create msgcat1]
- $interp eval [list set msgcat1 "running"]
- $interp eval [list source [info script]]
- interp delete $interp
- return
+ # Tests msgcat-0.*: locale initialization
+
+ proc PowerSet {l} {
+ if {[llength $l] == 0} {return [list [list]]}
+ set element [lindex $l 0]
+ set rest [lrange $l 1 end]
+ set result [list]
+ foreach x [PowerSet $rest] {
+ lappend result [linsert $x 0 $element]
+ lappend result $x
+ }
+ return $result
}
-}
-set oldlocale [::msgcat::mclocale]
+ variable envVars {LC_ALL LC_MESSAGES LANG}
+ variable count 0
+ variable body
+ variable result
+ variable setVars
+ foreach setVars [PowerSet $envVars] {
+ set result [string tolower [lindex $setVars 0]]
+ if {[string length $result] == 0} {
+ set result c
+ }
+ test msgcat-0.$count {
+ locale initialization from environment variables
+ } -setup {
+ variable var
+ foreach var $envVars {
+ catch {variable $var $::env($var)}
+ catch {unset ::env($var)}
+ }
+ foreach var $setVars {
+ set ::env($var) $var
+ }
+ interp create [namespace current]::i
+ i eval [list package ifneeded msgcat [package provide msgcat] \
+ [package ifneeded msgcat [package provide msgcat]]]
+ i eval package require msgcat
+ } -cleanup {
+ interp delete [namespace current]::i
+ foreach var $envVars {
+ catch {unset ::env($var)}
+ catch {set ::env($var) [set [namespace current]::$var]}
+ }
+ } -body {i eval msgcat::mclocale} -result $result
+ incr count
+ }
+ catch {unset result}
+
+ # Could add tests of initialization from Windows registry here.
+ # Use a fake registry package.
-# some tests fail in tne environment variable LANG exists and is not C
+ # Tests msgcat-1.*: [mclocale], [mcpreferences]
-if {[info exists env(LANG)] && ($env(LANG) != "C")} {
- set ::tcltest::testConstraints(LANGisC) 0
-} else {
- set ::tcltest::testConstraints(LANGisC) 1
-}
+ test msgcat-1.3 {mclocale set, single element} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale en
+ } -result en
-#
-# Test the various permutations of mclocale
-# and mcpreferences.
-#
+ test msgcat-1.4 {mclocale get, single element} -setup {
+ variable locale [mclocale]
+ mclocale en
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale
+ } -result en
-test msgcat-1.1 {::msgcat::mclocale default} {LANGisC} {
- ::msgcat::mclocale
-} {c}
-test msgcat-1.2 {::msgcat::mcpreferences, single element} {LANGisC} {
- ::msgcat::mcpreferences
-} {c}
-test msgcat-1.3 {::msgcat::mclocale, single element} {
- ::msgcat::mclocale en
-} {en}
-test msgcat-1.4 {::msgcat::mclocale, single element} {
- ::msgcat::mclocale
-} {en}
-test msgcat-1.5 {::msgcat::mcpreferences, single element} {
- ::msgcat::mcpreferences
-} {en}
-test msgcat-1.6 {::msgcat::mclocale, two elements} {
- ::msgcat::mclocale en_US
-} {en_us}
-test msgcat-1.7 {::msgcat::mclocale, two elements} {
- ::msgcat::mclocale en_US
- ::msgcat::mclocale
-} {en_us}
-test msgcat-1.8 {::msgcat::mcpreferences, two elements} {
- ::msgcat::mcpreferences
-} {en_us en}
-test msgcat-1.9 {::msgcat::mclocale, three elements} {
- ::msgcat::mclocale en_US_funky
-} {en_us_funky}
-test msgcat-1.10 {::msgcat::mclocale, three elements} {
- ::msgcat::mclocale
-} {en_us_funky}
-test msgcat-1.11 {::msgcat::mcpreferences, three elements} {
- ::msgcat::mcpreferences
-} {en_us_funky en_us en}
+ test msgcat-1.5 {mcpreferences, single element} -setup {
+ variable locale [mclocale]
+ mclocale en
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result en
-#
-# Test mcset and mcc, ensuring that namespace partitioning
-# is working.
-#
+ test msgcat-1.6 {mclocale set, two elements} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale en_US
+ } -result en_us
-test msgcat-2.1 {::msgcat::mcset, global scope} {
- ::msgcat::mcset foo_BAR text1 text2
-} {text2}
-test msgcat-2.2 {::msgcat::mcset, global scope, default} {
- ::msgcat::mcset foo_BAR text3
-} {text3}
-test msgcat-2.2 {::msgcat::mcset, namespace overlap} {
- namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
- namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
-} {con1baz}
-test msgcat-2.3 {::msgcat::mcset, namespace overlap} {
- ::msgcat::mclocale foo_BAR
- namespace eval bar {::msgcat::mc con1}
-} {con1bar}
-test msgcat-2.4 {::msgcat::mcset, namespace overlap} {
- ::msgcat::mclocale foo_BAR
- namespace eval baz {::msgcat::mc con1}
-} {con1baz}
+ test msgcat-1.7 {mclocale get, two elements} -setup {
+ variable locale [mclocale]
+ mclocale en_US
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale
+ } -result en_us
-#
-# Test mcset and mc, ensuring that more specific locales
-# (e.g. "en_UK") will search less specific locales
-# (e.g. "en") for translation strings.
-#
-# Do this for the 12 permutations of
-# locales: {foo foo_BAR foo_BAR_baz}
-# strings: {ov1 ov2 ov3 ov4}
-# locale foo defines ov1, ov2, ov3
-# locale foo_BAR defines ov2, ov3
-# locale foo_BAR_BAZ defines ov3
-# (ov4 is defined in none)
-# So,
-# ov3 should be resolved in foo, foo_BAR, foo_BAR_baz
-# ov2 should be resolved in foo, foo_BAR
-# ov2 should resolve to foo_BAR in foo_BAR_baz
-# ov1 should be resolved in foo
-# ov1 should resolve to foo in foo_BAR, foo_BAR_baz
-# ov4 should be resolved in none, and call mcunknown
-#
+ test msgcat-1.8 {mcpreferences, two elements} -setup {
+ variable locale [mclocale]
+ mclocale en_US
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {en_us en}
-test msgcat-3.1 {::msgcat::mcset, overlap} {
- ::msgcat::mcset foo ov1 ov1_foo
- ::msgcat::mcset foo ov2 ov2_foo
- ::msgcat::mcset foo ov3 ov3_foo
- ::msgcat::mcset foo_BAR ov2 ov2_foo_BAR
- ::msgcat::mcset foo_BAR ov3 ov3_foo_BAR
- ::msgcat::mcset foo_BAR_baz ov3 ov3_foo_BAR_baz
-} {ov3_foo_BAR_baz}
-# top level, locale foo
-test msgcat-3.2 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo
- ::msgcat::mc ov1
-} {ov1_foo}
-test msgcat-3.3 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo
- ::msgcat::mc ov2
-} {ov2_foo}
-test msgcat-3.4 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo
- ::msgcat::mc ov3
-} {ov3_foo}
-test msgcat-3.5 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo
- ::msgcat::mc ov4
-} {ov4}
-# second level, locale foo_BAR
-test msgcat-3.6 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR
- ::msgcat::mc ov1
-} {ov1_foo}
-test msgcat-3.7 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR
- ::msgcat::mc ov2
-} {ov2_foo_BAR}
-test msgcat-3.8 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR
- ::msgcat::mc ov3
-} {ov3_foo_BAR}
-test msgcat-3.9 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR
- ::msgcat::mc ov4
-} {ov4}
-# third level, locale foo_BAR_baz
-test msgcat-3.10 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR_baz
- ::msgcat::mc ov1
-} {ov1_foo}
-test msgcat-3.11 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR_baz
- ::msgcat::mc ov2
-} {ov2_foo_BAR}
-test msgcat-3.12 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR_baz
- ::msgcat::mc ov3
-} {ov3_foo_BAR_baz}
-test msgcat-3.13 {::msgcat::mcset, overlap} {
- ::msgcat::mclocale foo_BAR_baz
- ::msgcat::mc ov4
-} {ov4}
+ test msgcat-1.9 {mclocale set, three elements} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale en_US_funky
+ } -result en_us_funky
-#
-# Test mcunknown, first the default operation
-# and then with an overridden definition.
-#
+ test msgcat-1.10 {mclocale get, three elements} -setup {
+ variable locale [mclocale]
+ mclocale en_US_funky
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mclocale
+ } -result en_us_funky
+
+ test msgcat-1.11 {mcpreferences, three elements} -setup {
+ variable locale [mclocale]
+ mclocale en_US_funky
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {en_us_funky en_us en}
+
+ # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
+
+ test msgcat-2.1 {mcset, global scope} {
+ namespace eval :: ::msgcat::mcset foo_BAR text1 text2
+ } {text2}
+
+ test msgcat-2.2 {mcset, global scope, default} {
+ namespace eval :: ::msgcat::mcset foo_BAR text3
+ } {text3}
+
+ test msgcat-2.2 {mcset, namespace overlap} {
+ namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
+ } {con1baz}
+
+ test msgcat-2.3 {mcset, namespace overlap} -setup {
+ namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
+ namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ namespace eval bar {::msgcat::mc con1}
+ } -result con1bar
+
+ test msgcat-2.4 {mcset, namespace overlap} -setup {
+ namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
+ namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ namespace eval baz {::msgcat::mc con1}
+ } -result con1baz
-test msgcat-4.1 {::msgcat::mcunknown, default} {
- ::msgcat::mcset foo unk1 "unknown 1"
-} {unknown 1}
-test msgcat-4.2 {::msgcat::mcunknown, default} {
- ::msgcat::mclocale foo
- ::msgcat::mc unk1
-} {unknown 1}
-test msgcat-4.3 {::msgcat::mcunknown, default} {
- ::msgcat::mclocale foo
- ::msgcat::mc unk2
-} {unk2}
-test msgcat-4.4 {::msgcat::mcunknown, overridden} {
- rename ::msgcat::mcunknown oldproc
- proc ::msgcat::mcunknown {dom s} {
- return "unknown:$dom:$s"
+ test msgcat-2.5 {mcmset, global scope} -setup {
+ namespace eval :: {
+ ::msgcat::mcmset foo_BAR {
+ src1 trans1
+ src2 trans2
+ }
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ namespace eval :: {
+ ::msgcat::mc src1
+ }
+ } -result trans1
+
+ test msgcat-2.6 {mcmset, namespace overlap} -setup {
+ namespace eval bar {::msgcat::mcmset foo_BAR {con2 con2bar}}
+ namespace eval baz {::msgcat::mcmset foo_BAR {con2 con2baz}}
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ namespace eval bar {::msgcat::mc con2}
+ } -result con2bar
+
+ test msgcat-2.7 {mcmset, namespace overlap} -setup {
+ namespace eval bar {::msgcat::mcmset foo_BAR {con2 con2bar}}
+ namespace eval baz {::msgcat::mcmset foo_BAR {con2 con2baz}}
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ namespace eval baz {::msgcat::mc con2}
+ } -result con2baz
+
+ # Tests msgcat-3.*: [mcset], [mc], catalog "inheritance"
+ #
+ # Test mcset and mc, ensuring that more specific locales
+ # (e.g. en_UK) will search less specific locales
+ # (e.g. en) for translation strings.
+ #
+ # Do this for the 12 permutations of
+ # locales: {foo foo_BAR foo_BAR_baz}
+ # strings: {ov1 ov2 ov3 ov4}
+ # locale foo defines ov1, ov2, ov3
+ # locale foo_BAR defines ov2, ov3
+ # locale foo_BAR_BAZ defines ov3
+ # (ov4 is defined in none)
+ # So,
+ # ov3 should be resolved in foo, foo_BAR, foo_BAR_baz
+ # ov2 should be resolved in foo, foo_BAR
+ # ov2 should resolve to foo_BAR in foo_BAR_baz
+ # ov1 should be resolved in foo
+ # ov1 should resolve to foo in foo_BAR, foo_BAR_baz
+ # ov4 should be resolved in none, and call mcunknown
+ #
+ variable count 2
+ variable result
+ array set result {
+ foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4
+ foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR foo_BAR,ov3 ov3_foo_BAR
+ foo_BAR,ov4 ov4 foo_BAR_baz,ov1 ov1_foo foo_BAR_baz,ov2 ov2_foo_BAR
+ foo_BAR_baz,ov3 ov3_foo_BAR_baz foo_BAR_baz,ov4 ov4
}
- ::msgcat::mclocale foo
- set result [::msgcat::mc unk1]
- rename ::msgcat::mcunknown {}
- rename oldproc ::msgcat::mcunknown
- set result
-} {unknown 1}
-test msgcat-4.5 {::msgcat::mcunknown, overridden} {
- rename ::msgcat::mcunknown oldproc
- proc ::msgcat::mcunknown {dom s} {
- return "unknown:$dom:$s"
+ variable loc
+ variable string
+ foreach loc {foo foo_BAR foo_BAR_baz} {
+ foreach string {ov1 ov2 ov3 ov4} {
+ test msgcat-3.$count {mcset, overlap} -setup {
+ mcset foo ov1 ov1_foo
+ mcset foo ov2 ov2_foo
+ mcset foo ov3 ov3_foo
+ mcset foo_BAR ov2 ov2_foo_BAR
+ mcset foo_BAR ov3 ov3_foo_BAR
+ mcset foo_BAR_baz ov3 ov3_foo_BAR_baz
+ variable locale [mclocale]
+ mclocale $loc
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc $string
+ } -result $result($loc,$string)
+ incr count
+ }
}
- ::msgcat::mclocale foo
- set result [::msgcat::mc unk2]
- rename ::msgcat::mcunknown {}
- rename oldproc ::msgcat::mcunknown
- set result
-} {unknown:foo:unk2}
-test msgcat-4.6 {::msgcat::mcunknown, uplevel context} {
- rename ::msgcat::mcunknown oldproc
- proc ::msgcat::mcunknown {dom s} {
- return "unknown:$dom:$s:[info level]"
+ catch {unset result}
+
+ # Tests msgcat-4.*: [mcunknown]
+
+ test msgcat-4.2 {mcunknown, default} -setup {
+ mcset foo unk1 "unknown 1"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc unk1
+ } -result {unknown 1}
+
+ test msgcat-4.3 {mcunknown, default} -setup {
+ mcset foo unk1 "unknown 1"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc unk2
+ } -result unk2
+
+ test msgcat-4.4 {mcunknown, overridden} -setup {
+ rename ::msgcat::mcunknown SavedMcunknown
+ proc ::msgcat::mcunknown {dom s} {
+ return unknown:$dom:$s
+ }
+ mcset foo unk1 "unknown 1"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ rename ::msgcat::mcunknown {}
+ rename SavedMcunknown ::msgcat::mcunknown
+ } -body {
+ mc unk1
+ } -result {unknown 1}
+
+ test msgcat-4.5 {mcunknown, overridden} -setup {
+ rename ::msgcat::mcunknown SavedMcunknown
+ proc ::msgcat::mcunknown {dom s} {
+ return unknown:$dom:$s
+ }
+ mcset foo unk1 "unknown 1"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ rename ::msgcat::mcunknown {}
+ rename SavedMcunknown ::msgcat::mcunknown
+ } -body {
+ mc unk2
+ } -result {unknown:foo:unk2}
+
+ test msgcat-4.6 {mcunknown, uplevel context} -setup {
+ rename ::msgcat::mcunknown SavedMcunknown
+ proc ::msgcat::mcunknown {dom s} {
+ return "unknown:$dom:$s:[expr {[info level] - 1}]"
+ }
+ mcset foo unk1 "unknown 1"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ rename ::msgcat::mcunknown {}
+ rename SavedMcunknown ::msgcat::mcunknown
+ } -body {
+ mc unk2
+ } -result unknown:foo:unk2:[info level]
+
+ # Tests msgcat-5.*: [mcload]
+
+ variable locales {foo foo_BAR foo_BAR_baz}
+ makeDirectory msgdir
+ foreach loc $locales {
+ makeFile "::msgcat::mcset $loc abc abc-$loc" \
+ [string tolower [file join msgdir $loc.msg]]
+ }
+ variable count 1
+ foreach loc {foo foo_BAR foo_BAR_baz} {
+ test msgcat-5.$count {mcload} -setup {
+ variable locale [mclocale]
+ mclocale $loc
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcload [file join [temporaryDirectory] msgdir]
+ } -result $count
+ incr count
}
- ::msgcat::mclocale foo
- set result [::msgcat::mc unk2]
- rename ::msgcat::mcunknown {}
- rename oldproc ::msgcat::mcunknown
- set result
-} {unknown:foo:unk2:1}
-
-#
-# Test mcload. Need to set up an environment for
-# these tests by creating a temporary directory and
-# message files.
-#
+ # Even though foo_BAR_notexist does not exist,
+ # foo_BAR and foo should be loaded.
+ test msgcat-5.4 {mcload} -setup {
+ variable locale [mclocale]
+ mclocale foo_BAR_notexist
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcload [file join [temporaryDirectory] msgdir]
+ } -result 2
-set locales {en en_US en_US_funky}
+ test msgcat-5.5 {mcload} -setup {
+ variable locale [mclocale]
+ mclocale no_FI_notexist
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcload [file join [temporaryDirectory] msgdir]
+ } -result 0
-catch {file mkdir msgdir}
-foreach l $locales {
- set fd [open [string tolower [file join msgdir $l.msg]] w]
- puts $fd "::msgcat::mcset $l abc abc-$l"
- close $fd
-}
+ test msgcat-5.6 {mcload} -setup {
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc abc
+ } -result abc-foo
+
+ test msgcat-5.7 {mcload} -setup {
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc abc
+ } -result abc-foo_BAR
+
+ test msgcat-5.8 {mcload} -setup {
+ variable locale [mclocale]
+ mclocale foo_BAR_baz
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc abc
+ } -result abc-foo_BAR_baz
+
+ test msgcat-5.9 {mcload} -setup {
+ rename ::msgcat::mcunknown SavedMcunknown
+ proc ::msgcat::mcunknown {dom s} {
+ return unknown:$dom:$s
+ }
+ variable locale [mclocale]
+ mclocale no_FI_notexist
+ } -cleanup {
+ mclocale $locale
+ rename ::msgcat::mcunknown {}
+ rename SavedMcunknown ::msgcat::mcunknown
+ } -body {
+ mc abc
+ } -result unknown:no_fi_notexist:abc
-test msgcat-5.1 {::msgcat::mcload} {
- ::msgcat::mclocale en
- ::msgcat::mcload msgdir
-} {1}
-test msgcat-5.2 {::msgcat::mcload} {
- ::msgcat::mclocale en_US
- ::msgcat::mcload msgdir
-} {2}
-test msgcat-5.3 {::msgcat::mcload} {
- ::msgcat::mclocale en_US_funky
- ::msgcat::mcload msgdir
-} {3}
-
-# Even though en_US_notexist does not exist,
-# en_US and en should be loaded.
-
-test msgcat-5.4 {::msgcat::mcload} {
- ::msgcat::mclocale en_US_notexist
- ::msgcat::mcload msgdir
-} {2}
-test msgcat-5.5 {::msgcat::mcload} {
- ::msgcat::mclocale no_FI_notexist
- ::msgcat::mcload msgdir
-} {0}
-test msgcat-5.6 {::msgcat::mcload} {
- ::msgcat::mclocale en
- ::msgcat::mc abc
-} {abc-en}
-test msgcat-5.7 {::msgcat::mcload} {
- ::msgcat::mclocale en_US
- ::msgcat::mc abc
-} {abc-en_US}
-test msgcat-5.8 {::msgcat::mcload} {
- ::msgcat::mclocale en_US_funky
- ::msgcat::mc abc
-} {abc-en_US_funky}
-test msgcat-5.9 {::msgcat::mcload} {
- rename ::msgcat::mcunknown oldproc
- proc ::msgcat::mcunknown {dom s} {
- return "unknown:$dom:$s"
+
+ foreach loc $locales {
+ removeFile [string tolower [file join msgdir $loc.msg]]
}
- ::msgcat::mclocale no_FI_notexist
- set result [::msgcat::mc abc]
- rename ::msgcat::mcunknown {}
- rename oldproc ::msgcat::mcunknown
- set result
-} {unknown:no_fi_notexist:abc}
-
-# cleanup temp files
-foreach l $locales {
- file delete [string tolower [file join msgdir $l.msg]]
-}
-# Clean out the msg catalogs
-file delete msgdir
+ removeDirectory msgdir
+ # Tests msgcat-6.*: [mcset], [mc] namespace inheritance
#
# Test mcset and mc, ensuring that resolution for messages
# proceeds from the current ns to its parent and so on to the
#
# Do this for the 12 permutations of
# locales: foo
-# namespaces: ::foo ::foo::bar ::foo::bar::baz
+# namespaces: foo foo::bar foo::bar::baz
# strings: {ov1 ov2 ov3 ov4}
# namespace ::foo defines ov1, ov2, ov3
# namespace ::foo::bar defines ov2, ov3
# ov4 should be resolved in none, and call mcunknown
#
-namespace eval ::foo {
- ::msgcat::mcset foo ov1 "ov1_foo"
- ::msgcat::mcset foo ov2 "ov2_foo"
- ::msgcat::mcset foo ov3 "ov3_foo"
+ variable result
+ array set result {
+ foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4
+ foo::bar,ov1 ov1_foo foo::bar,ov2 ov2_foo_bar
+ foo::bar,ov3 ov3_foo_bar foo::bar,ov4 ov4 foo::bar::baz,ov1 ov1_foo
+ foo::bar::baz,ov2 ov2_foo_bar foo::bar::baz,ov3 ov3_foo_bar_baz
+ foo::bar::baz,ov4 ov4
+ }
+ variable count 1
+ variable ns
+ foreach ns {foo foo::bar foo::bar::baz} {
+ foreach string {ov1 ov2 ov3 ov4} {
+ test msgcat-6.$count {mcset, overlap} -setup {
+ namespace eval foo {
+ ::msgcat::mcset foo ov1 ov1_foo
+ ::msgcat::mcset foo ov2 ov2_foo
+ ::msgcat::mcset foo ov3 ov3_foo
+ namespace eval bar {
+ ::msgcat::mcset foo ov2 ov2_foo_bar
+ ::msgcat::mcset foo ov3 ov3_foo_bar
+ namespace eval baz {
+ ::msgcat::mcset foo ov3 "ov3_foo_bar_baz"
+ }
+ }
+
+ }
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ namespace delete foo
+ } -body {
+ namespace eval $ns [list ::msgcat::mc $string]
+ } -result $result($ns,$string)
+ incr count
+ }
+ }
+
+ # Tests msgcat-7.*: [mc] extra args processed by [format]
+
+ test msgcat-7.1 {mc extra args go through to format} -setup {
+ mcset foo format1 "this is a test"
+ mcset foo format2 "this is a %s"
+ mcset foo format3 "this is a %s %s"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc format1 "good test"
+ } -result "this is a test"
+
+ test msgcat-7.2 {mc extra args go through to format} -setup {
+ mcset foo format1 "this is a test"
+ mcset foo format2 "this is a %s"
+ mcset foo format3 "this is a %s %s"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc format2 "good test"
+ } -result "this is a good test"
+
+ test msgcat-7.3 {mc errors from format are propagated} -setup {
+ mcset foo format1 "this is a test"
+ mcset foo format2 "this is a %s"
+ mcset foo format3 "this is a %s %s"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ catch {mc format3 "good test"}
+ } -result 1
+
+ test msgcat-7.4 {mc, extra args are given to unknown} -setup {
+ mcset foo format1 "this is a test"
+ mcset foo format2 "this is a %s"
+ mcset foo format3 "this is a %s %s"
+ variable locale [mclocale]
+ mclocale foo
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mc "this is a %s" "good test"
+ } -result "this is a good test"
+
+ cleanupTests
}
-namespace eval ::foo::bar {
- ::msgcat::mcset foo ov2 "ov2_foo_bar"
- ::msgcat::mcset foo ov3 "ov3_foo_bar"
-}
-namespace eval ::foo::bar::baz {
- ::msgcat::mcset foo ov3 "ov3_foo_bar_baz"
-}
-::msgcat::mclocale foo
-
-# namespace ::foo
-test msgcat-6.1 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo {::msgcat::mc ov1}
-} {ov1_foo}
-test msgcat-6.2 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo {::msgcat::mc ov2}
-} {ov2_foo}
-test msgcat-6.3 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo {::msgcat::mc ov3}
-} {ov3_foo}
-test msgcat-6.4 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo {::msgcat::mc ov4}
-} {ov4}
-# namespace ::foo::bar
-test msgcat-6.5 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar {::msgcat::mc ov1}
-} {ov1_foo}
-test msgcat-6.6 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar {::msgcat::mc ov2}
-} {ov2_foo_bar}
-test msgcat-6.7 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar {::msgcat::mc ov3}
-} {ov3_foo_bar}
-test msgcat-6.8 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar {::msgcat::mc ov4}
-} {ov4}
-# namespace ::foo
-test msgcat-6.9 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar::baz {::msgcat::mc ov1}
-} {ov1_foo}
-test msgcat-6.10 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar::baz {::msgcat::mc ov2}
-} {ov2_foo_bar}
-test msgcat-6.11 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar::baz {::msgcat::mc ov3}
-} {ov3_foo_bar_baz}
-test msgcat-6.12 {::msgcat::mc, namespace resolution} {
- namespace eval ::foo::bar::baz {::msgcat::mc ov4}
-} {ov4}
-
-namespace delete ::foo::bar::baz ::foo::bar ::foo
-
-::msgcat::mclocale foo
-::msgcat::mcset foo format1 "this is a test"
-::msgcat::mcset foo format2 "this is a %s"
-::msgcat::mcset foo format3 "this is a %s %s"
-
-test msgcat-7.1 {::msgcat::mc, extra args go through to format} {
- ::msgcat::mc format1 "good test"
-} "this is a test"
-test msgcat-7.2 {::msgcat::mc, extra args go through to format} {
- ::msgcat::mc format2 "good test"
-} "this is a good test"
-test msgcat-7.3 {::msgcat::mc, errors from format are propagated} {
- catch {::msgcat::mc format3 "good test"}
-} 1
-test msgcat-7.4 {::msgcat::mc, extra args are given to unknown} {
- ::msgcat::mc "this is a %s" "good test"
-} "this is a good test"
-
-# Reset the locale
-::msgcat::mclocale $oldlocale
-
-::tcltest::cleanupTests
+namespace delete ::msgcat::test
return
namespace eval test_ns_inscope {
namespace code {"1 2 3" "4 5" 6}
}
-} {namespace inscope ::test_ns_inscope {"1 2 3" "4 5" 6}}
+} {::namespace inscope ::test_ns_inscope {"1 2 3" "4 5" 6}}
test namespace-old-10.5 {with one arg, first "scope" sticks} {
set sval [namespace eval test_ns_inscope {namespace code {one two}}]
namespace code $sval
-} {namespace inscope ::test_ns_inscope {one two}}
+} {::namespace inscope ::test_ns_inscope {one two}}
test namespace-old-10.6 {with many args, each "scope" adds new args} {
set sval [namespace eval test_ns_inscope {namespace code {one two}}]
namespace code "$sval three"
-} {namespace inscope ::test_ns_inscope {one two} three}
+} {::namespace inscope ::test_ns_inscope {one two} three}
test namespace-old-10.7 {scoped commands work with eval} {
set cref [namespace eval test_ns_inscope {namespace code show}]
-
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
list [catch {namespace wombat {}} msg] $msg
-} {1 {bad option "wombat": must be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "wombat": must be children, code, current, delete, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
} {namespace inscope ::test_ns_1 cmd}
test namespace-22.4 {NamespaceCodeCmd, in :: namespace} {
namespace code unknown
-} {namespace inscope :: unknown}
+} {::namespace inscope :: unknown}
test namespace-22.5 {NamespaceCodeCmd, in other namespace} {
namespace eval test_ns_1 {
namespace code cmd
}
-} {namespace inscope ::test_ns_1 cmd}
+} {::namespace inscope ::test_ns_1 cmd}
+test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
+ namespace eval test_ns_1 {
+ variable v 42
+ }
+ namespace eval test_ns_2 {
+ proc namespace args {}
+ }
+ namespace eval test_ns_2 [namespace eval test_ns_1 {
+ namespace code {set v}
+ }]
+} {42}
test namespace-23.1 {NamespaceCurrentCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
list [catch {namespace test_ns_1} msg] $msg
-} {1 {bad option "test_ns_1": must be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "test_ns_1": must be children, code, current, delete, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
[namespace eval {} {namespace current}]
} {:: ::}
+test namespace-39.1 {NamespaceExistsCmd} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval ::test_ns_z::test_me { variable foo }
+ list [namespace exists ::] \
+ [namespace exists ::bogus_namespace] \
+ [namespace exists ::test_ns_z] \
+ [namespace exists test_ns_z] \
+ [namespace exists ::test_ns_z::foo] \
+ [namespace exists ::test_ns_z::test_me] \
+ [namespace eval ::test_ns_z { namespace exists ::test_me }] \
+ [namespace eval ::test_ns_z { namespace exists test_me }] \
+ [namespace exists :::::test_ns_z]
+} {1 0 1 1 0 1 0 1 1}
+test namespace-39.2 {NamespaceExistsCmd error} {
+ list [catch {namespace exists} msg] $msg
+} {1 {wrong # args: should be "namespace exists name"}}
+test namespace-39.3 {NamespaceExistsCmd error} {
+ list [catch {namespace exists a b} msg] $msg
+} {1 {wrong # args: should be "namespace exists name"}}
+
+test namespace-40.1 {Ignoring namespace proc "unknown"} {
+ rename unknown _unknown
+ proc unknown args {return global}
+ namespace eval ns {proc unknown args {return local}}
+ set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]]
+ rename unknown {}
+ rename _unknown unknown
+ namespace delete ns
+ set l
+} {global global}
+
+test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} {
+ set res {}
+ namespace eval ns {
+ set res {}
+ proc test {} {
+ set ::g 0
+ }
+ lappend ::res [test]
+ proc set {a b} {
+ ::set a [incr b]
+ }
+ lappend ::res [test]
+ }
+ namespace delete ns
+ set res
+} {0 1}
+
+test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} {
+ set res {}
+ namespace eval ns {}
+ proc ns::a {i} {
+ variable b
+ proc set args {return "New proc is called"}
+ return [set b $i]
+ }
+ ns::a 1
+ set res [ns::a 2]
+ namespace delete ns
+ set res
+} {New proc is called}
+
+test namespace-41.3 {Shadowing byte-compiled commands, Bug: 231259} {knownBug} {
+ set res {}
+ namespace eval ns {
+ variable b 0
+ }
+
+ proc ns::a {i} {
+ variable b
+ proc set args {return "New proc is called"}
+ return [set b $i]
+ }
+
+ set res [list [ns::a 1] $ns::b]
+ namespace delete ns
+ set res
+} {{New proc is called} 0}
+
# cleanup
catch {rename cmd1 {}}
catch {unset l}
-
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
set r 1
- foreach {t} {list boolean cmdName bytecode string int double} {
+ foreach {t} {
+ {array search}
+ boolean
+ bytearray
+ bytecode
+ double
+ end-offset
+ index
+ int
+ list
+ nsName
+ procbody
+ string
+ } {
set first [string first $t [testobj types]]
set r [expr {$r && ($first != -1)}]
}
lappend result [catch {testbooleanobj not 1} msg]
lappend result $msg
} {{} 1 {expected boolean value but got ""}}
+test obj-11.5 {Tcl_GetBooleanFromObj, convert hex to boolean} {
+ set result ""
+ lappend result [teststringobj set 1 0xac]
+ lappend result [testbooleanobj not 1]
+ lappend result [testobj type 1]
+} {0xac 0 boolean}
+test obj-11.6 {Tcl_GetBooleanFromObj, convert float to boolean} {
+ set result ""
+ lappend result [teststringobj set 1 5.42]
+ lappend result [testbooleanobj not 1]
+ lappend result [testobj type 1]
+} {5.42 0 boolean}
test obj-12.1 {DupBooleanInternalRep} {
set result ""
lappend result [testobj refcount 2]
} {{} 1024 1024 int 4 4 0 boolean 3 2}
+
+test obj-31.1 {regenerate string rep of "end"} {
+ testobj freeallvars
+ teststringobj set 1 end
+ testobj convert 1 end-offset
+ testobj invalidateStringRep 1
+} end
+
+test obj-31.2 {regenerate string rep of "end-1"} {
+ testobj freeallvars
+ teststringobj set 1 end-0x1
+ testobj convert 1 end-offset
+ testobj invalidateStringRep 1
+} end-1
+
+test obj-31.3 {regenerate string rep of "end--1"} {
+ testobj freeallvars
+ teststringobj set 1 end--0x1
+ testobj convert 1 end-offset
+ testobj invalidateStringRep 1
+} end--1
+
+test obj-31.4 {regenerate string rep of "end-bigInteger"} {
+ testobj freeallvars
+ teststringobj set 1 end-0x7fffffff
+ testobj convert 1 end-offset
+ testobj invalidateStringRep 1
+} end-2147483647
+
+test obj-31.5 {regenerate string rep of "end--bigInteger"} {
+ testobj freeallvars
+ teststringobj set 1 end--0x7fffffff
+ testobj convert 1 end-offset
+ testobj invalidateStringRep 1
+} end--2147483647
+
+
+test obj-31.6 {regenerate string rep of "end--bigInteger"} {nonPortable} {
+ testobj freeallvars
+ teststringobj set 1 end--0x80000000
+ testobj convert 1 end-offset
+ testobj invalidateStringRep 1
+} end--2147483648
+
testobj freeallvars
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
::tcltest::cleanupTests
return
-
subst {[eval {return foo}]bar}
} foobar
+test parse-17.1 {Correct return codes from errors during substitution} {
+ catch {eval {w[continue]}}
+} 4
+
# cleanup
catch {unset a}
::tcltest::cleanupTests
-
return
}
+# Some tests only work if wide integers (>32bit) are not found to be
+# integers at all.
+set ::tcltest::testConstraints(wideIntegerUnparsed) \
+ [expr {-1 == 0xffffffff}]
+
test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {
testexprparser [bytestring "1+2\0 +3"] -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} {
testexprparser "1 + 2" -1
} {- {} 0 subexpr {1 + 2} 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {nonPortable} {
+test parseExpr-1.3 {Tcl_ParseExpr procedure, error getting initial lexeme} {wideIntegerUnparsed} {
list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-1.4 {Tcl_ParseExpr procedure, error in conditional expression} {
list [catch {testexprparser {foo+} -1} msg] $msg
-} {1 {syntax error in expression "foo+"}}
+} {1 {syntax error in expression "foo+": variable references require preceding $}}
test parseExpr-1.5 {Tcl_ParseExpr procedure, lexemes after the expression} {
list [catch {testexprparser {1+2 345} -1} msg] $msg
-} {1 {syntax error in expression "1+2 345"}}
+} {1 {syntax error in expression "1+2 345": extra tokens at end of expression}}
test parseExpr-2.1 {ParseCondExpr procedure, valid test subexpr} {
testexprparser {2>3? 1 : 0} -1
} {- {} 0 subexpr {2>3? 1 : 0} 11 operator ? 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-2.2 {ParseCondExpr procedure, error in test subexpr} {
list [catch {testexprparser {0 || foo} -1} msg] $msg
-} {1 {syntax error in expression "0 || foo"}}
+} {1 {syntax error in expression "0 || foo": variable references require preceding $}}
test parseExpr-2.3 {ParseCondExpr procedure, next lexeme isn't "?"} {
testexprparser {1+2} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
test parseExpr-2.4 {ParseCondExpr procedure, next lexeme is "?"} {
testexprparser {1+2 ? 3 : 4} -1
} {- {} 0 subexpr {1+2 ? 3 : 4} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {nonPortable} {
+test parseExpr-2.5 {ParseCondExpr procedure, bad lexeme after "?"} {wideIntegerUnparsed} {
list [catch {testexprparser {1+2 ? 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-2.6 {ParseCondExpr procedure, valid "then" subexpression} {
} {- {} 0 subexpr {1? 3 : 4} 7 operator ? 0 subexpr 1 1 text 1 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-2.7 {ParseCondExpr procedure, error in "then" subexpression} {
list [catch {testexprparser {1? fred : martha} -1} msg] $msg
-} {1 {syntax error in expression "1? fred : martha"}}
+} {1 {syntax error in expression "1? fred : martha": variable references require preceding $}}
test parseExpr-2.8 {ParseCondExpr procedure, lexeme after "then" subexpr isn't ":"} {
list [catch {testexprparser {1? 2 martha 3} -1} msg] $msg
-} {1 {syntax error in expression "1? 2 martha 3"}}
+} {1 {syntax error in expression "1? 2 martha 3": missing colon from ternary conditional}}
test parseExpr-2.9 {ParseCondExpr procedure, valid "else" subexpression} {
testexprparser {27||3? 3 : 4&&9} -1
} {- {} 0 subexpr {27||3? 3 : 4&&9} 15 operator ? 0 subexpr 27||3 5 operator || 0 subexpr 27 1 text 27 0 subexpr 3 1 text 3 0 subexpr 3 1 text 3 0 subexpr 4&&9 5 operator && 0 subexpr 4 1 text 4 0 subexpr 9 1 text 9 0 {}}
test parseExpr-2.10 {ParseCondExpr procedure, error in "else" subexpression} {
list [catch {testexprparser {1? 2 : martha} -1} msg] $msg
-} {1 {syntax error in expression "1? 2 : martha"}}
+} {1 {syntax error in expression "1? 2 : martha": variable references require preceding $}}
test parseExpr-3.1 {ParseLorExpr procedure, valid logical and subexpr} {
testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-3.2 {ParseLorExpr procedure, error in logical and subexpr} {
list [catch {testexprparser {1&&foo || 3} -1} msg] $msg
-} {1 {syntax error in expression "1&&foo || 3"}}
+} {1 {syntax error in expression "1&&foo || 3": variable references require preceding $}}
test parseExpr-3.3 {ParseLorExpr procedure, next lexeme isn't "||"} {
testexprparser {1&&2? 1 : 0} -1
} {- {} 0 subexpr {1&&2? 1 : 0} 11 operator ? 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-3.4 {ParseLorExpr procedure, next lexeme is "||"} {
testexprparser {1&&2 || 3} -1
} {- {} 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {nonPortable} {
+test parseExpr-3.5 {ParseLorExpr procedure, bad lexeme after "||"} {wideIntegerUnparsed} {
list [catch {testexprparser {1&&2 || 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-3.6 {ParseLorExpr procedure, valid RHS subexpression} {
} {- {} 0 subexpr {1&&2 || 3 || 4} 13 operator || 0 subexpr {1&&2 || 3} 9 operator || 0 subexpr 1&&2 5 operator && 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-3.7 {ParseLorExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1&&2 || 3 || martha} -1} msg] $msg
-} {1 {syntax error in expression "1&&2 || 3 || martha"}}
+} {1 {syntax error in expression "1&&2 || 3 || martha": variable references require preceding $}}
test parseExpr-4.1 {ParseLandExpr procedure, valid LHS "|" subexpr} {
testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-4.2 {ParseLandExpr procedure, error in LHS "|" subexpr} {
list [catch {testexprparser {1&&foo && 3} -1} msg] $msg
-} {1 {syntax error in expression "1&&foo && 3"}}
+} {1 {syntax error in expression "1&&foo && 3": variable references require preceding $}}
test parseExpr-4.3 {ParseLandExpr procedure, next lexeme isn't "&&"} {
testexprparser {1|2? 1 : 0} -1
} {- {} 0 subexpr {1|2? 1 : 0} 11 operator ? 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-4.4 {ParseLandExpr procedure, next lexeme is "&&"} {
testexprparser {1|2 && 3} -1
} {- {} 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {nonPortable} {
+test parseExpr-4.5 {ParseLandExpr procedure, bad lexeme after "&&"} {wideIntegerUnparsed} {
list [catch {testexprparser {1|2 && 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-4.6 {ParseLandExpr procedure, valid RHS subexpression} {
} {- {} 0 subexpr {1|2 && 3 && 4} 13 operator && 0 subexpr {1|2 && 3} 9 operator && 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-4.7 {ParseLandExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1|2 && 3 && martha} -1} msg] $msg
-} {1 {syntax error in expression "1|2 && 3 && martha"}}
+} {1 {syntax error in expression "1|2 && 3 && martha": variable references require preceding $}}
test parseExpr-5.1 {ParseBitOrExpr procedure, valid LHS "^" subexpr} {
testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-5.2 {ParseBitOrExpr procedure, error in LHS "^" subexpr} {
list [catch {testexprparser {1|foo | 3} -1} msg] $msg
-} {1 {syntax error in expression "1|foo | 3"}}
+} {1 {syntax error in expression "1|foo | 3": variable references require preceding $}}
test parseExpr-5.3 {ParseBitOrExpr procedure, next lexeme isn't "|"} {
testexprparser {1^2? 1 : 0} -1
} {- {} 0 subexpr {1^2? 1 : 0} 11 operator ? 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-5.4 {ParseBitOrExpr procedure, next lexeme is "|"} {
testexprparser {1^2 | 3} -1
} {- {} 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {nonPortable} {
+test parseExpr-5.5 {ParseBitOrExpr procedure, bad lexeme after "|"} {wideIntegerUnparsed} {
list [catch {testexprparser {1^2 | 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-5.6 {ParseBitOrExpr procedure, valid RHS subexpression} {
} {- {} 0 subexpr {1^2 | 3 | 4} 13 operator | 0 subexpr {1^2 | 3} 9 operator | 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-5.7 {ParseBitOrExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1^2 | 3 | martha} -1} msg] $msg
-} {1 {syntax error in expression "1^2 | 3 | martha"}}
+} {1 {syntax error in expression "1^2 | 3 | martha": variable references require preceding $}}
test parseExpr-6.1 {ParseBitXorExpr procedure, valid LHS "&" subexpr} {
testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-6.2 {ParseBitXorExpr procedure, error in LHS "&" subexpr} {
list [catch {testexprparser {1^foo ^ 3} -1} msg] $msg
-} {1 {syntax error in expression "1^foo ^ 3"}}
+} {1 {syntax error in expression "1^foo ^ 3": variable references require preceding $}}
test parseExpr-6.3 {ParseBitXorExpr procedure, next lexeme isn't "^"} {
testexprparser {1&2? 1 : 0} -1
} {- {} 0 subexpr {1&2? 1 : 0} 11 operator ? 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-6.4 {ParseBitXorExpr procedure, next lexeme is "^"} {
testexprparser {1&2 ^ 3} -1
} {- {} 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {nonPortable} {
+test parseExpr-6.5 {ParseBitXorExpr procedure, bad lexeme after "^"} {wideIntegerUnparsed} {
list [catch {testexprparser {1&2 ^ 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-6.6 {ParseBitXorExpr procedure, valid RHS subexpression} {
} {- {} 0 subexpr {1&2 ^ 3 ^ 4} 13 operator ^ 0 subexpr {1&2 ^ 3} 9 operator ^ 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-6.7 {ParseBitXorExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1&2 ^ 3 ^ martha} -1} msg] $msg
-} {1 {syntax error in expression "1&2 ^ 3 ^ martha"}}
+} {1 {syntax error in expression "1&2 ^ 3 ^ martha": variable references require preceding $}}
test parseExpr-7.1 {ParseBitAndExpr procedure, valid LHS equality subexpr} {
testexprparser {1==2 & 3} -1
} {- {} 0 subexpr {1==2 & 3} 9 operator & 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
test parseExpr-7.2 {ParseBitAndExpr procedure, error in LHS equality subexpr} {
list [catch {testexprparser {1!=foo & 3} -1} msg] $msg
-} {1 {syntax error in expression "1!=foo & 3"}}
+} {1 {syntax error in expression "1!=foo & 3": variable references require preceding $}}
test parseExpr-7.3 {ParseBitAndExpr procedure, next lexeme isn't "&"} {
testexprparser {1==2? 1 : 0} -1
} {- {} 0 subexpr {1==2? 1 : 0} 11 operator ? 0 subexpr 1==2 5 operator == 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
test parseExpr-7.4 {ParseBitAndExpr procedure, next lexeme is "&"} {
testexprparser {1>2 & 3} -1
} {- {} 0 subexpr {1>2 & 3} 9 operator & 0 subexpr 1>2 5 operator > 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {nonPortable} {
+test parseExpr-7.5 {ParseBitAndExpr procedure, bad lexeme after "&"} {wideIntegerUnparsed} {
list [catch {testexprparser {1==2 & 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-7.6 {ParseBitAndExpr procedure, valid RHS subexpression} {
} {- {} 0 subexpr {1<2 & 3 & 4} 13 operator & 0 subexpr {1<2 & 3} 9 operator & 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
test parseExpr-7.7 {ParseBitAndExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1==2 & 3>2 & martha} -1} msg] $msg
-} {1 {syntax error in expression "1==2 & 3>2 & martha"}}
+} {1 {syntax error in expression "1==2 & 3>2 & martha": variable references require preceding $}}
-test parseExpr-7.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} {
+test parseExpr-8.1 {ParseEqualityExpr procedure, valid LHS relational subexpr} {
testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-7.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} {
+test parseExpr-8.2 {ParseEqualityExpr procedure, error in LHS relational subexpr} {
list [catch {testexprparser {1>=foo == 3} -1} msg] $msg
-} {1 {syntax error in expression "1>=foo == 3"}}
-test parseExpr-7.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} {
+} {1 {syntax error in expression "1>=foo == 3": variable references require preceding $}}
+test parseExpr-8.3 {ParseEqualityExpr procedure, next lexeme isn't "==" or "!="} {
testexprparser {1<2? 1 : 0} -1
} {- {} 0 subexpr {1<2? 1 : 0} 11 operator ? 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
-test parseExpr-7.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!=} {
+test parseExpr-8.4 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} {
testexprparser {1<2 == 3} -1
} {- {} 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-7.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} {
+test parseExpr-8.5 {ParseEqualityExpr procedure, next lexeme is "==" or "!="} {
testexprparser {1<2 != 3} -1
} {- {} 0 subexpr {1<2 != 3} 9 operator != 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-7.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {nonPortable} {
+test parseExpr-8.6 {ParseEqualityExpr procedure, bad lexeme after "==" or "!="} {wideIntegerUnparsed} {
list [catch {testexprparser {1<2 == 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-7.7 {ParseEqualityExpr procedure, valid RHS subexpression} {
+test parseExpr-8.7 {ParseEqualityExpr procedure, valid RHS subexpression} {
testexprparser {1<2 == 3 == 4} -1
} {- {} 0 subexpr {1<2 == 3 == 4} 13 operator == 0 subexpr {1<2 == 3} 9 operator == 0 subexpr 1<2 5 operator < 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-7.8 {ParseEqualityExpr procedure, error in RHS subexpression} {
+test parseExpr-8.8 {ParseEqualityExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1<2 == 3 != martha} -1} msg] $msg
-} {1 {syntax error in expression "1<2 == 3 != martha"}}
+} {1 {syntax error in expression "1<2 == 3 != martha": variable references require preceding $}}
-test parseExpr-8.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} {
+test parseExpr-9.1 {ParseRelationalExpr procedure, valid LHS shift subexpr} {
testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-8.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} {
+test parseExpr-9.2 {ParseRelationalExpr procedure, error in LHS shift subexpr} {
list [catch {testexprparser {1>=foo < 3} -1} msg] $msg
-} {1 {syntax error in expression "1>=foo < 3"}}
-test parseExpr-8.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} {
+} {1 {syntax error in expression "1>=foo < 3": variable references require preceding $}}
+test parseExpr-9.3 {ParseRelationalExpr procedure, next lexeme isn't relational op} {
testexprparser {1<<2? 1 : 0} -1
} {- {} 0 subexpr {1<<2? 1 : 0} 11 operator ? 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
-test parseExpr-8.4 {ParseRelationalExpr procedure, next lexeme is relational op} {
+test parseExpr-9.4 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1<<2 < 3} -1
} {- {} 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-8.5 {ParseRelationalExpr procedure, next lexeme is relational op} {
+test parseExpr-9.5 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1>>2 > 3} -1
} {- {} 0 subexpr {1>>2 > 3} 9 operator > 0 subexpr 1>>2 5 operator >> 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-8.6 {ParseRelationalExpr procedure, next lexeme is relational op} {
+test parseExpr-9.6 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1<<2 <= 3} -1
} {- {} 0 subexpr {1<<2 <= 3} 9 operator <= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-8.7 {ParseRelationalExpr procedure, next lexeme is relational op} {
+test parseExpr-9.7 {ParseRelationalExpr procedure, next lexeme is relational op} {
testexprparser {1<<2 >= 3} -1
} {- {} 0 subexpr {1<<2 >= 3} 9 operator >= 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-8.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {nonPortable} {
+test parseExpr-9.8 {ParseRelationalExpr procedure, bad lexeme after relational op} {wideIntegerUnparsed} {
list [catch {testexprparser {1<<2 < 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-8.9 {ParseRelationalExpr procedure, valid RHS subexpression} {
+test parseExpr-9.9 {ParseRelationalExpr procedure, valid RHS subexpression} {
testexprparser {1<<2 < 3 < 4} -1
} {- {} 0 subexpr {1<<2 < 3 < 4} 13 operator < 0 subexpr {1<<2 < 3} 9 operator < 0 subexpr 1<<2 5 operator << 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-8.8 {ParseRelationalExpr procedure, error in RHS subexpression} {
+test parseExpr-9.10 {ParseRelationalExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1<<2 < 3 > martha} -1} msg] $msg
-} {1 {syntax error in expression "1<<2 < 3 > martha"}}
+} {1 {syntax error in expression "1<<2 < 3 > martha": variable references require preceding $}}
-test parseExpr-9.1 {ParseShiftExpr procedure, valid LHS add subexpr} {
+test parseExpr-10.1 {ParseShiftExpr procedure, valid LHS add subexpr} {
testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-9.2 {ParseShiftExpr procedure, error in LHS add subexpr} {
+test parseExpr-10.2 {ParseShiftExpr procedure, error in LHS add subexpr} {
list [catch {testexprparser {1-foo << 3} -1} msg] $msg
-} {1 {syntax error in expression "1-foo << 3"}}
-test parseExpr-9.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} {
+} {1 {syntax error in expression "1-foo << 3": variable references require preceding $}}
+test parseExpr-10.3 {ParseShiftExpr procedure, next lexeme isn't "<<" or ">>"} {
testexprparser {1+2? 1 : 0} -1
} {- {} 0 subexpr {1+2? 1 : 0} 11 operator ? 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
-test parseExpr-9.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>} {
+test parseExpr-10.4 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} {
testexprparser {1+2 << 3} -1
} {- {} 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-9.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} {
+test parseExpr-10.5 {ParseShiftExpr procedure, next lexeme is "<<" or ">>"} {
testexprparser {1+2 >> 3} -1
} {- {} 0 subexpr {1+2 >> 3} 9 operator >> 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-9.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {nonPortable} {
+test parseExpr-10.6 {ParseShiftExpr procedure, bad lexeme after "<<" or ">>"} {wideIntegerUnparsed} {
list [catch {testexprparser {1+2 << 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-9.7 {ParseShiftExpr procedure, valid RHS subexpression} {
+test parseExpr-10.7 {ParseShiftExpr procedure, valid RHS subexpression} {
testexprparser {1+2 << 3 << 4} -1
} {- {} 0 subexpr {1+2 << 3 << 4} 13 operator << 0 subexpr {1+2 << 3} 9 operator << 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-9.8 {ParseShiftExpr procedure, error in RHS subexpression} {
+test parseExpr-10.8 {ParseShiftExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1+2 << 3 >> martha} -1} msg] $msg
-} {1 {syntax error in expression "1+2 << 3 >> martha"}}
+} {1 {syntax error in expression "1+2 << 3 >> martha": variable references require preceding $}}
-test parseExpr-10.1 {ParseAddExpr procedure, valid LHS multiply subexpr} {
+test parseExpr-11.1 {ParseAddExpr procedure, valid LHS multiply subexpr} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-10.2 {ParseAddExpr procedure, error in LHS multiply subexpr} {
+test parseExpr-11.2 {ParseAddExpr procedure, error in LHS multiply subexpr} {
list [catch {testexprparser {1/foo + 3} -1} msg] $msg
-} {1 {syntax error in expression "1/foo + 3"}}
-test parseExpr-10.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} {
+} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}}
+test parseExpr-11.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} {
testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
-test parseExpr-10.4 {ParseAddExpr procedure, next lexeme is "+" or "-} {
+test parseExpr-11.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-10.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
+test parseExpr-11.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-10.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {nonPortable} {
+test parseExpr-11.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {wideIntegerUnparsed} {
list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-10.7 {ParseAddExpr procedure, valid RHS subexpression} {
+test parseExpr-11.7 {ParseAddExpr procedure, valid RHS subexpression} {
testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-10.8 {ParseAddExpr procedure, error in RHS subexpression} {
+test parseExpr-11.8 {ParseAddExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg
-} {1 {syntax error in expression "1*2 + 3 - martha"}}
+} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}}
-test parseExpr-10.1 {ParseAddExpr procedure, valid LHS multiply subexpr} {
+test parseExpr-12.1 {ParseAddExpr procedure, valid LHS multiply subexpr} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-10.2 {ParseAddExpr procedure, error in LHS multiply subexpr} {
+test parseExpr-12.2 {ParseAddExpr procedure, error in LHS multiply subexpr} {
list [catch {testexprparser {1/foo + 3} -1} msg] $msg
-} {1 {syntax error in expression "1/foo + 3"}}
-test parseExpr-10.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} {
+} {1 {syntax error in expression "1/foo + 3": variable references require preceding $}}
+test parseExpr-12.3 {ParseAddExpr procedure, next lexeme isn't "+" or "-"} {
testexprparser {1*2? 1 : 0} -1
} {- {} 0 subexpr {1*2? 1 : 0} 11 operator ? 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
-test parseExpr-10.4 {ParseAddExpr procedure, next lexeme is "+" or "-} {
+test parseExpr-12.4 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 + 3} -1
} {- {} 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-10.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
+test parseExpr-12.5 {ParseAddExpr procedure, next lexeme is "+" or "-"} {
testexprparser {1*2 - 3} -1
} {- {} 0 subexpr {1*2 - 3} 9 operator - 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-10.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {nonPortable} {
+test parseExpr-12.6 {ParseAddExpr procedure, bad lexeme after "+" or "-"} {wideIntegerUnparsed} {
list [catch {testexprparser {1*2 + 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-10.7 {ParseAddExpr procedure, valid RHS subexpression} {
+test parseExpr-12.7 {ParseAddExpr procedure, valid RHS subexpression} {
testexprparser {1*2 + 3 + 4} -1
} {- {} 0 subexpr {1*2 + 3 + 4} 13 operator + 0 subexpr {1*2 + 3} 9 operator + 0 subexpr 1*2 5 operator * 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-10.8 {ParseAddExpr procedure, error in RHS subexpression} {
+test parseExpr-12.8 {ParseAddExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {1*2 + 3 - martha} -1} msg] $msg
-} {1 {syntax error in expression "1*2 + 3 - martha"}}
+} {1 {syntax error in expression "1*2 + 3 - martha": variable references require preceding $}}
-test parseExpr-11.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} {
+test parseExpr-13.1 {ParseMultiplyExpr procedure, valid LHS unary subexpr} {
testexprparser {+2 * 3} -1
} {- {} 0 subexpr {+2 * 3} 7 operator * 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-11.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {nonPortable} {
+test parseExpr-13.2 {ParseMultiplyExpr procedure, error in LHS unary subexpr} {wideIntegerUnparsed} {
list [catch {testexprparser {-12345678901234567890 * 3} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-11.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} {
+test parseExpr-13.3 {ParseMultiplyExpr procedure, next lexeme isn't "*", "/", or "%"} {
testexprparser {+2? 1 : 0} -1
} {- {} 0 subexpr {+2? 1 : 0} 9 operator ? 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
-test parseExpr-11.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
+test parseExpr-13.4 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
testexprparser {-123 * 3} -1
} {- {} 0 subexpr {-123 * 3} 7 operator * 0 subexpr -123 3 operator - 0 subexpr 123 1 text 123 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-11.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
+test parseExpr-13.5 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
testexprparser {+-456 / 3} -1
} {- {} 0 subexpr {+-456 / 3} 9 operator / 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-11.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
+test parseExpr-13.6 {ParseMultiplyExpr procedure, next lexeme is "*", "/", or "%"} {
testexprparser {+-456 % 3} -1
} {- {} 0 subexpr {+-456 % 3} 9 operator % 0 subexpr +-456 5 operator + 0 subexpr -456 3 operator - 0 subexpr 456 1 text 456 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-11.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {nonPortable} {
+test parseExpr-13.7 {ParseMultiplyExpr procedure, bad lexeme after "*", "/", or "%"} {wideIntegerUnparsed} {
list [catch {testexprparser {--++5 / 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-11.8 {ParseMultiplyExpr procedure, valid RHS subexpression} {
+test parseExpr-13.8 {ParseMultiplyExpr procedure, valid RHS subexpression} {
testexprparser {-2 / 3 % 4} -1
} {- {} 0 subexpr {-2 / 3 % 4} 11 operator % 0 subexpr {-2 / 3} 7 operator / 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-11.9 {ParseMultiplyExpr procedure, error in RHS subexpression} {
+test parseExpr-13.9 {ParseMultiplyExpr procedure, error in RHS subexpression} {
list [catch {testexprparser {++2 / 3 * martha} -1} msg] $msg
-} {1 {syntax error in expression "++2 / 3 * martha"}}
+} {1 {syntax error in expression "++2 / 3 * martha": variable references require preceding $}}
-test parseExpr-12.1 {ParseUnaryExpr procedure, first token is unary operator} {
+test parseExpr-14.1 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {+2} -1
} {- {} 0 subexpr +2 3 operator + 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-12.2 {ParseUnaryExpr procedure, first token is unary operator} {
+test parseExpr-14.2 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {-2} -1
} {- {} 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-12.3 {ParseUnaryExpr procedure, first token is unary operator} {
+test parseExpr-14.3 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {~2} -1
} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-12.4 {ParseUnaryExpr procedure, first token is unary operator} {
+test parseExpr-14.4 {ParseUnaryExpr procedure, first token is unary operator} {
testexprparser {!2} -1
} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-12.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {nonPortable} {
+test parseExpr-14.5 {ParseUnaryExpr procedure, error in lexeme after unary op} {wideIntegerUnparsed} {
list [catch {testexprparser {-12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-12.6 {ParseUnaryExpr procedure, simple unary expr after unary op} {
+test parseExpr-14.6 {ParseUnaryExpr procedure, simple unary expr after unary op} {
testexprparser {+"1234"} -1
} {- {} 0 subexpr +\"1234\" 3 operator + 0 subexpr {"1234"} 1 text 1234 0 {}}
-test parseExpr-12.7 {ParseUnaryExpr procedure, another unary expr after unary op} {
+test parseExpr-14.7 {ParseUnaryExpr procedure, another unary expr after unary op} {
testexprparser {~!{fred}} -1
} {- {} 0 subexpr ~!{fred} 5 operator ~ 0 subexpr !{fred} 3 operator ! 0 subexpr {{fred}} 1 text fred 0 {}}
-test parseExpr-12.8 {ParseUnaryExpr procedure, error in unary expr after unary op} {
+test parseExpr-14.8 {ParseUnaryExpr procedure, error in unary expr after unary op} {
list [catch {testexprparser {+-||27} -1} msg] $msg
-} {1 {syntax error in expression "+-||27"}}
-test parseExpr-12.9 {ParseUnaryExpr procedure, error in unary expr after unary op} {
+} {1 {syntax error in expression "+-||27": unexpected operator ||}}
+test parseExpr-14.9 {ParseUnaryExpr procedure, error in unary expr after unary op} {
list [catch {testexprparser {+-||27} -1} msg] $msg
-} {1 {syntax error in expression "+-||27"}}
-test parseExpr-12.10 {ParseUnaryExpr procedure, first token is not unary op} {
+} {1 {syntax error in expression "+-||27": unexpected operator ||}}
+test parseExpr-14.10 {ParseUnaryExpr procedure, first token is not unary op} {
testexprparser {123} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
-test parseExpr-12.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} {
+test parseExpr-14.11 {ParseUnaryExpr procedure, not unary expr, complex primary expr} {
testexprparser {(1+2)} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-12.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {nonPortable} {
+test parseExpr-14.12 {ParseUnaryExpr procedure, not unary expr, error in primary expr} {wideIntegerUnparsed} {
list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-13.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} {
+test parseExpr-15.1 {ParsePrimaryExpr procedure, just parenthesized subexpr} {
testexprparser {({abc}/{def})} -1
} {- {} 0 subexpr {{abc}/{def}} 5 operator / 0 subexpr {{abc}} 1 text abc 0 subexpr {{def}} 1 text def 0 {}}
-test parseExpr-13.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {nonPortable} {
+test parseExpr-15.2 {ParsePrimaryExpr procedure, bad lexeme after "("} {wideIntegerUnparsed} {
list [catch {testexprparser {(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-13.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} {
+test parseExpr-15.3 {ParsePrimaryExpr procedure, valid parenthesized subexpr} {
testexprparser {({abc}? 2*4 : -6)} -1
} {- {} 0 subexpr {{abc}? 2*4 : -6} 13 operator ? 0 subexpr {{abc}} 1 text abc 0 subexpr 2*4 5 operator * 0 subexpr 2 1 text 2 0 subexpr 4 1 text 4 0 subexpr -6 3 operator - 0 subexpr 6 1 text 6 0 {}}
-test parseExpr-13.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} {
+test parseExpr-15.4 {ParsePrimaryExpr procedure, error in parenthesized subexpr} {
list [catch {testexprparser {(? 123 : 456)} -1} msg] $msg
-} {1 {syntax error in expression "(? 123 : 456)"}}
-test parseExpr-13.5 {ParsePrimaryExpr procedure, missing ")" after in parenthesized subexpr} {
+} {1 {syntax error in expression "(? 123 : 456)": unexpected ternary 'then' separator}}
+test parseExpr-15.5 {ParsePrimaryExpr procedure, missing ")" after in parenthesized subexpr} {
list [catch {testexprparser {({abc}/{def}} -1} msg] $msg
-} {1 {syntax error in expression "({abc}/{def}"}}
-test parseExpr-13.6 {ParsePrimaryExpr procedure, primary is literal} {
+} {1 {syntax error in expression "({abc}/{def}": looking for close parenthesis}}
+test parseExpr-15.6 {ParsePrimaryExpr procedure, primary is literal} {
testexprparser {12345} -1
} {- {} 0 subexpr 12345 1 text 12345 0 {}}
-test parseExpr-13.7 {ParsePrimaryExpr procedure, primary is literal} {
+test parseExpr-15.7 {ParsePrimaryExpr procedure, primary is literal} {
testexprparser {12345.6789} -1
} {- {} 0 subexpr 12345.6789 1 text 12345.6789 0 {}}
-test parseExpr-13.8 {ParsePrimaryExpr procedure, primary is var reference} {
+test parseExpr-15.8 {ParsePrimaryExpr procedure, primary is var reference} {
testexprparser {$a} -1
} {- {} 0 subexpr {$a} 2 variable {$a} 1 text a 0 {}}
-test parseExpr-13.9 {ParsePrimaryExpr procedure, primary is var reference} {
+test parseExpr-15.9 {ParsePrimaryExpr procedure, primary is var reference} {
testexprparser {$a(hello$there)} -1
} {- {} 0 subexpr {$a(hello$there)} 5 variable {$a(hello$there)} 4 text a 0 text hello 0 variable {$there} 1 text there 0 {}}
-test parseExpr-13.10 {ParsePrimaryExpr procedure, primary is var reference} {
+test parseExpr-15.10 {ParsePrimaryExpr procedure, primary is var reference} {
testexprparser {$a()} -1
} {- {} 0 subexpr {$a()} 3 variable {$a()} 2 text a 0 text {} 0 {}}
-test parseExpr-13.11 {ParsePrimaryExpr procedure, error in var reference} {
+test parseExpr-15.11 {ParsePrimaryExpr procedure, error in var reference} {
list [catch {testexprparser {$a(} -1} msg] $msg
} {1 {missing )}}
-test parseExpr-13.12 {ParsePrimaryExpr procedure, primary is quoted string} {
+test parseExpr-15.12 {ParsePrimaryExpr procedure, primary is quoted string} {
testexprparser {"abc $xyz def"} -1
} {- {} 0 subexpr {"abc $xyz def"} 5 word {"abc $xyz def"} 4 text {abc } 0 variable {$xyz} 1 text xyz 0 text { def} 0 {}}
-test parseExpr-13.13 {ParsePrimaryExpr procedure, error in quoted string} {
+test parseExpr-15.13 {ParsePrimaryExpr procedure, error in quoted string} {
list [catch {testexprparser {"$a(12"} -1} msg] $msg
} {1 {missing )}}
-test parseExpr-13.14 {ParsePrimaryExpr procedure, quoted string has multiple tokens} {
+test parseExpr-15.14 {ParsePrimaryExpr procedure, quoted string has multiple tokens} {
testexprparser {"abc [xyz] $def"} -1
} {- {} 0 subexpr {"abc [xyz] $def"} 6 word {"abc [xyz] $def"} 5 text {abc } 0 command {[xyz]} 0 text { } 0 variable {$def} 1 text def 0 {}}
-test parseExpr-13.15 {ParsePrimaryExpr procedure, primary is command} {
+test parseExpr-15.15 {ParsePrimaryExpr procedure, primary is command} {
testexprparser {[def]} -1
} {- {} 0 subexpr {[def]} 1 command {[def]} 0 {}}
-test parseExpr-13.16 {ParsePrimaryExpr procedure, primary is multiple commands} {
+test parseExpr-15.16 {ParsePrimaryExpr procedure, primary is multiple commands} {
testexprparser {[one; two; three; four;]} -1
} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}}
-test parseExpr-13.17 {ParsePrimaryExpr procedure, primary is multiple commands} {
+test parseExpr-15.17 {ParsePrimaryExpr procedure, primary is multiple commands} {
testexprparser {[one; two; three; four;]} -1
} {- {} 0 subexpr {[one; two; three; four;]} 1 command {[one; two; three; four;]} 0 {}}
-test parseExpr-13.18 {ParsePrimaryExpr procedure, missing close bracket} {
+test parseExpr-15.18 {ParsePrimaryExpr procedure, missing close bracket} {
list [catch {testexprparser {[one} -1} msg] $msg
} {1 {missing close-bracket}}
-test parseExpr-13.19 {ParsePrimaryExpr procedure, primary is braced string} {
+test parseExpr-15.19 {ParsePrimaryExpr procedure, primary is braced string} {
testexprparser {{hello world}} -1
} {- {} 0 subexpr {{hello world}} 1 text {hello world} 0 {}}
-test parseExpr-13.20 {ParsePrimaryExpr procedure, error in primary, which is braced string} {
+test parseExpr-15.20 {ParsePrimaryExpr procedure, error in primary, which is braced string} {
list [catch {testexprparser "\{abc\\\n" -1} msg] $msg
} {1 {missing close-brace}}
-test parseExpr-13.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} {
+test parseExpr-15.21 {ParsePrimaryExpr procedure, primary is braced string with multiple tokens} {
testexprparser "\{ \\
+123 \}" -1
} {- {} 0 subexpr \{\ \ \\\n\ +123\ \} 4 word \{\ \ \\\n\ +123\ \} 3 text { } 0 backslash \\\n\ 0 text {+123 } 0 {}}
-test parseExpr-13.22 {ParsePrimaryExpr procedure, primary is function call} {
+test parseExpr-15.22 {ParsePrimaryExpr procedure, primary is function call} {
testexprparser {foo(123)} -1
} {- {} 0 subexpr foo(123) 3 operator foo 0 subexpr 123 1 text 123 0 {}}
-test parseExpr-13.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {nonPortable} {
+test parseExpr-15.23 {ParsePrimaryExpr procedure, bad lexeme after function name} {wideIntegerUnparsed} {
list [catch {testexprparser {foo 12345678901234567890 123)} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-13.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} {
+test parseExpr-15.24 {ParsePrimaryExpr procedure, lexeme after function name isn't "("} {
list [catch {testexprparser {foo 27.4 123)} -1} msg] $msg
-} {1 {syntax error in expression "foo 27.4 123)"}}
-test parseExpr-13.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {nonPortable} {
+} {1 {syntax error in expression "foo 27.4 123)": variable references require preceding $}}
+test parseExpr-15.25 {ParsePrimaryExpr procedure, bad lexeme after "("} {wideIntegerUnparsed} {
list [catch {testexprparser {foo(12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-13.26 {ParsePrimaryExpr procedure, function call, one arg} {
+test parseExpr-15.26 {ParsePrimaryExpr procedure, function call, one arg} {
testexprparser {foo(27*4)} -1
} {- {} 0 subexpr foo(27*4) 7 operator foo 0 subexpr 27*4 5 operator * 0 subexpr 27 1 text 27 0 subexpr 4 1 text 4 0 {}}
-test parseExpr-13.27 {ParsePrimaryExpr procedure, error in function arg} {
+test parseExpr-15.27 {ParsePrimaryExpr procedure, error in function arg} {
list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
-} {1 {syntax error in expression "foo(*1-2)"}}
-test parseExpr-13.28 {ParsePrimaryExpr procedure, error in function arg} {
+} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
+test parseExpr-15.28 {ParsePrimaryExpr procedure, error in function arg} {
list [catch {testexprparser {foo(*1-2)} -1} msg] $msg
-} {1 {syntax error in expression "foo(*1-2)"}}
-test parseExpr-13.29 {ParsePrimaryExpr procedure, function call, comma after arg} {
+} {1 {syntax error in expression "foo(*1-2)": unexpected operator *}}
+test parseExpr-15.29 {ParsePrimaryExpr procedure, function call, comma after arg} {
testexprparser {foo(27-2, (-2*[foo]))} -1
} {- {} 0 subexpr {foo(27-2, (-2*[foo]))} 15 operator foo 0 subexpr 27-2 5 operator - 0 subexpr 27 1 text 27 0 subexpr 2 1 text 2 0 subexpr {-2*[foo]} 7 operator * 0 subexpr -2 3 operator - 0 subexpr 2 1 text 2 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
-test parseExpr-13.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {nonPortable} {
+test parseExpr-15.30 {ParsePrimaryExpr procedure, bad lexeme after comma} {wideIntegerUnparsed} {
list [catch {testexprparser {foo(123, 12345678901234567890)} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-13.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} {
+test parseExpr-15.31 {ParsePrimaryExpr procedure, lexeme not "," or ")" after arg} {
list [catch {testexprparser {foo(123 [foo])} -1} msg] $msg
-} {1 {syntax error in expression "foo(123 [foo])"}}
-test parseExpr-13.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {nonPortable} {
+} {1 {syntax error in expression "foo(123 [foo])": missing close parenthesis at end of function call}}
+test parseExpr-15.32 {ParsePrimaryExpr procedure, bad lexeme after primary} {wideIntegerUnparsed} {
list [catch {testexprparser {123 12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-
-test parseExpr-14.1 {GetLexeme procedure, whitespace before lexeme} {
+test parseExpr-15.33 {ParsePrimaryExpr procedure, comma-specific message} {
+ list [catch {testexprparser {123+,456} -1} msg] $msg
+} {1 {syntax error in expression "123+,456": commas can only separate function arguments}}
+test parseExpr-15.34 {ParsePrimaryExpr procedure, single equal-specific message} {
+ list [catch {testexprparser {123+=456} -1} msg] $msg
+} {1 {syntax error in expression "123+=456": single equality character not legal in expressions}}
+test parseExpr-15.35 {ParsePrimaryExpr procedure, error in parenthesized subexpr} {
+ list [catch {testexprparser {(: 123 : 456)} -1} msg] $msg
+} {1 {syntax error in expression "(: 123 : 456)": unexpected ternary 'else' separator}}
+
+test parseExpr-16.1 {GetLexeme procedure, whitespace before lexeme} {
testexprparser { 123} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
-test parseExpr-14.2 {GetLexeme procedure, whitespace before lexeme} {
+test parseExpr-16.2 {GetLexeme procedure, whitespace before lexeme} {
testexprparser { \
456} -1
} {- {} 0 subexpr 456 1 text 456 0 {}}
-test parseExpr-14.3 {GetLexeme procedure, no lexeme after whitespace} {
+test parseExpr-16.3 {GetLexeme procedure, no lexeme after whitespace} {
testexprparser { 123 \
} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
-test parseExpr-14.4 {GetLexeme procedure, integer lexeme} {
+test parseExpr-16.4 {GetLexeme procedure, integer lexeme} {
testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
-test parseExpr-14.5 {GetLexeme procedure, integer lexeme too big} {nonPortable} {
+test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {wideIntegerUnparsed} {
list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
-test parseExpr-14.6 {GetLexeme procedure, bad integer lexeme} {
- list [catch {testexprparser {0999} -1} msg] $msg
-} {1 {"0999" is an invalid octal number}}
-test parseExpr-14.7 {GetLexeme procedure, double lexeme} {
+
+test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -body {
+ testexprparser {0999} -1
+} -returnCodes error -match glob -result {*invalid octal number*}
+
+test parseExpr-16.7 {GetLexeme procedure, double lexeme} {
testexprparser {0.999} -1
} {- {} 0 subexpr 0.999 1 text 0.999 0 {}}
-test parseExpr-14.8 {GetLexeme procedure, double lexeme} {
+test parseExpr-16.8 {GetLexeme procedure, double lexeme} {
testexprparser {.123} -1
} {- {} 0 subexpr .123 1 text .123 0 {}}
-test parseExpr-14.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
+test parseExpr-16.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
testexprparser {nan} -1
} {- {} 0 subexpr nan 1 text nan 0 {}}
-test parseExpr-14.10 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
+test parseExpr-16.10 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
testexprparser {NaN} -1
} {- {} 0 subexpr NaN 1 text NaN 0 {}}
-test parseExpr-14.11 {GetLexeme procedure, bad double lexeme too big} {
+test parseExpr-16.11 {GetLexeme procedure, bad double lexeme too big} {
list [catch {testexprparser {123.e+99999999999999} -1} msg] $msg
} {1 {floating-point value too large to represent}}
-test parseExpr-14.12 {GetLexeme procedure, bad double lexeme} {
+test parseExpr-16.12 {GetLexeme procedure, bad double lexeme} {
list [catch {testexprparser {123.4x56} -1} msg] $msg
-} {1 {syntax error in expression "123.4x56"}}
-test parseExpr-14.13 {GetLexeme procedure, lexeme is "["} {
+} {1 {syntax error in expression "123.4x56": extra tokens at end of expression}}
+test parseExpr-16.13 {GetLexeme procedure, lexeme is "["} {
testexprparser {[foo]} -1
} {- {} 0 subexpr {[foo]} 1 command {[foo]} 0 {}}
-test parseExpr-14.14 {GetLexeme procedure, lexeme is open brace} {
+test parseExpr-16.14 {GetLexeme procedure, lexeme is open brace} {
testexprparser {{bar}} -1
} {- {} 0 subexpr {{bar}} 1 text bar 0 {}}
-test parseExpr-14.15 {GetLexeme procedure, lexeme is "("} {
+test parseExpr-16.15 {GetLexeme procedure, lexeme is "("} {
testexprparser {(123)} -1
} {- {} 0 subexpr 123 1 text 123 0 {}}
-test parseExpr-14.16 {GetLexeme procedure, lexeme is ")"} {
+test parseExpr-16.16 {GetLexeme procedure, lexeme is ")"} {
testexprparser {(2*3)} -1
} {- {} 0 subexpr 2*3 5 operator * 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.17 {GetLexeme procedure, lexeme is "$"} {
+test parseExpr-16.17 {GetLexeme procedure, lexeme is "$"} {
testexprparser {$wombat} -1
} {- {} 0 subexpr {$wombat} 2 variable {$wombat} 1 text wombat 0 {}}
-test parseExpr-14.18 {GetLexeme procedure, lexeme is '"'} {
+test parseExpr-16.18 "GetLexeme procedure, lexeme is '\"'" {
testexprparser {"fred"} -1
} {- {} 0 subexpr {"fred"} 1 text fred 0 {}}
-test parseExpr-14.19 {GetLexeme procedure, lexeme is ","} {
+test parseExpr-16.19 {GetLexeme procedure, lexeme is ","} {
testexprparser {foo(1,2)} -1
} {- {} 0 subexpr foo(1,2) 5 operator foo 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-14.20 {GetLexeme procedure, lexeme is "*"} {
+test parseExpr-16.20 {GetLexeme procedure, lexeme is "*"} {
testexprparser {$a*$b} -1
} {- {} 0 subexpr {$a*$b} 7 operator * 0 subexpr {$a} 2 variable {$a} 1 text a 0 subexpr {$b} 2 variable {$b} 1 text b 0 {}}
-test parseExpr-14.21 {GetLexeme procedure, lexeme is "/"} {
+test parseExpr-16.21 {GetLexeme procedure, lexeme is "/"} {
testexprparser {5/6} -1
} {- {} 0 subexpr 5/6 5 operator / 0 subexpr 5 1 text 5 0 subexpr 6 1 text 6 0 {}}
-test parseExpr-14.22 {GetLexeme procedure, lexeme is "%"} {
+test parseExpr-16.22 {GetLexeme procedure, lexeme is "%"} {
testexprparser {5%[xxx]} -1
} {- {} 0 subexpr {5%[xxx]} 5 operator % 0 subexpr 5 1 text 5 0 subexpr {[xxx]} 1 command {[xxx]} 0 {}}
-test parseExpr-14.23 {GetLexeme procedure, lexeme is "+"} {
+test parseExpr-16.23 {GetLexeme procedure, lexeme is "+"} {
testexprparser {1+2} -1
} {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-14.24 {GetLexeme procedure, lexeme is "-"} {
+test parseExpr-16.24 {GetLexeme procedure, lexeme is "-"} {
testexprparser {.12-0e27} -1
} {- {} 0 subexpr .12-0e27 5 operator - 0 subexpr .12 1 text .12 0 subexpr 0e27 1 text 0e27 0 {}}
-test parseExpr-14.25 {GetLexeme procedure, lexeme is "?" or ":"} {
+test parseExpr-16.25 {GetLexeme procedure, lexeme is "?" or ":"} {
testexprparser {$b? 1 : 0} -1
} {- {} 0 subexpr {$b? 1 : 0} 8 operator ? 0 subexpr {$b} 2 variable {$b} 1 text b 0 subexpr 1 1 text 1 0 subexpr 0 1 text 0 0 {}}
-test parseExpr-14.26 {GetLexeme procedure, lexeme is "<"} {
+test parseExpr-16.26 {GetLexeme procedure, lexeme is "<"} {
testexprparser {2<3} -1
} {- {} 0 subexpr 2<3 5 operator < 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.27 {GetLexeme procedure, lexeme is "<<"} {
+test parseExpr-16.27 {GetLexeme procedure, lexeme is "<<"} {
testexprparser {2<<3} -1
} {- {} 0 subexpr 2<<3 5 operator << 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.28 {GetLexeme procedure, lexeme is "<="} {
+test parseExpr-16.28 {GetLexeme procedure, lexeme is "<="} {
testexprparser {2<=3} -1
} {- {} 0 subexpr 2<=3 5 operator <= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.29 {GetLexeme procedure, lexeme is ">"} {
+test parseExpr-16.29 {GetLexeme procedure, lexeme is ">"} {
testexprparser {2>3} -1
} {- {} 0 subexpr 2>3 5 operator > 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.30 {GetLexeme procedure, lexeme is ">>"} {
+test parseExpr-16.30 {GetLexeme procedure, lexeme is ">>"} {
testexprparser {2>>3} -1
} {- {} 0 subexpr 2>>3 5 operator >> 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.31 {GetLexeme procedure, lexeme is ">="} {
+test parseExpr-16.31 {GetLexeme procedure, lexeme is ">="} {
testexprparser {2>=3} -1
} {- {} 0 subexpr 2>=3 5 operator >= 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.32 {GetLexeme procedure, lexeme is "=="} {
+test parseExpr-16.32 {GetLexeme procedure, lexeme is "=="} {
testexprparser {2==3} -1
} {- {} 0 subexpr 2==3 5 operator == 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.33 {GetLexeme procedure, bad lexeme starting with "="} {
+test parseExpr-16.33 {GetLexeme procedure, bad lexeme starting with "="} {
list [catch {testexprparser {2=+3} -1} msg] $msg
-} {1 {syntax error in expression "2=+3"}}
-test parseExpr-14.34 {GetLexeme procedure, lexeme is "!="} {
+} {1 {syntax error in expression "2=+3": extra tokens at end of expression}}
+test parseExpr-16.34 {GetLexeme procedure, lexeme is "!="} {
testexprparser {2!=3} -1
} {- {} 0 subexpr 2!=3 5 operator != 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.35 {GetLexeme procedure, lexeme is "!"} {
+test parseExpr-16.35 {GetLexeme procedure, lexeme is "!"} {
testexprparser {!2} -1
} {- {} 0 subexpr !2 3 operator ! 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-14.36 {GetLexeme procedure, lexeme is "&&"} {
+test parseExpr-16.36 {GetLexeme procedure, lexeme is "&&"} {
testexprparser {2&&3} -1
} {- {} 0 subexpr 2&&3 5 operator && 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.37 {GetLexeme procedure, lexeme is "&"} {
+test parseExpr-16.37 {GetLexeme procedure, lexeme is "&"} {
testexprparser {1&2} -1
} {- {} 0 subexpr 1&2 5 operator & 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-14.38 {GetLexeme procedure, lexeme is "^"} {
+test parseExpr-16.38 {GetLexeme procedure, lexeme is "^"} {
testexprparser {1^2} -1
} {- {} 0 subexpr 1^2 5 operator ^ 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-14.39 {GetLexeme procedure, lexeme is "||"} {
+test parseExpr-16.39 {GetLexeme procedure, lexeme is "||"} {
testexprparser {2||3} -1
} {- {} 0 subexpr 2||3 5 operator || 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.40 {GetLexeme procedure, lexeme is "|"} {
+test parseExpr-16.40 {GetLexeme procedure, lexeme is "|"} {
testexprparser {1|2} -1
} {- {} 0 subexpr 1|2 5 operator | 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-14.41 {GetLexeme procedure, lexeme is "~"} {
+test parseExpr-16.41 {GetLexeme procedure, lexeme is "~"} {
testexprparser {~2} -1
} {- {} 0 subexpr ~2 3 operator ~ 0 subexpr 2 1 text 2 0 {}}
-test parseExpr-14.42 {GetLexeme procedure, lexeme is func name} {
+test parseExpr-16.42 {GetLexeme procedure, lexeme is func name} {
testexprparser {george()} -1
} {- {} 0 subexpr george() 1 operator george 0 {}}
-test parseExpr-14.43 {GetLexeme procedure, lexeme is func name} {
+test parseExpr-16.43 {GetLexeme procedure, lexeme is func name} {
testexprparser {harmonic_ratio(2,3)} -1
} {- {} 0 subexpr harmonic_ratio(2,3) 5 operator harmonic_ratio 0 subexpr 2 1 text 2 0 subexpr 3 1 text 3 0 {}}
-test parseExpr-14.44 {GetLexeme procedure, unknown lexeme} {
+test parseExpr-16.44 {GetLexeme procedure, unknown lexeme} {
list [catch {testexprparser {@27} -1} msg] $msg
-} {1 {syntax error in expression "@27"}}
+} {1 {syntax error in expression "@27": character not legal in expressions}}
-test parseExpr-15.1 {PrependSubExprTokens procedure, expand token array} {
+test parseExpr-17.1 {PrependSubExprTokens procedure, expand token array} {
testexprparser {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} -1
} {- {} 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 13 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 9 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} 5 operator && 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 subexpr {[string compare [format %c $i] [string index $a $i]]} 1 command {[string compare [format %c $i] [string index $a $i]]} 0 {}}
-test parse-16.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
+test parseExpr-18.1 {LogSyntaxError procedure, error in expr longer than 60 chars} {
list [catch {testexprparser {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1} msg] $msg
-} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012"}}
+} {1 {syntax error in expression "(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+012...": premature end of expression}}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
namespace import -force ::tcltest::*
}
+tcltest::testConstraint testwordend \
+ [string equal "testwordend" [info commands testwordend]]
+
+# Save the argv value for restoration later
+set savedArgv $argv
+
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
set arg1 $a
]"
} {2}
-if {[info command testwordend] == "testwordend"} {
- test parseOld-14.1 {TclWordEnd procedure} {
- testwordend " \n abc"
- } {c}
- test parseOld-14.2 {TclWordEnd procedure} {
- testwordend " \\\n"
- } {}
- test parseOld-14.3 {TclWordEnd procedure} {
- testwordend " \\\n "
- } { }
- test parseOld-14.4 {TclWordEnd procedure} {
- testwordend {"abc"}
- } {"}
- test parseOld-14.5 {TclWordEnd procedure} {
- testwordend {{xyz}}
- } \}
- test parseOld-14.6 {TclWordEnd procedure} {
- testwordend {{a{}b{}\}} xyz}
- } "\} xyz"
- test parseOld-14.7 {TclWordEnd procedure} {
- testwordend {abc[this is a]def ghi}
- } {f ghi}
- test parseOld-14.8 {TclWordEnd procedure} {
- testwordend "puts\\\n\n "
- } "s\\\n\n "
- test parseOld-14.9 {TclWordEnd procedure} {
- testwordend "puts\\\n "
- } "s\\\n "
- test parseOld-14.10 {TclWordEnd procedure} {
- testwordend "puts\\\n xyz"
- } "s\\\n xyz"
- test parseOld-14.11 {TclWordEnd procedure} {
- testwordend {a$x.$y(a long index) foo}
- } ") foo"
- test parseOld-14.12 {TclWordEnd procedure} {
- testwordend {abc; def}
- } {; def}
- test parseOld-14.13 {TclWordEnd procedure} {
- testwordend {abc def}
- } {c def}
- test parseOld-14.14 {TclWordEnd procedure} {
- testwordend {abc def}
- } {c def}
- test parseOld-14.15 {TclWordEnd procedure} {
- testwordend "abc\ndef"
- } "c\ndef"
- test parseOld-14.16 {TclWordEnd procedure} {
- testwordend "abc"
- } {c}
- test parseOld-14.17 {TclWordEnd procedure} {
- testwordend "a\000bc"
- } {c}
- test parseOld-14.18 {TclWordEnd procedure} {
- testwordend \[a\000\]
- } {]}
- test parseOld-14.19 {TclWordEnd procedure} {
- testwordend \"a\000\"
- } {"}
- test parseOld-14.20 {TclWordEnd procedure} {
- testwordend a{\000}b
- } {b}
- test parseOld-14.21 {TclWordEnd procedure} {
- testwordend " \000b"
- } {b}
-}
+test parseOld-14.1 {TclWordEnd procedure} {testwordend} {
+ testwordend " \n abc"
+} {c}
+test parseOld-14.2 {TclWordEnd procedure} {testwordend} {
+ testwordend " \\\n"
+} {}
+test parseOld-14.3 {TclWordEnd procedure} {testwordend} {
+ testwordend " \\\n "
+} { }
+test parseOld-14.4 {TclWordEnd procedure} {testwordend} {
+ testwordend {"abc"}
+} {"}
+test parseOld-14.5 {TclWordEnd procedure} {testwordend} {
+ testwordend {{xyz}}
+} \}
+test parseOld-14.6 {TclWordEnd procedure} {testwordend} {
+ testwordend {{a{}b{}\}} xyz}
+} "\} xyz"
+test parseOld-14.7 {TclWordEnd procedure} {testwordend} {
+ testwordend {abc[this is a]def ghi}
+} {f ghi}
+test parseOld-14.8 {TclWordEnd procedure} {testwordend} {
+ testwordend "puts\\\n\n "
+} "s\\\n\n "
+test parseOld-14.9 {TclWordEnd procedure} {testwordend} {
+ testwordend "puts\\\n "
+} "s\\\n "
+test parseOld-14.10 {TclWordEnd procedure} {testwordend} {
+ testwordend "puts\\\n xyz"
+} "s\\\n xyz"
+test parseOld-14.11 {TclWordEnd procedure} {testwordend} {
+ testwordend {a$x.$y(a long index) foo}
+} ") foo"
+test parseOld-14.12 {TclWordEnd procedure} {testwordend} {
+ testwordend {abc; def}
+} {; def}
+test parseOld-14.13 {TclWordEnd procedure} {testwordend} {
+ testwordend {abc def}
+} {c def}
+test parseOld-14.14 {TclWordEnd procedure} {testwordend} {
+ testwordend {abc def}
+} {c def}
+test parseOld-14.15 {TclWordEnd procedure} {testwordend} {
+ testwordend "abc\ndef"
+} "c\ndef"
+test parseOld-14.16 {TclWordEnd procedure} {testwordend} {
+ testwordend "abc"
+} {c}
+test parseOld-14.17 {TclWordEnd procedure} {testwordend} {
+ testwordend "a\000bc"
+} {c}
+test parseOld-14.18 {TclWordEnd procedure} {testwordend} {
+ testwordend \[a\000\]
+} {]}
+test parseOld-14.19 {TclWordEnd procedure} {testwordend} {
+ testwordend \"a\000\"
+} {"}
+test parseOld-14.20 {TclWordEnd procedure} {testwordend} {
+ testwordend a{\000}b
+} {b}
+test parseOld-14.21 {TclWordEnd procedure} {testwordend} {
+ testwordend " \000b"
+} {b}
test parseOld-15.1 {TclScriptEnd procedure} {
info complete {puts [
} {0}
# cleanup
+set argv $savedArgv
::tcltest::cleanupTests
return
-
}
catch {removeFile test1}
+set path(test1) [makeFile {} test1]
test pid-1.1 {pid command} {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} {unixOrPc unixExecs} {
- set f [open {| echo foo | cat >test1} w]
+ set f [open [format {| echo foo | cat >%s} $path(test1)] w]
set pids [pid $f]
close $f
catch {removeFile test1}
[expr {[lindex $pids 0] == [lindex $pids 1]}]
} {2 1 1 0}
test pid-1.3 {pid command} {
- set f [open test1 w]
+ set f [open $path(test1) w]
set pids [pid $f]
close $f
set pids
-
package forget a c
lappend result [lsort [package names]]
} {{a b c} b}
+test pkg-3.5.1 {Tcl_PackageCmd procedure, "forget" option} {
+ # Test for Bug 415273
+ package ifneeded a 1 "I should have been forgotten"
+ package forget no-such-package a
+ set x [package ifneeded a 1]
+ package forget a
+ set x
+} {}
test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} {
list [catch {package ifneeded a} msg] $msg
} {1 {wrong # args: should be "package ifneeded package version ?script?"}}
-
+++ /dev/null
-# circ1.tcl --
-#
-# Test package for pkg_mkIndex. This package requires circ2, and circ2
-# requires circ3, which in turn requires circ1.
-# In case of cirularities, pkg_mkIndex should give up when it gets stuck.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package require circ2 1.0
-
-package provide circ1 1.0
-
-namespace eval circ1 {
- namespace export c1-1 c1-2 c1-3 c1-4
-}
-
-proc circ1::c1-1 { num } {
- return [circ2::c2-1 $num]
-}
-
-proc circ1::c1-2 { num } {
- return [circ2::c2-2 $num]
-}
-
-proc circ1::c1-3 {} {
- return 10
-}
-
-proc circ1::c1-4 {} {
- return 20
-}
+++ /dev/null
-# circ2.tcl --
-#
-# Test package for pkg_mkIndex. This package is required by circ1, and
-# requires circ3. Circ3, in turn, requires circ1 to give us a circularity.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package require circ3 1.0
-
-package provide circ2 1.0
-
-namespace eval circ2 {
- namespace export c2-1 c2-2
-}
-
-proc circ2::c2-1 { num } {
- return [expr $num * [circ3::c3-1]]
-}
-
-proc circ2::c2-2 { num } {
- return [expr $num * [circ3::c3-2]]
-}
+++ /dev/null
-# circ3.tcl --
-#
-# Test package for pkg_mkIndex. This package is required by circ2, and in
-# turn requires circ1. This closes the circularity.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package require circ1 1.0
-
-package provide circ3 1.0
-
-namespace eval circ3 {
- namespace export c3-1 c3-4
-}
-
-proc circ3::c3-1 {} {
- return [circ1::c1-3]
-}
-
-proc circ3::c3-2 {} {
- return [circ1::c1-4]
-}
+++ /dev/null
-# global.tcl --
-#
-# Test package for pkg_mkIndex.
-# Contains global symbols, used to check that they don't have a leading ::
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package provide global 1.0
-
-proc global_lower { stg } {
- return [string tolower $stg]
-}
-
-proc global_upper { stg } {
- return [string toupper $stg]
-}
+++ /dev/null
-package provide fubar 1.0
-
-namespace eval ::fubar:: {
- #
- # export only public functions.
- #
- namespace export {[a-z]*}
-}
-
-proc ::fubar::foo {bar} {
- puts "$bar"
- return true
-}
-
-namespace import ::fubar::foo
-
+++ /dev/null
-This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
-
-The authors hereby grant permission to use, copy, modify, distribute,
-and license this software and its documentation for any purpose, provided
-that existing copyright notices are retained in all copies and that this
-notice is included verbatim in any distributions. No written agreement,
-license, or royalty fee is required for any of the authorized uses.
-Modifications to this software may be copyrighted by their authors
-and need not follow the licensing terms described here, provided that
-the new terms are clearly indicated on the first page of each file where
-they apply.
-
-IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
-FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
-ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
-DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGE.
-
-THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
-IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
-NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
-MODIFICATIONS.
-
-GOVERNMENT USE: If you are acquiring this software on behalf of the
-U.S. government, the Government shall have only "Restricted Rights"
-in the software and related documentation as defined in the Federal
-Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
-are acquiring the software on behalf of the Department of Defense, the
-software shall be classified as "Commercial Computer Software" and the
-Government shall have only "Restricted Rights" as defined in Clause
-252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
-authors grant the U.S. Government and others acting in its behalf
-permission to use and distribute the software in accordance with the
-terms specified in this license.
+++ /dev/null
-set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
-set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo"
-set bracket1 "this contains an unescaped bracket [NoSuchProc]"
-set bracket2 "this contains an escaped bracket \[NoSuchProc\]"
-set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]"
-proc testProc {} {}
+++ /dev/null
-proc {[magic mojo proc]} {} {}
+++ /dev/null
-# pkg1.tcl --
-#
-# Test package for pkg_mkIndex. This package requires pkg3, but it does
-# not use any of pkg3's procs in the code that is executed by the file
-# (i.e. references to pkg3's procs are in the proc bodies only).
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package require pkg3 1.0
-
-package provide pkg1 1.0
-
-namespace eval pkg1 {
- namespace export p1-1 p1-2
-}
-
-proc pkg1::p1-1 { num } {
- return [pkg3::p3-1 $num]
-}
-
-proc pkg1::p1-2 { num } {
- return [pkg3::p3-2 $num]
-}
+++ /dev/null
-# pkg2_a.tcl --
-#
-# Test package for pkg_mkIndex. This package is required by pkg1.
-# This package is split into two files, to test packages that are split
-# over multiple files.
-#
-# Copyright (c) 2998 by Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# SCCS: %Z% %M% %I% %E% %U%
-
-package provide pkg2 1.0
-
-namespace eval pkg2 {
- namespace export p2-1
-}
-
-proc pkg2::p2-1 { num } {
- return [expr $num * 2]
-}
+++ /dev/null
-# pkg2_b.tcl --
-#
-# Test package for pkg_mkIndex. This package is required by pkg1.
-# This package is split into two files, to test packages that are split
-# over multiple files.
-#
-# Copyright (c) 2998 by Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# SCCS: %Z% %M% %I% %E% %U%
-
-package provide pkg2 1.0
-
-namespace eval pkg2 {
- namespace export p2-2
-}
-
-proc pkg2::p2-2 { num } {
- return [expr $num * 3]
-}
+++ /dev/null
-# pkg3.tcl --
-#
-# Test package for pkg_mkIndex.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package provide pkg3 1.0
-
-namespace eval pkg3 {
- namespace export p3-1 p3-2
-}
-
-proc pkg3::p3-1 { num } {
- return {[expr $num * 2]}
-}
-
-proc pkg3::p3-2 { num } {
- return {[expr $num * 3]}
-}
+++ /dev/null
-# pkg4.tcl --
-#
-# Test package for pkg_mkIndex. This package requires pkg3, and it calls
-# a pkg3 proc in the code that is executed by the file
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package require pkg3 1.0
-
-package provide pkg4 1.0
-
-namespace eval pkg4 {
- namespace export p4-1 p4-2
- variable m2 [pkg3::p3-1 10]
-}
-
-proc pkg4::p4-1 { num } {
- variable m2
- return [expr {$m2 * $num}]
-}
-
-proc pkg4::p4-2 { num } {
- return [pkg3::p3-2 $num]
-}
+++ /dev/null
-# pkg5.tcl --
-#
-# Test package for pkg_mkIndex. This package requires pkg2, and it calls
-# a pkg2 proc in the code that is executed by the file.
-# Pkg2 is a split package.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package require pkg2 1.0
-
-package provide pkg5 1.0
-
-namespace eval pkg5 {
- namespace export p5-1 p5-2
- variable m2 [pkg2::p2-1 10]
- variable m3 [pkg2::p2-2 10]
-}
-
-proc pkg5::p5-1 { num } {
- variable m2
- return [expr {$m2 * $num}]
-}
-
-proc pkg5::p5-2 { num } {
- variable m2
- return [expr {$m2 * $num}]
-}
+++ /dev/null
-# pkga.tcl --
-#
-# Test package for pkg_mkIndex. This package provides Pkga,
-# which is also provided by a DLL.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package provide Pkga 1.0
-
-proc pkga_neq { x } {
- return [expr {! [pkgq_eq $x]}]
-}
+++ /dev/null
-package provide football 1.0
-
-namespace eval ::pro:: {
- #
- # export only public functions.
- #
- namespace export {[a-z]*}
-}
-namespace eval ::college:: {
- #
- # export only public functions.
- #
- namespace export {[a-z]*}
-}
-
-proc ::pro::team {} {
- puts "go packers!"
- return true
-}
-
-proc ::college::team {} {
- puts "go badgers!"
- return true
-}
-
+++ /dev/null
-# simple.tcl --
-#
-# Test package for pkg_mkIndex. This is a simple package, just to check
-# basic functionality.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package provide simple 1.0
-
-namespace eval simple {
- namespace export lower upper
-}
-
-proc simple::lower { stg } {
- return [string tolower $stg]
-}
-
-proc simple::upper { stg } {
- return [string toupper $stg]
-}
+++ /dev/null
-package provide spacename 1.0
-proc {a b} {} {}
-proc {c d} {} {}
+++ /dev/null
-# std.tcl --
-#
-# Test package for pkg_mkIndex.
-# Does a package require of direct1, whose pkgIndex.tcl entry (in pkg1)
-# should be a -direct entry.
-# This tests that pkg_mkIndex can handle code that is sourced in pkgIndex.tcl
-# files.
-#
-# Copyright (c) 1998 by Scriptics Corporation.
-# All rights reserved.
-#
-# RCS: @(#) $Id$
-
-package require direct1
-
-package provide std 1.0
-
-namespace eval std {
- namespace export p1 p2
-}
-
-proc std::p1 { stg } {
- return [string tolower $stg]
-}
-
-proc std::p2 { stg } {
- return [string toupper $stg]
-}
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
-set origDir [pwd]
-cd $::tcltest::testsDirectory
+set fullPkgPath [makeDirectory pkg]
-set fullPkgPath [file join $::tcltest::testsDirectory pkg]
-
-# Add the pkg1 directory to auto_path, so that its packages can be found.
-# packages in pkg1 are used to test indexing of packages in pkg.
-# Make sure that the path to pkg1 is absolute.
-
-lappend auto_path [file join $::tcltest::testsDirectory pkg1]
namespace eval pkgtest {
# Namespace for procs we can discard
set patternList [lindex $parsed 2]
file mkdir $dirPath
-
+
if {[catch {
file delete [file join $dirPath pkgIndex.tcl]
- eval pkg_mkIndex $options $dirPath $patternList
+ eval pkg_mkIndex $options [list $dirPath] $patternList
} err]} {
return [list 1 $err]
}
# returned by pkgtest::parseIndex.
# If error, this is the error result.
-proc pkgtest::runIndex { args } {
- set rv [eval createIndex $args]
+proc pkgtest::runCreatedIndex {rv args} {
if {[lindex $rv 0] == 0} {
set parsed [eval parseArgs $args]
set dirPath [lindex $parsed 1]
return $result
}
+proc pkgtest::runIndex { args } {
+ set rv [eval createIndex $args]
+ return [eval [list runCreatedIndex $rv] $args]
+}
# If there is no match to the patterns, make sure the directory hasn't
# changed on us
list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd]
} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]
+makeFile {
+# This is a simple package, just to check basic functionality.
+package provide simple 1.0
+namespace eval simple {
+ namespace export lower upper
+}
+proc simple::lower { stg } {
+ return [string tolower $stg]
+}
+proc simple::upper { stg } {
+ return [string toupper $stg]
+}
+} [file join pkg simple.tcl]
+
test pkgMkIndex-2.1 {simple package} {
pkgtest::runIndex -lazy $fullPkgPath simple.tcl
} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}
test pkgMkIndex-2.2 {simple package - use -direct} {
pkgtest::runIndex -direct $fullPkgPath simple.tcl
-} "0 {{simple:1.0 {source [file join $fullPkgPath simple.tcl]}}}"
+} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
test pkgMkIndex-2.3 {simple package - direct loading is default} {
pkgtest::runIndex $fullPkgPath simple.tcl
-} "0 {{simple:1.0 {source [file join $fullPkgPath simple.tcl]}}}"
+} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
+
+removeFile [file join pkg simple.tcl]
+
+makeFile {
+# Contains global symbols, used to check that they don't have a leading ::
+package provide global 1.0
+proc global_lower { stg } {
+ return [string tolower $stg]
+}
+proc global_upper { stg } {
+ return [string toupper $stg]
+}
+} [file join pkg global.tcl]
test pkgMkIndex-3.1 {simple package with global symbols} {
pkgtest::runIndex -lazy $fullPkgPath global.tcl
} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}}
+removeFile [file join pkg global.tcl]
+
+makeFile {
+# This package is required by pkg1.
+# This package is split into two files, to test packages that are split
+# over multiple files.
+package provide pkg2 1.0
+namespace eval pkg2 {
+ namespace export p2-1
+}
+proc pkg2::p2-1 { num } {
+ return [expr $num * 2]
+}
+} [file join pkg pkg2_a.tcl]
+
+makeFile {
+# This package is required by pkg1.
+# This package is split into two files, to test packages that are split
+# over multiple files.
+package provide pkg2 1.0
+namespace eval pkg2 {
+ namespace export p2-2
+}
+proc pkg2::p2-2 { num } {
+ return [expr $num * 3]
+}
+} [file join pkg pkg2_b.tcl]
+
test pkgMkIndex-4.1 {split package} {
pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}
test pkgMkIndex-4.2 {split package - direct loading} {
pkgtest::runIndex -direct $fullPkgPath pkg2_a.tcl pkg2_b.tcl
-} "0 {{pkg2:1.0 {source [file join $fullPkgPath pkg2_a.tcl]
-source [file join $fullPkgPath pkg2_b.tcl]}}}"
-
-# This will fail, with "direct1" procedures in the list of procedures
-# provided by std.
-# It may also fail, if tclblend is in the auto_path, with an additional
-# command "loadJava" which comes from the tclblend pkgIndex.tcl file.
-# Both failures are caused by Tcl code executed in pkgIndex.tcl.
+} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
+[list source [file join $fullPkgPath pkg2_b.tcl]]}}}"
+
+# Add the direct1 directory to auto_path, so that the direct1 package
+# can be found.
+set direct1 [makeDirectory direct1]
+lappend auto_path $direct1
+makeFile {
+# This is referenced by pkgIndex.tcl as a -direct script.
+package provide direct1 1.0
+namespace eval direct1 {
+ namespace export pd1 pd2
+}
+proc direct1::pd1 { stg } {
+ return [string tolower $stg]
+}
+proc direct1::pd2 { stg } {
+ return [string toupper $stg]
+}
+} [file join direct1 direct1.tcl]
+pkg_mkIndex -direct $direct1 direct1.tcl
+
+makeFile {
+# Does a package require of direct1, whose pkgIndex.tcl entry
+# is created above with option -direct. This tests that pkg_mkIndex
+# can handle code that is sourced in pkgIndex.tcl files.
+package require direct1
+package provide std 1.0
+namespace eval std {
+ namespace export p1 p2
+}
+proc std::p1 { stg } {
+ return [string tolower $stg]
+}
+proc std::p2 { stg } {
+ return [string toupper $stg]
+}
+} [file join pkg std.tcl]
test pkgMkIndex-5.1 {requires -direct package} {
pkgtest::runIndex -lazy $fullPkgPath std.tcl
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}
+removeFile [file join direct1 direct1.tcl]
+file delete [file join $direct1 pkgIndex.tcl]
+removeDirectory direct1
+removeFile [file join pkg std.tcl]
+
+makeFile {
+# This package requires pkg3, but it does
+# not use any of pkg3's procs in the code that is executed by the file
+# (i.e. references to pkg3's procs are in the proc bodies only).
+package require pkg3 1.0
+package provide pkg1 1.0
+namespace eval pkg1 {
+ namespace export p1-1 p1-2
+}
+proc pkg1::p1-1 { num } {
+ return [pkg3::p3-1 $num]
+}
+proc pkg1::p1-2 { num } {
+ return [pkg3::p3-2 $num]
+}
+} [file join pkg pkg1.tcl]
+
+makeFile {
+package provide pkg3 1.0
+namespace eval pkg3 {
+ namespace export p3-1 p3-2
+}
+proc pkg3::p3-1 { num } {
+ return {[expr $num * 2]}
+}
+proc pkg3::p3-2 { num } {
+ return {[expr $num * 3]}
+}
+} [file join pkg pkg3.tcl]
+
test pkgMkIndex-6.1 {pkg1 requires pkg3} {
pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}
test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} {
pkgtest::runIndex -direct $fullPkgPath pkg1.tcl pkg3.tcl
-} "0 {{pkg1:1.0 {source [file join $fullPkgPath pkg1.tcl]}} {pkg3:1.0 {source [file join $fullPkgPath pkg3.tcl]}}}"
+} "0 {{pkg1:1.0 {[list source [file join $fullPkgPath pkg1.tcl]]}} {pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}}}"
+
+removeFile [file join pkg pkg1.tcl]
+
+makeFile {
+# This package requires pkg3, and it calls
+# a pkg3 proc in the code that is executed by the file
+package require pkg3 1.0
+package provide pkg4 1.0
+namespace eval pkg4 {
+ namespace export p4-1 p4-2
+ variable m2 [pkg3::p3-1 10]
+}
+proc pkg4::p4-1 { num } {
+ variable m2
+ return [expr {$m2 * $num}]
+}
+proc pkg4::p4-2 { num } {
+ return [pkg3::p3-2 $num]
+}
+} [file join pkg pkg4.tcl]
test pkgMkIndex-7.1 {pkg4 uses pkg3} {
pkgtest::runIndex -lazy $fullPkgPath pkg4.tcl pkg3.tcl
test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} {
pkgtest::runIndex -direct $fullPkgPath pkg4.tcl pkg3.tcl
-} "0 {{pkg3:1.0 {source [file join $fullPkgPath pkg3.tcl]}} {pkg4:1.0 {source [file join $fullPkgPath pkg4.tcl]}}}"
+} "0 {{pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}} {pkg4:1.0 {[list source [file join $fullPkgPath pkg4.tcl]]}}}"
+
+removeFile [file join pkg pkg4.tcl]
+removeFile [file join pkg pkg3.tcl]
+
+makeFile {
+# This package requires pkg2, and it calls
+# a pkg2 proc in the code that is executed by the file.
+# Pkg2 is a split package.
+package require pkg2 1.0
+package provide pkg5 1.0
+namespace eval pkg5 {
+ namespace export p5-1 p5-2
+ variable m2 [pkg2::p2-1 10]
+ variable m3 [pkg2::p2-2 10]
+}
+proc pkg5::p5-1 { num } {
+ variable m2
+ return [expr {$m2 * $num}]
+}
+proc pkg5::p5-2 { num } {
+ variable m2
+ return [expr {$m2 * $num}]
+}
+} [file join pkg pkg5.tcl]
test pkgMkIndex-8.1 {pkg5 uses pkg2} {
pkgtest::runIndex -lazy $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} {
pkgtest::runIndex -direct $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
-} "0 {{pkg2:1.0 {source [file join $fullPkgPath pkg2_a.tcl]
-source [file join $fullPkgPath pkg2_b.tcl]}} {pkg5:1.0 {source [file join $fullPkgPath pkg5.tcl]}}}"
+} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
+[list source [file join $fullPkgPath pkg2_b.tcl]]}} {pkg5:1.0 {[list source [file join $fullPkgPath pkg5.tcl]]}}}"
+
+removeFile [file join pkg pkg5.tcl]
+removeFile [file join pkg pkg2_a.tcl]
+removeFile [file join pkg pkg2_b.tcl]
+
+makeFile {
+# This package requires circ2, and circ2
+# requires circ3, which in turn requires circ1.
+# In case of cirularities, pkg_mkIndex should give up when it gets stuck.
+package require circ2 1.0
+package provide circ1 1.0
+namespace eval circ1 {
+ namespace export c1-1 c1-2 c1-3 c1-4
+}
+proc circ1::c1-1 { num } {
+ return [circ2::c2-1 $num]
+}
+proc circ1::c1-2 { num } {
+ return [circ2::c2-2 $num]
+}
+proc circ1::c1-3 {} {
+ return 10
+}
+proc circ1::c1-4 {} {
+ return 20
+}
+} [file join pkg circ1.tcl]
+
+makeFile {
+# This package is required by circ1, and
+# requires circ3. Circ3, in turn, requires circ1 to give us a circularity.
+package require circ3 1.0
+package provide circ2 1.0
+namespace eval circ2 {
+ namespace export c2-1 c2-2
+}
+proc circ2::c2-1 { num } {
+ return [expr $num * [circ3::c3-1]]
+}
+proc circ2::c2-2 { num } {
+ return [expr $num * [circ3::c3-2]]
+}
+} [file join pkg circ2.tcl]
+
+makeFile {
+# This package is required by circ2, and in
+# turn requires circ1. This closes the circularity.
+package require circ1 1.0
+package provide circ3 1.0
+namespace eval circ3 {
+ namespace export c3-1 c3-4
+}
+proc circ3::c3-1 {} {
+ return [circ1::c1-3]
+}
+proc circ3::c3-2 {} {
+ return [circ1::c1-4]
+}
+} [file join pkg circ3.tcl]
test pkgMkIndex-9.1 {circular packages} {
pkgtest::runIndex -lazy $fullPkgPath circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}
+removeFile [file join pkg circ1.tcl]
+removeFile [file join pkg circ2.tcl]
+removeFile [file join pkg circ3.tcl]
+
# Some tests require the existence of one of the DLLs in the dltest directory
set x [file join [file dirname [info nameofexecutable]] dltest \
pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
-set ::tcltest::testConstraints($dll) [file exists $x]
-
-test pkgMkIndex-10.1 {package in DLL and script} $dll {
- file copy -force $x $fullPkgPath
- pkgtest::runIndex -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
+::tcltest::testConstraint $dll [file exists $x]
+
+if {[testConstraint $dll]} {
+makeFile {
+# This package provides Pkga, which is also provided by a DLL.
+package provide Pkga 1.0
+proc pkga_neq { x } {
+ return [expr {! [pkgq_eq $x]}]
+}
+} [file join pkg pkga.tcl]
+file copy -force $x $fullPkgPath
+}
+testConstraint exec [llength [info commands ::exec]]
+
+test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
+ # Do all [load]ing of shared libraries in another process, so
+ # we can delete the file and not get stuck because we're holding
+ # a reference to it.
+ set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]
+ exec [interpreter] << $cmd
+ pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
-test pkgMkIndex-10.2 {package in DLL hidden by -load} $dll {
- pkgtest::runIndex -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
+test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
+ # Do all [load]ing of shared libraries in another process, so
+ # we can delete the file and not get stuck because we're holding
+ # a reference to it.
+ #
+ # This test depends on context from prior test, so repeat it.
+ set script "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]\n"
+ append script \
+ "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
+ exec [interpreter] << $script
+ pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
} {0 {}}
+if {[testConstraint $dll]} {
+file delete -force [file join $fullPkgPath [file tail $x]]
+removeFile [file join pkg pkga.tcl]
+}
+
# Tolerate "namespace import" at the global scope
+makeFile {
+package provide fubar 1.0
+namespace eval ::fubar:: {
+ #
+ # export only public functions.
+ #
+ namespace export {[a-z]*}
+}
+proc ::fubar::foo {bar} {
+ puts "$bar"
+ return true
+}
+namespace import ::fubar::foo
+} [file join pkg import.tcl]
+
test pkgMkIndex-11.1 {conflicting namespace imports} {
pkgtest::runIndex -lazy $fullPkgPath import.tcl
} {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}}
+removeFile [file join pkg import.tcl]
+
# Verify that the auto load list generated is correct even when there
# is a proc name conflict between two namespaces (ie, ::foo::baz and
# ::bar::baz)
+makeFile {
+package provide football 1.0
+namespace eval ::pro:: {
+ #
+ # export only public functions.
+ #
+ namespace export {[a-z]*}
+}
+namespace eval ::college:: {
+ #
+ # export only public functions.
+ #
+ namespace export {[a-z]*}
+}
+proc ::pro::team {} {
+ puts "go packers!"
+ return true
+}
+proc ::college::team {} {
+ puts "go badgers!"
+ return true
+}
+} [file join pkg samename.tcl]
+
test pkgMkIndex-12.1 {same name procs in different namespace} {
pkgtest::runIndex -lazy $fullPkgPath samename.tcl
} {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}}
+removeFile [file join pkg samename.tcl]
+
# Proc names with embedded spaces are properly listed (ie, correct number of
# braces) in result
+makeFile {
+package provide spacename 1.0
+proc {a b} {} {}
+proc {c d} {} {}
+} [file join pkg spacename.tcl]
+
test pkgMkIndex-13.1 {proc names with embedded spaces} {
pkgtest::runIndex -lazy $fullPkgPath spacename.tcl
} {0 {{spacename:1.0 {tclPkgSetup {spacename.tcl source {{a b} {c d}}}}}}}
+removeFile [file join pkg spacename.tcl]
+
+# Test the pkg_compareExtension helper function
+test pkgMkIndex-14.1 {pkg_compareExtension} {unixOnly} {
+ pkg_compareExtension foo.so .so
+} 1
+test pkgMkIndex-14.2 {pkg_compareExtension} {unixOnly} {
+ pkg_compareExtension foo.so.bar .so
+} 0
+test pkgMkIndex-14.3 {pkg_compareExtension} {unixOnly} {
+ pkg_compareExtension foo.so.1 .so
+} 1
+test pkgMkIndex-14.4 {pkg_compareExtension} {unixOnly} {
+ pkg_compareExtension foo.so.1.2 .so
+} 1
+test pkgMkIndex-14.5 {pkg_compareExtension} {unixOnly} {
+ pkg_compareExtension foo .so
+} 0
+test pkgMkIndex-14.6 {pkg_compareExtension} {unixOnly} {
+ pkg_compareExtension foo.so.1.2.bar .so
+} 0
+
# cleanup
+removeDirectory pkg
+
namespace delete pkgtest
-cd $origDir
::tcltest::cleanupTests
return
-
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
-} {byteOrder machine os osVersion platform user}
+} {byteOrder machine os osVersion platform user wordSize}
+
+# Test assumes twos-complement arithmetic, which is true of virtually
+# everything these days. Note that this does *not* use wide(), and
+# this is intentional since that could make Tcl's numbers wider than
+# the machine-integer on some platforms...
+test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
+ set result [expr {1 << (8 * $tcl_platform(wordSize) - 1)}]
+ # Result must be the largest bit in a machine word, which this checks
+ # without assuming how wide the word really is
+ list [expr {$result < 0}] [expr {$result ^ ($result - 1)}]
+} {1 -1}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
} {{w t1}}
catch {unset a}
-test proc-old-3.1 {arguments and defaults} {
+test proc-old-30.1 {arguments and defaults} {
proc tproc {x y z} {
return [list $x $y $z]
}
tproc 11 12 13
} {11 12 13}
-test proc-old-3.2 {arguments and defaults} {
+test proc-old-30.2 {arguments and defaults} {
proc tproc {x y z} {
return [list $x $y $z]
}
list [catch {tproc 11 12} msg] $msg
-} {1 {no value given for parameter "z" to "tproc"}}
-test proc-old-3.3 {arguments and defaults} {
+} {1 {wrong # args: should be "tproc x y z"}}
+test proc-old-30.3 {arguments and defaults} {
proc tproc {x y z} {
return [list $x $y $z]
}
list [catch {tproc 11 12 13 14} msg] $msg
-} {1 {called "tproc" with too many arguments}}
-test proc-old-3.4 {arguments and defaults} {
+} {1 {wrong # args: should be "tproc x y z"}}
+test proc-old-30.4 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
tproc 11 12 13
} {11 12 13}
-test proc-old-3.5 {arguments and defaults} {
+test proc-old-30.5 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
tproc 11 12
} {11 12 z-default}
-test proc-old-3.6 {arguments and defaults} {
+test proc-old-30.6 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
tproc 11
} {11 y-default z-default}
-test proc-old-3.7 {arguments and defaults} {
+test proc-old-30.7 {arguments and defaults} {
proc tproc {x {y y-default} {z z-default}} {
return [list $x $y $z]
}
list [catch {tproc} msg] $msg
-} {1 {no value given for parameter "x" to "tproc"}}
-test proc-old-3.8 {arguments and defaults} {
+} {1 {wrong # args: should be "tproc x ?y? ?z?"}}
+test proc-old-30.8 {arguments and defaults} {
list [catch {
proc tproc {x {y y-default} z} {
return [list $x $y $z]
}
tproc 2 3
} msg] $msg
-} {1 {no value given for parameter "z" to "tproc"}}
-test proc-old-3.9 {arguments and defaults} {
+} {1 {wrong # args: should be "tproc x ?y? z"}}
+test proc-old-30.9 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
tproc 2 3 4 5
} {2 3 {4 5}}
-test proc-old-3.10 {arguments and defaults} {
+test proc-old-30.10 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
tproc 2 3
} {2 3 {}}
-test proc-old-3.11 {arguments and defaults} {
+test proc-old-30.11 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
tproc 2
} {2 y-default {}}
-test proc-old-3.12 {arguments and defaults} {
+test proc-old-30.12 {arguments and defaults} {
proc tproc {x {y y-default} args} {
return [list $x $y $args]
}
list [catch {tproc} msg] $msg
-} {1 {no value given for parameter "x" to "tproc"}}
+} {1 {wrong # args: should be "tproc x ?y? args"}}
test proc-old-4.1 {variable numbers of arguments} {
proc tproc args {return $args}
test proc-old-4.6 {variable numbers of arguments} {
proc tproc {x missing args} {return $args}
list [catch {tproc 1} msg] $msg
-} {1 {no value given for parameter "missing" to "tproc"}}
+} {1 {wrong # args: should be "tproc x missing args"}}
test proc-old-5.1 {error conditions} {
list [catch {proc} msg] $msg
catch tproc msg
set errorInfo
} {invoked "break" outside of a loop
- while executing
+ (procedure "tproc" line 1)
+ invoked from within
"tproc"}
test proc-old-5.15 {error conditions} {
proc tproc {} {
catch tproc msg
set errorInfo
} {invoked "continue" outside of a loop
- while executing
+ (procedure "tproc" line 1)
+ invoked from within
"tproc"}
test proc-old-5.16 {error conditions} {
proc foo args {
catch {open _bad_file_name r} msg
return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
}
- normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
+ normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
while executing
"open _bad_file_name r"
catch {open _bad_file_name r} msg
return -code error -errorcode $errorCode $msg
}
- normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
+ normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
while executing
"tproc2"} {posix enoent {no such file or directory}}}
catch {open _bad_file_name r} msg
return -code error -errorinfo $errorInfo $msg
}
- normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
+ normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
while executing
"open _bad_file_name r"
catch {open _bad_file_name r} msg
return -code error $msg
}
- normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
+ regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
+ normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
while executing
"tproc2"} none}
-
puts "$z=z, $a(1)=$a(1)"
}} msg] $msg
} {1 {procedure "p" has formal parameter "a(1)" that is an array element}}
+test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
+ catch {rename p ""}
+ list [catch {proc p {b:a b::a} {
+ }} msg] $msg
+} {1 {procedure "p" has formal parameter "b::a" that is not a simple name}}
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
-} {1 {no value given for parameter "x" to "p"}}
+} {1 {wrong # args: should be "p x"}}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
+test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
+ proc p args {} ; # this will be bytecompiled into t
+ proc t {} {
+ set res {}
+ set a 0
+ set b 0
+ trace add variable a read {append res a ;#}
+ trace add variable b write {append res b ;#}
+ p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello
+ set res
+ }
+ set result [t]
+ catch {rename p ""}
+ catch {rename t ""}
+ set result
+} {aba}
+
# cleanup
catch {rename p ""}
catch {rename t ""}
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
# All tests require the testregexp command, return if this
# command doesn't exist
-set ::tcltest::testConstraints(testregexp) \
+::tcltest::testConstraint testregexp \
[expr {[info commands testregexp] != {}}]
-set ::tcltest::testConstraints(localeRegexp) 0
+::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
# testing. The name of the procedure indicates the general nature of the
if {[info exists regBug] && $regBug} {
# This will register as a skipped test
- test $prefix.[tno $testid] [desc $testid] knownBug {} {}
+ test $prefix.[tno $testid] [desc $testid] knownBug {format 0} {1}
return
}
# flush any leftover complaints
doing 0 "flush"
+# Tests resulting from bugs reported by users
+test reg-31.1 {[[:xdigit:]] behaves correctly when followed by [[:space:]]} {
+ set str {2:::DebugWin32}
+ set re {([[:xdigit:]])([[:space:]]*)}
+ list [regexp $re $str match xdigit spaces] $match $xdigit $spaces
+ # Code used to produce {1 2:::DebugWin32 2 :::DebugWin32} !!!
+} {1 2 2 {}}
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
set match {}
list [regexp {^a*b} aaaab match] $match
} {1 aaaab}
+test regexp-2.9 {getting substrings back from regexp} {
+ set foo {}
+ set f2 {}
+ list [regexp f\352te(b*)c f\352tebbbbc foo f2] $foo $f2
+} [list 1 f\352tebbbbc bbbb]
+test regexp-2.10 {getting substrings back from regexp} {
+ set foo {}
+ set f2 {}
+ list [regexp f\352te(b*)c eff\352tebbbbc foo f2] $foo $f2
+} [list 1 f\352tebbbbc bbbb]
test regexp-3.1 {-indices option to regexp} {
set foo {}
} "1 {da\nb123\nxb}"
test regexp-11.1 {regsub errors} {
- list [catch {regsub a b c} msg] $msg
-} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
+ list [catch {regsub a b} msg] $msg
+} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.2 {regsub errors} {
- list [catch {regsub -nocase a b c} msg] $msg
-} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
+ list [catch {regsub -nocase a b} msg] $msg
+} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.3 {regsub errors} {
- list [catch {regsub -nocase -all a b c} msg] $msg
-} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
+ list [catch {regsub -nocase -all a b} msg] $msg
+} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.4 {regsub errors} {
list [catch {regsub a b c d e f} msg] $msg
-} {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}}
+} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexp-11.5 {regsub errors} {
list [catch {regsub -gorp a b c} msg] $msg
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexp-11.8 {regsub errors, -start bad int check} {
list [catch {regsub -start bogus pattern string rep var} msg] $msg
} {1 {expected integer but got "bogus"}}
+test regexp-11.9 {regsub without final variable name returns value} {
+ regsub b abaca X
+} {aXaca}
+test regexp-11.10 {regsub without final variable name returns value} {
+ regsub -all a abaca X
+} {XbXcX}
+test regexp-11.11 {regsub without final variable name returns value} {
+ regsub b(.*?)d abcdeabcfde {,&,\1,}
+} {a,bcd,c,eabcfde}
+test regexp-11.12 {regsub without final variable name returns value} {
+ regsub -all b(.*?)d abcdeabcfde {,&,\1,}
+} {a,bcd,c,ea,bcfd,cf,e}
# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg. This is probably bigger than most users want...
regexp -nocase $x bbba
} 1
-# There is no exec on the Mac ...
-
-test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} {unixOrPc} {
- makeFile {puts [regexp {} foo]} junk.tcl
- exec $::tcltest::tcltest junk.tcl
+testConstraint exec [llength [info commands exec]]
+test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} {
+ exec
+} {
+ exec [interpreter] [makeFile {puts [regexp {} foo]} junk.tcl]
} 1
test regexp-15.1 {regexp -start} {
# Go to index 3; this is past the end of the string, so stop.
regexp -all -inline {a*} aba
} {a {} a}
+test regexp-18.11 {regexp -all} {
+ regexp -all -inline {^a} aaaa
+} {a}
+test regexp-18.12 {regexp -all -inline -indices} {
+ regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
+} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
+
+test regexp-19.1 {regsub null replacement} {
+ regsub -all {@} {@hel@lo@} "\0a\0" result
+ list $result [string length $result]
+} "\0a\0hel\0a\0lo\0a\0 14"
+
+test regexp-20.1 {regsub shared object shimmering} {
+ # Bug #461322
+ set a abcdefghijklmnopqurstuvwxyz
+ set b $a
+ set c abcdefghijklmnopqurstuvwxyz0123456789
+ regsub $a $c $b d
+ list $d [string length $d] [string bytelength $d]
+} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
+test regexp-20.2 {regsub shared object shimmering with -about} {
+ eval regexp -about abc
+} {0 {}}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
if {$tcl_platform(platform) == "windows"} {
if [catch {
- set lib [lindex [glob [file join [pwd] [file dirname \
- [info nameofexecutable]] tclreg*.dll]] 0]
+ set lib [lindex [glob -directory [file join [pwd] [file dirname \
+ [info nameofexecutable]]] tclreg*.dll] 0]
load $lib registry
}] {
puts "Unable to find the registry package. Skipping registry tests."
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
test registry-1.2 {argument parsing for registry command} {pcOnly} {
list [catch {registry foo} msg] $msg
-} {1 {bad option "foo": must be delete, get, keys, set, type, or values}}
+} {1 {bad option "foo": must be broadcast, delete, get, keys, set, type, or values}}
test registry-1.3 {argument parsing for registry command} {pcOnly} {
list [catch {registry d} msg] $msg
list [catch {registry set {\\mom\HKEY_CLASSES_ROOT\TclFoobar} bar foobar} msg] $msg
} {1 {unable to open key: Access is denied.}}
+test registry-12.1 {BroadcastValue} {pcOnly} {
+ list [catch {registry broadcast} msg] $msg
+} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
+test registry-12.2 {BroadcastValue} {pcOnly} {
+ list [catch {registry broadcast "" -time} msg] $msg
+} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
+test registry-12.3 {BroadcastValue} {pcOnly} {
+ list [catch {registry broadcast "" - 500} msg] $msg
+} {1 {wrong # args: should be "registry broadcast keyName ?-timeout millisecs?"}}
+test registry-12.4 {BroadcastValue} {pcOnly} {
+ list [catch {registry broadcast {Environment}} msg] $msg
+} {0 {1 0}}
+test registry-12.5 {BroadcastValue} {pcOnly} {
+ list [catch {registry b {}} msg] $msg
+} {0 {1 0}}
# cleanup
unset hostname
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
catch {rename unknown {}}
catch {rename unknown.old unknown}
+catch {rename bar {}}
if {[info command testdel] == "testdel"} {
test rename-4.1 {reentrancy issues with command deletion and renaming} {
proc incr {} {puts "new incr called!"}
catch {x} msg
set msg
-} {called "incr" with too many arguments}
+} {wrong # args: should be "incr"}
if {[info commands incr.old] != {}} {
catch {rename incr {}}
}
::tcltest::cleanupTests
return
-
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
# Some tests require the testsaveresult command
-set ::tcltest::testConstraints(testsaveresult) \
+::tcltest::testConstraint testsaveresult \
[expr {[info commands testsaveresult] != {}}]
test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} {
catch {namespace eval safe {set [InterpStateName a](foo)}} m2
list $m1 $m2
} "{}\
- {can't read \"[safe::InterpStateName a]\": no such variable}"
+ {can't read \"[safe::InterpStateName a](foo)\": no such variable}"
test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} {
set r [lreplace $r $threaded $threaded]
}
set r
-} {byteOrder platform}
+} {byteOrder platform wordSize}
# more test should be added to check that hostname, nameofexecutable,
# aren't leaking infos, but they still do...
test safe-8.5 {safe source control on file} {
+ # This tested filename == *.tcl or tclIndex, but that restriction
+ # was removed in 8.4a4 - hobbs
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
-} "1 {blah: must be a *.tcl or tclIndex} {{ERROR for slave a : [file join [info library] blah]:blah: must be a *.tcl or tclIndex}} {} {}"
+} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"] {} {}]
test safe-8.6 {safe source control on file} {
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
-} "1 {no such file or directory} {{ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory}} {} {}"
+} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"] {} {}]
test safe-8.7 {safe source control on file} {
+ # This tested length of filename, but that restriction
+ # was removed in 8.4a4 - hobbs
set i "a";
catch {safe::interpDelete $i}
safe::interpCreate $i;
$log \
[safe::setLogCmd $prevlog; unset log] \
[safe::interpDelete $i] ;
-} "1 {xxxxxxxxxxx.tcl: filename too long} {{ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:xxxxxxxxxxx.tcl: filename too long}} {} {}"
+} [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"] {} {}]
test safe-8.8 {safe source forbids -rsrc} {
set i "a";
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
+::tcltest::testConstraint 64bitInts [expr {0x80000000 > 0}]
+
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
} {1 f}
list [scan {+1238 -123a 0123} {%x%x%x} x y z] $x $y $z
} {3 4664 -4666 291}
test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} {
+ # The behavior changed in 8.4a4/8.3.4cvs (6 Feb) to correctly
+ # return '1' for 0x1 scanned via %x, to comply with 8.0 and C scanf.
+ # Bug #495213
set x {}
list [scan {aBcDeF AbCdEf 0x1} {%x%x%x} x y z] $x $y $z
-} {3 11259375 11259375 0}
+} {3 11259375 11259375 1}
+test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} {
+ set x {}
+ list [scan {0xF 0x00A0B 0X0XF} {%x %x %x} x y z] $x $y $z
+} {3 15 2571 0}
+test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} {
+ catch {unset x}
+ list [scan {xF} {%x} x] [info exists x]
+} {0 0}
test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} {
set x {}
list [scan {10 010 0x10} {%i%i%i} x y z] $x $y $z
set result
} {1 {couldn't set variable "z"couldn't set variable "y"} abc}
+# procedure that returns the range of integers
+
+proc int_range {} {
+ for { set MIN_INT 1 } { $MIN_INT > 0 } {} {
+ set MIN_INT [expr { $MIN_INT << 1 }]
+ }
+ set MAX_INT [expr { ~ $MIN_INT }]
+ return [list $MIN_INT $MAX_INT]
+}
+
+test scan-4.62 {scanning of large and negative octal integers} {
+ foreach { MIN_INT MAX_INT } [int_range] {}
+ set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT]
+ list [scan $scanstring {%o %o %o} a b c] \
+ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
+} {3 1 1 1}
+test scan-4.63 {scanning of large and negative hex integers} {
+ foreach { MIN_INT MAX_INT } [int_range] {}
+ set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT]
+ list [scan $scanstring {%x %x %x} a b c] \
+ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
+} {3 1 1 1}
+
+# clean up from last two tests
+
+catch {
+ rename int_range {}
+}
+
test scan-5.1 {integer scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d
[expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}
+test scan-5.12 {integer scanning} {64bitInts} {
+ set a {}; set b {}; set c {}
+ list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
+ %ld,%lx,%lo a b c] $a $b $c
+} {3 7810179016327718216 7810179016327718216 7810179016327718216}
+
test scan-6.1 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
} {0 0 0 1}
test set-old-7.2 {unset command} {
list [catch {unset} msg] $msg
-} {1 {wrong # args: should be "unset varName ?varName ...?"}}
+} {0 {}}
+# Used to return:
+#{1 {wrong # args: should be "unset ?-nocomplain? ?--? ?varName varName ...?"}}
test set-old-7.3 {unset command} {
catch {unset a}
list [catch {unset a} msg] $msg
unset a
list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2
} {1 {can't read "a(14)": no such variable} 0 {}}
+test set-old-7.12 {unset command, -nocomplain} {
+ catch {unset a}
+ list [info exists a] [catch {unset -nocomplain a}] [info exists a]
+} {0 0 0}
+test set-old-7.13 {unset command, -nocomplain} {
+ set -nocomplain abc
+ list [info exists -nocomplain] [catch {unset -nocomplain}] \
+ [info exists -nocomplain] [catch {unset -- -nocomplain}] \
+ [info exists -nocomplain]
+} {1 0 1 0 0}
+test set-old-7.14 {unset command, --} {
+ set -- abc
+ list [info exists --] [catch {unset --}] \
+ [info exists --] [catch {unset -- --}] \
+ [info exists --]
+} {1 0 1 0 0}
+test set-old-7.15 {unset command, -nocomplain} {
+ set -nocomplain abc
+ set -- abc
+ list [info exists -nocomplain] [catch {unset -- -nocomplain}] \
+ [info exists -nocomplain] [info exists --] \
+ [catch {unset -- -nocomplain}] [info exists --] \
+ [catch {unset -- --}] [info exists --]
+} {1 0 0 1 1 1 0 0}
+test set-old-7.16 {unset command, -nocomplain} {
+ set -nocomplain abc
+ set var abc
+ list [info exists bogus] [catch {unset -nocomplain bogus var bogus}] \
+ [info exists -nocomplain] [info exists var] \
+ [catch {unset -nocomplain -nocomplain}] [info exists -nocomplain]
+} {0 0 1 0 0 0}
+test set-old-7.17 {unset command, -nocomplain (no abbreviation)} {
+ set -nocomp abc
+ list [info exists -nocomp] [catch {unset -nocomp}] [info exists -nocomp]
+} {1 0 0}
+test set-old-7.18 {unset command, -nocomplain (no abbreviation)} {
+ catch {unset -nocomp}
+ list [info exists -nocomp] [catch {unset -nocomp}]
+} {0 1}
# Array command.
catch {unset a}
set a(22) 3
list [catch {array gorp a} msg] $msg
-} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, or unset}}
+} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}}
test set-old-8.7 {array command, anymore option} {
catch {unset a}
list [catch {array anymore a x} msg] $msg
catch {unset a}
set a(22) 3
list [catch {array names a 4 5} msg] $msg
-} {1 {wrong # args: should be "array names arrayName ?pattern?"}}
+} {1 {bad option "4": must be -exact, -glob, or -regexp}}
test set-old-8.19 {array command, names option} {
catch {unset a}
array names a
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.37.6 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var {a b}} msg] $msg
-} {1 {can't set "bogusnamespace::var(a)": parent namespace doesn't exist}}
+} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.37.7 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var(0)": variable isn't array}}
}
list [catch {p 1} msg] $msg
} {1 {"a" isn't an array}}
+test set-old-8.48 {array command, statistics option} {
+ catch {unset a}
+ set a(abc) 1
+ set a(def) 2
+ set a(ghi) 3
+ set a(jkl) 4
+ set a(mno) 5
+ set a(pqr) 6
+ set a(stu) 7
+ set a(vwx) 8
+ set a(yz) 9
+ array statistics a
+} "9 entries in table, 4 buckets
+number of buckets with 0 entries: 0
+number of buckets with 1 entries: 0
+number of buckets with 2 entries: 3
+number of buckets with 3 entries: 1
+number of buckets with 4 entries: 0
+number of buckets with 5 entries: 0
+number of buckets with 6 entries: 0
+number of buckets with 7 entries: 0
+number of buckets with 8 entries: 0
+number of buckets with 9 entries: 0
+number of buckets with 10 or more entries: 0
+average search distance for entry: 1.7"
+test set-old-8.49 {array command, array names -exact on glob pattern} {
+ catch {unset a}
+ set a(1*2) 1
+ list [catch {array names a -exact 1*2} msg] $msg
+} {0 1*2}
+test set-old-8.48 {array command, array names -glob on glob pattern} {
+ catch {unset a}
+ set a(1*2) 1
+ set a(12) 1
+ set a(11) 1
+ list [catch {lsort [array names a -glob 1*2]} msg] $msg
+} {0 {1*2 12}}
+test set-old-8.49 {array command, array names -regexp on regexp pattern} {
+ catch {unset a}
+ set a(1*2) 1
+ set a(12) 1
+ set a(11) 1
+ list [catch {lsort [array names a -regexp ^1]} msg] $msg
+} {0 {1*2 11 12}}
+test set-old-8.50 {array command, array names -regexp} {
+ catch {unset a}
+ set a(-glob) 1
+ set a(-regexp) 1
+ set a(-exact) 1
+ list [catch {array names a -regexp} msg] $msg
+} {0 -regexp}
+test set-old-8.51 {array command, array names -exact} {
+ catch {unset a}
+ set a(-glob) 1
+ set a(-regexp) 1
+ set a(-exact) 1
+ list [catch {array names a -exact} msg] $msg
+} {0 -exact}
+test set-old-8.52 {array command, array names -glob} {
+ catch {unset a}
+ set a(-glob) 1
+ set a(-regexp) 1
+ set a(-exact) 1
+ list [catch {array names a -glob} msg] $msg
+} {0 -glob}
+test set-old-8.53 {array command, array statistics on a non-array} {
+ catch {unset a}
+ list [catch {array statistics a} msg] $msg
+} [list 1 "\"a\" isn't an array"]
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
set a(a) 1
- list [array st a] [array st a] [array done a s-1-a; array st a] \
+ list [array star a] [array star a] [array done a s-1-a; array star a] \
[array done a s-2-a; array d a s-3-a; array start a]
} {s-1-a s-2-a s-3-a s-1-a}
test set-old-9.2 {array enumeration} {
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
catch {unset z}
::tcltest::cleanupTests
return
-
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
# Some tests require the testthread and exec commands
+testConstraint testthread [llength [info commands testthread]]
+testConstraint exec [llength [info commands exec]]
-set ::tcltest::testConstraints(testthread) \
- [expr {[info commands testthread] != {}}]
-set ::tcltest::testConstraints(exec) [expr {[info commands exec] != {}}]
-
-#
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#
set doTestsWithRemoteServer 0
} else {
set remoteServerIP 127.0.0.1
- set remoteFile [file join [pwd] remote.tcl]
+ # Be *extra* careful in case this file is sourced from
+ # a directory other than the current one...
+ set remoteFile [file join [pwd] [file dirname [info script]] \
+ remote.tcl]
if {[catch {set remoteProcChan \
- [open "|[list $::tcltest::tcltest $remoteFile \
+ [open "|[list [interpreter] $remoteFile \
-serverIsSilent \
-port $remoteServerPort \
-address $remoteServerIP]" \
set doTestsWithRemoteServer 0
}
} else {
- set noRemoteTestReason "$msg $::tcltest::tcltest"
+ set noRemoteTestReason "$msg [interpreter]"
set doTestsWithRemoteServer 0
}
}
list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
+set path(script) [makeFile {} script]
+
test socket-2.1 {tcp connection} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- set timer [after 2000 "set x timed_out"]
- set f [socket -server accept 2828]
+ set timer [after 10000 "set x timed_out"]
+ set f [socket -server accept 0]
proc accept {file addr port} {
global x
set x done
close $file
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
- if {[catch {socket 127.0.0.1 2828} msg]} {
+ gets $f listen
+ if {[catch {socket 127.0.0.1 $listen} msg]} {
set x $msg
} else {
lappend x [gets $f]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept 2829]
+ set timer [after 10000 "set x timeout"]
+ set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file] $port"
set x done
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
+ gets $f listen
global port
- if {[catch {socket -myport $port 127.0.0.1 2829} sock]} {
+ if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
set x $sock
- close [socket 127.0.0.1 2829]
+ close [socket 127.0.0.1 $listen]
puts stderr $sock
} else {
puts $sock hello
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
set f [socket -server accept 2830]
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
set x $sock
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
- set f [socket -server accept -myaddr [info hostname] 2831]
+ set f [socket -server accept -myaddr 127.0.0.1 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
set x done
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
- if {[catch {socket [info hostname] 2831} sock]} {
+ gets $f listen
+ if {[catch {socket 127.0.0.1 $listen} sock]} {
set x $sock
} else {
puts $sock hello
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept 2832]
+ set timer [after 10000 "set x timeout"]
+ set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
set x done
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
- if {[catch {socket 127.0.0.1 2832} sock]} {
+ gets $f listen
+ if {[catch {socket 127.0.0.1 $listen} sock]} {
set x $sock
} else {
puts $sock hello
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- set timer [after 2000 "set x done"]
- set f [socket -server accept 2834]
+ set timer [after 10000 "set x timeout"]
+ set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -translation lf -buffering line
}
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
- puts done
+ puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f
- set s [socket 127.0.0.1 2834]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
fconfigure $s -buffering line -translation lf
puts $s "hello abcdefghijklmnop"
after 1000
} {{hello abcdefghijklmnop} done}
test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
makeFile {
- set f [socket -server accept 2835]
+ set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
set i 0
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
set timer [after 20000 "set x done"]
vwait x
after cancel $timer
close $f
puts "done $i"
} script
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f
- set s [socket 127.0.0.1 2835]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
fconfigure $s -buffering line
catch {
for {set x 0} {$x < 50} {incr x} {
set x
} {done 50}
test socket-2.9 {socket conflict} {socket stdio} {
- set s [socket -server accept 2828]
+ set s [socket -server accept 0]
removeFile script
- set f [open script w]
- puts -nonewline $f {socket -server accept 2828}
+ set f [open $path(script) w]
+ puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f
after 100
- set x [list [catch {close $f} msg] $msg]
+ set x [list [catch {close $f} msg]]
+ regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number
+ lappend x $msg
close $s
set x
-} {1 {couldn't open socket: address already in use
- while executing
-"socket -server accept 2828"
- (file "script" line 1)}}
+} {1 {couldn't open socket: address already in use}}
test socket-2.10 {close on accept, accepted socket lives} {socket} {
set done 0
set timer [after 20000 "set done timed_out"]
- set ss [socket -server accept 2830]
+ set ss [socket -server accept 0]
proc accept {s a p} {
global ss
close $ss
close $s
set done 1
}
- set cs [socket [info hostname] 2830]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
puts $cs hello
close $cs
vwait done
set sock $s
}
- set s [socket -server accept 2400]
+ set s [socket -server accept 0]
set sock ""
- set s2 [socket 127.0.0.1 2400]
+ set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
test socket-3.1 {socket conflict} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- set f [socket -server accept 2828]
+ set f [socket -server accept 0]
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
gets stdin
close $f
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r+]
+ set f [open "|[list [interpreter] $path(script)]" r+]
gets $f
- set x [list [catch {socket -server accept 2828} msg] \
+ gets $f listen
+ set x [list [catch {socket -server accept $listen} msg] \
$msg]
puts $f bye
close $f
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
set counter 0
- set s [socket -server accept 2828]
+ set s [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
}
puts ready
+ puts [lindex [fconfigure $s -sockname] 2]
vwait x
after cancel $t1
vwait x
puts $x
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r+]
+ set f [open "|[list [interpreter] $path(script)]" r+]
set x [gets $f]
- set s1 [socket 127.0.0.1 2828]
+ gets $f listen
+ set s1 [socket 127.0.0.1 $listen]
fconfigure $s1 -buffering line
- set s2 [socket 127.0.0.1 2828]
+ set s2 [socket 127.0.0.1 $listen]
fconfigure $s2 -buffering line
- set s3 [socket 127.0.0.1 2828]
+ set s3 [socket 127.0.0.1 $listen]
fconfigure $s3 -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s1 hello,s1
test socket-4.1 {server with several clients} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- gets stdin
- set s [socket 127.0.0.1 2828]
+ set port [gets stdin]
+ set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s hello
gets stdin
}
close $f
- set p1 [open "|[list $::tcltest::tcltest script]" r+]
+ set p1 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p1 -buffering line
- set p2 [open "|[list $::tcltest::tcltest script]" r+]
+ set p2 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p2 -buffering line
- set p3 [open "|[list $::tcltest::tcltest script]" r+]
+ set p3 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p3 -buffering line
proc accept {s a p} {
fconfigure $s -buffering line
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
- set s [socket -server accept 2828]
- puts $p1 open
- puts $p2 open
- puts $p3 open
+ set s [socket -server accept 0]
+ set listen [lindex [fconfigure $s -sockname] 2]
+ puts $p1 $listen
+ puts $p2 $listen
+ puts $p3 $listen
vwait x
vwait x
vwait x
test socket-6.1 {accept callback error} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- gets stdin
- socket 127.0.0.1 2848
+ gets stdin port
+ socket 127.0.0.1 $port
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r+]
+ set f [open "|[list [interpreter] $path(script)]" r+]
proc bgerror args {
global x
set x $args
}
proc accept {s a p} {expr 10 / 0}
- set s [socket -server accept 2848]
- puts $f hello
+ set s [socket -server accept 0]
+ puts $f [lindex [fconfigure $s -sockname] 2]
close $f
set timer [after 10000 "set x timed_out"]
vwait x
test socket-7.1 {testing socket specific options} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- socket -server accept 2820
+ set ss [socket -server accept 0]
proc accept args {
global x
set x done
}
puts ready
+ puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f
- set s [socket 127.0.0.1 2820]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -peername]
close $s
close $f
set l ""
lappend l [string compare [lindex $p 0] 127.0.0.1]
- lappend l [string compare [lindex $p 2] 2820]
+ lappend l [string compare [lindex $p 2] $listen]
lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
removeFile script
- set f [open script w]
+ set f [open $path(script) w]
puts $f {
- socket -server accept 2821
+ set ss [socket -server accept 2821]
proc accept args {
global x
set x done
}
puts ready
+ puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
- set f [open "|[list $::tcltest::tcltest script]" r]
+ set f [open "|[list [interpreter] $path(script)]" r]
gets $f
- set s [socket 127.0.0.1 2821]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -sockname]
close $s
close $f
- set l ""
- lappend l [llength $p]
- lappend l [lindex $p 0]
- lappend l [expr [lindex $p 2] == 2821]
-} {3 127.0.0.1 0}
+ list [llength $p] \
+ [regexp {^(127\.0\.0\.1|0\.0\.0\.0)$} [lindex $p 0]] \
+ [expr {[lindex $p 2] == $listen}]
+} {3 1 0}
test socket-7.3 {testing socket specific options} {socket} {
- set s [socket -server accept 2822]
+ set s [socket -server accept 0]
set l [fconfigure $s]
close $s
update
llength $l
-} 12
+} 14
test socket-7.4 {testing socket specific options} {socket} {
- set s [socket -server accept 2823]
+ set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
- set s1 [socket [info hostname] 2823]
+ set listen [lindex [fconfigure $s -sockname] 2]
+ set s1 [socket [info hostname] $listen]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
close $s1
set l ""
- lappend l [lindex $x 2] [llength $x]
-} {2823 3}
+ lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
+} {1 3}
test socket-7.5 {testing socket specific options} {socket unixOrPc} {
- set s [socket -server accept 2829]
+ set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
- set s1 [socket 127.0.0.1 2829]
+ set listen [lindex [fconfigure $s -sockname] 2]
+ set s1 [socket 127.0.0.1 $listen]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
close $s1
set l ""
- lappend l [lindex $x 0] [lindex $x 2] [llength $x]
-} {127.0.0.1 2829 3}
+ lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
+} {127.0.0.1 1 3}
test socket-8.1 {testing -async flag on sockets} {socket} {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does,
# problem, please email jyl@eng.sun.com. We have not observed this
# failure on Solaris 2.5, so another option (instead of installing
# these patches) is to upgrade to Solaris 2.5.
- set s [socket -server accept 2830]
+ set s [socket -server accept 0]
proc accept {s a p} {
global x
puts $s bye
close $s
set x done
}
- set s1 [socket -async [info hostname] 2830]
+ set s1 [socket -async [info hostname] [lindex [fconfigure $s -sockname] 2]]
vwait x
set z [gets $s1]
close $s
fconfigure $s -buffering none -blocking off
fileevent $s readable [list readlittle $s]
}
- set s [socket -server accept 2831]
- set c [socket [info hostname] 2831]
+ set s [socket -server accept 0]
+ set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
puts -nonewline $c 01234567890123456789012345678901234567890123456789
close $c
set timer [after 10000 "set done timed_out"]
for {set i 0} {$i < 16} {incr i} {
set secondblock "b$secondblock$secondblock"
}
- set l [socket -server accept 2832]
+ set l [socket -server accept 0]
proc accept {s a p} {
fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
-buffering line
puts -nonewline $s $secondblock
close $s
}
- set s [socket [info hostname] 2832]
+ set s [socket [info hostname] [lindex [fconfigure $l -sockname] 2]]
fconfigure $s -blocking 0 -trans lf -buffering line
set count 0
puts $s hello
fconfigure $s -buffering line -translation lf
fileevent $s writable "write_then_close $s"
}
- set s [socket -server accept 2833]
- set c [socket [info hostname] 2833]
+ set s [socket -server accept 0]
+ set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
fconfigure $c -blocking off -buffering line -translation lf
fileevent $c readable "count_to_eof $c"
set timer [after 1000 timerproc]
test socket-10.1 {testing socket accept callback error handling} {socket} {
set goterror 0
proc bgerror args {global goterror; set goterror 1}
- set s [socket -server accept 2898]
+ set s [socket -server accept 0]
proc accept {s a p} {close $s; error}
- set c [socket 127.0.0.1 2898]
+ set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
vwait goterror
close $s
close $c
set count
} 65566
-test socket-12.1 {testing inheritance of server sockets} {socket exec} {
+set path(script1) [makeFile {} script1]
+set path(script2) [makeFile {} script2]
+
+test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
removeFile script1
removeFile script2
# Script1 is just a 10 second delay. If the server socket
# is inherited, it will be held open for 10 seconds
- set f [open script1 w]
+ set f [open $path(script1) w]
puts $f {
after 10000 exit
vwait forever
# waits a second, and exits. The server socket will now
# be closed unless script1 inherited it.
- set f [open script2 w]
- puts $f [list set tclsh $::tcltest::tcltest]
- puts $f {
- set f [socket -server accept 2828]
+ set f [open $path(script2) w]
+ puts $f [list set tcltest [interpreter]]
+ puts $f [format {
+ set f [socket -server accept 0]
+ puts [lindex [fconfigure $f -sockname] 2]
proc accept { file addr port } {
close $file
}
- exec $tclsh script1 &
+ exec $tcltest "%s" &
close $f
after 1000 exit
vwait forever
- }
+ } $path(script1)]
close $f
# Launch script2 and wait 5 seconds
- exec $::tcltest::tcltest script2 &
+ ### exec [interpreter] script2 &
+ set p [open "|[list [interpreter] $path(script2)]" r]
+ gets $p listen
+
after 5000 { set ok_to_proceed 1 }
vwait ok_to_proceed
# If we can still connect to the server, the socket got inherited.
- if {[catch {socket 127.0.0.1 2828} msg]} {
+ if {[catch {socket 127.0.0.1 $listen} msg]} {
set x {server socket was not inherited}
} else {
close $msg
removeFile script1
removeFile script2
+ close $p
set x
} {server socket was not inherited}
-test socket-12.2 {testing inheritance of client sockets} {socket exec} {
+test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
removeFile script1
removeFile script2
- # Script1 is just a 10 second delay. If the server socket
+ # Script1 is just a 20 second delay. If the server socket
# is inherited, it will be held open for 10 seconds
- set f [open script1 w]
+ set f [open $path(script1) w]
puts $f {
- after 10000 exit
+ after 20000 exit
vwait forever
}
close $f
# launches script1 and exits. If the child process inherited the
# client socket, the socket will still be open.
- set f [open script2 w]
- puts $f [list set tclsh $::tcltest::tcltest]
- puts $f {
- set f [socket 127.0.0.1 2829]
- exec $tclsh script1 &
+ set f [open $path(script2) w]
+ puts $f [list set tcltest [interpreter]]
+ puts $f [format {
+ gets stdin port
+ set f [socket 127.0.0.1 $port]
+ exec $tcltest "%s" &
puts $f testing
flush $f
after 1000 exit
vwait forever
- }
+ } $path(script1)]
close $f
# Create the server socket
- set server [socket -server accept 2829]
+ set server [socket -server accept 0]
proc accept { file host port } {
# When the client connects, establish the read handler
global server
return
}
- # If the socket doesn't hit end-of-file in 5 seconds, the
+ # If the socket doesn't hit end-of-file in 10 seconds, the
# script1 process must have inherited the client.
set failed 0
- after 5000 [list set failed 1]
+ after 10000 [list set failed 1]
# Launch the script2 process
+ ### exec [interpreter] script2 &
- exec $::tcltest::tcltest script2 &
+ set p [open "|[list [interpreter] $path(script2)]" w]
+ puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
vwait x
if {!$failed} {
}
removeFile script1
removeFile script2
+ close $p
set x
} {client socket was not inherited}
-test socket-12.3 {testing inheritance of accepted sockets} {socket exec} {
+test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
removeFile script1
removeFile script2
- set f [open script1 w]
+ set f [open $path(script1) w]
puts $f {
after 10000 exit
vwait forever
}
close $f
- set f [open script2 w]
- puts $f [list set tclsh $::tcltest::tcltest]
- puts $f {
- set server [socket -server accept 2931]
+ set f [open $path(script2) w]
+ puts $f [list set tcltest [interpreter]]
+ puts $f [format {
+ set server [socket -server accept 0]
+ puts stdout [lindex [fconfigure $server -sockname] 2]
proc accept { file host port } {
- global tclsh
+ global tcltest
puts $file {test data on socket}
- exec $tclsh script1 &
+ exec $tcltest "%s" &
after 1000 exit
}
vwait forever
- }
+ } $path(script1)]
close $f
# Launch the script2 process and connect to it. See how long
# the socket stays open
- exec $::tcltest::tcltest script2 &
+ ## exec [interpreter] script2 &
+ set p [open "|[list [interpreter] $path(script2)]" r]
+ gets $p listen
after 1000 set ok_to_proceed 1
vwait ok_to_proceed
- set f [socket 127.0.0.1 2931]
+ set f [socket 127.0.0.1 $listen]
fconfigure $f -buffering full -blocking 0
fileevent $f readable [list getdata $f]
removeFile script1
removeFile script2
+ close $p
set x
} {accepted socket was not inherited}
threadReap
makeFile {
- set f [socket -server accept 2828]
+ set f [socket -server accept 0]
+ set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
# create a thread
set serverthread [testthread create { source script } ]
update
-
+ set port [testthread send $serverthread {set listen}]
+ update
+
after 1000
- set s [socket 127.0.0.1 2828]
+ set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
catch {
::tcltest::cleanupTests
flush stdout
return
-
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace import -force ::tcltest::*
}
+set sourcefile [makeFile "" source.file]
test source-1.1 {source command} {
set x "old x value"
set y "old y value"
set y 33
set z 44
} source.file
- source source.file
+ source $sourcefile
list $x $y $z
} {22 33 44}
test source-1.2 {source command} {
makeFile {list result} source.file
- source source.file
+ source $sourcefile
} result
test source-1.3 {source command} {
set y {\ }
- set fd [open source.file w]
+ set fd [open $sourcefile w]
fconfigure $fd -translation lf
puts -nonewline $fd "list a b c "
puts $fd [string index $y 0]
puts $fd "d e f"
close $fd
- source source.file
+ source $sourcefile
} {a b c d e f}
test source-2.3 {source error conditions} {
error "error in sourced file"
set y $x
} source.file
- list [catch {source source.file} msg] $msg $errorInfo
-} {1 {error in sourced file} {error in sourced file
+ list [catch {source $sourcefile} msg] $msg $errorInfo
+} [list 1 {error in sourced file} "error in sourced file
while executing
-"error "error in sourced file""
- (file "source.file" line 3)
+\"error \"error in sourced file\"\"
+ (file \"$sourcefile\" line 3)
invoked from within
-"source source.file"}}
+\"source \$sourcefile\""]
test source-2.4 {source error conditions} {
makeFile {break} source.file
- catch {source source.file}
+ catch {source $sourcefile}
} 3
test source-2.5 {source error conditions} {
makeFile {continue} source.file
- catch {source source.file}
+ catch {source $sourcefile}
} 4
test source-2.6 {source error conditions} {
normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode]
} source.file
set x old-x
set y old-y
- set z [source source.file]
+ set z [source $sourcefile]
list $x $y $z
} {new-x old-y allDone}
test source-3.2 {return with special code etc.} {
return -code break "Silly result"
set y new-y
} source.file
- list [catch {source source.file} msg] $msg
+ list [catch {source $sourcefile} msg] $msg
} {3 {Silly result}}
test source-3.3 {return with special code etc.} {
makeFile {
return -code error "Simulated error"
set y new-y
} source.file
- list [catch {source source.file} msg] $msg $errorInfo $errorCode
+ list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {Simulated error} {Simulated error
while executing
-"source source.file"} NONE}
+"source $sourcefile"} NONE}
test source-3.4 {return with special code etc.} {
makeFile {
set x new-x
return -code error -errorinfo "Simulated errorInfo stuff"
set y new-y
} source.file
- list [catch {source source.file} msg] $msg $errorInfo $errorCode
+ list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {} {Simulated errorInfo stuff
invoked from within
-"source source.file"} NONE}
+"source $sourcefile"} NONE}
test source-3.5 {return with special code etc.} {
makeFile {
set x new-x
-errorcode {a b c}
set y new-y
} source.file
- list [catch {source source.file} msg] $msg $errorInfo $errorCode
+ list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {} {Simulated errorInfo stuff
invoked from within
-"source source.file"} {a b c}}
+"source $sourcefile"} {a b c}}
# Test for the Macintosh specfic features of the source command
test source-4.1 {source error conditions} {macOnly} {
} [list 1 "Error finding the file: \"bad_file\"."]
test source-5.2 {source resource files} {macOnly} {
makeFile {return} source.file
- list [catch {source -rsrc rsrcName source.file} msg] $msg
-} [list 1 "Error reading the file: \"source.file\"."]
+ list [catch {source -rsrc rsrcName $sourcefile} msg] $msg
+} [list 1 "Error reading the file: \"$sourcefile\"."]
test source-5.3 {source resource files} {macOnly} {
testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return}
set result [catch {source -rsrc rsrcName rsrc.file} msg]
test source-6.1 {source is binary ok} {
set x {}
makeFile [list set x "a b\0c"] source.file
- source source.file
+ source $sourcefile
string length $x
} 5
+test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} {
+ set x {}
+ makeFile [list set x "ab\32c"] source.file
+ source $sourcefile
+ string length $x
+} 2
# cleanup
catch {::tcltest::removeFile source.file}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
# cleanup
+catch {rename foo {}}
::tcltest::cleanupTests
return
-
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that a failure in this test results in a crash of the executable.
+# In order to avoid that, we do a basic check of the current stacksize.
+# This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh).
-test stack-1.1 {maxNestingDepth reached on infinite recursion} {
+# This doesn't catch all cases, for example threads of lower stacksize
+# can still squeak through. A core check is really needed. -- JH
+
+if {[string equal $::tcl_platform(platform) "unix"]} {
+ set stackSize [exec /bin/sh -c "ulimit -s"]
+ if {[string is integer $stackSize] && ($stackSize < 2400)} {
+ puts stderr "WARNING: the default application stacksize of $stackSize\
+ may cause Tcl to\ncrash due to stack overflow before the\
+ recursion limit is reached.\nA minimum stacksize of 2400\
+ kbytes is recommended.\nSkipping infinite recursion test."
+ ::tcltest::testConstraint minStack2400 0
+ } else {
+ ::tcltest::testConstraint minStack2400 1
+ }
+} else {
+ ::tcltest::testConstraint minStack2400 1
+}
+
+test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
proc recurse {} { return [recurse] }
catch {recurse} rv
rename recurse {}
set rv
-} {too many nested calls to Tcl_EvalObj (infinite loop?)}
+} {too many nested evaluations (infinite loop?)}
+
+test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
+ # do this in a slave to not mess with parent
+ set slave stack-2.1
+ interp create $slave
+ $slave eval { interp alias {} unknown {} notaknownproc }
+ set msg [$slave eval { catch {foo} msg ; set msg }]
+ interp delete $slave
+ set msg
+} {too many nested evaluations (infinite loop?)}
# cleanup
::tcltest::cleanupTests
return
-
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
test string-2.27 {string compare -nocase, null strings} {
string compare -nocase foo ""
} 1
-test string-2.28 {string equal with length, unequal strings} {
+test string-2.28 {string compare with length, unequal strings} {
string compare -length 2 abc abde
} 0
-test string-2.29 {string equal with length, unequal strings} {
+test string-2.29 {string compare with length, unequal strings} {
string compare -length 2 ab abde
} 0
+test string-2.30 {string compare with NUL character vs. other ASCII} {
+ # Be careful here, since UTF-8 rep comparison with memcmp() of
+ # these puts chars in the wrong order
+ string compare \x00 \x01
+} -1
+test string-2.31 {string compare, high bit} {
+ proc foo {} {string compare "a\x80" "a@"}
+ foo
+} 1
+test string-2.32 {string compare, high bit} {
+ proc foo {} {string compare "a\x00" "a\x01"}
+ foo
+} -1
+test string-2.33 {string compare, high bit} {
+ proc foo {} {string compare "\x00\x00" "\x00\x01"}
+ foo
+} -1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
test string-4.1 {string first, too few args} {
list [catch {string first a} msg] $msg
-} {1 {wrong # args: should be "string first string1 string2 ?startIndex?"}}
+} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.2 {string first, bad args} {
list [catch {string first a b c} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test string-4.3 {string first, too many args} {
list [catch {string first a b 5 d} msg] $msg
-} {1 {wrong # args: should be "string first string1 string2 ?startIndex?"}}
+} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test string-4.4 {string first} {
string first bq abcdefgbcefgbqrs
} 12
test string-4.13 {string first, start index} {
string first \u7266 abc\u7266x end-2
} 3
-test string-4.14 {string first, start index} {
- string first a abcabc end-4
-} 3
+test string-4.14 {string first, negative start index} {
+ string first b abc -1
+} 1
test string-5.1 {string index} {
list [catch {string index} msg] $msg
} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}}
test string-5.18 {string index, bad integer} {
list [catch {string index "abc" end-00289} msg] $msg
-} {1 {expected integer but got "-00289" (looks like invalid octal number)}}
+} {1 {bad index "end-00289": must be integer or end?-integer? (looks like invalid octal number)}}
+test string-5.19 {string index, bytearray object out of bounds} {
+ string index [binary format I* {0x50515253 0x52}] -1
+} {}
+test string-5.20 {string index, bytearray object out of bounds} {
+ string index [binary format I* {0x50515253 0x52}] 20
+} {}
proc largest_int {} {
# so we can test for overflow properly below on >32 bit systems
set int 1
set exp 7; # assume we get at least 8 bits
- while {$int > 0} { set int [expr {1 << [incr exp]}] }
+ while {$int > 0} { set int [expr {wide(1) << [incr exp]}] }
return [expr {$int-1}]
}
test string-7.1 {string last, too few args} {
list [catch {string last a} msg] $msg
-} {1 {wrong # args: should be "string last string1 string2 ?startIndex?"}}
+} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.2 {string last, bad args} {
list [catch {string last a b c} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test string-7.3 {string last, too many args} {
list [catch {string last a b c d} msg] $msg
-} {1 {wrong # args: should be "string last string1 string2 ?startIndex?"}}
+} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.4 {string last} {
string la xxx xxxx123xx345x678
} 1
test string-10.14 {string map, -nocase null arguments} {
string map -nocase {{} abc} foo
} foo
+test string-10.15 {string map, one pair case} {
+ string map -nocase {abc 32} aAbCaBaAbAbcAb
+} {a32aBaAb32Ab}
+test string-10.16 {string map, one pair case} {
+ string map -nocase {ab 4321} aAbCaBaAbAbcAb
+} {a4321C4321a43214321c4321}
+test string-10.17 {string map, one pair case} {
+ string map {Ab 4321} aAbCaBaAbAbcAb
+} {a4321CaBa43214321c4321}
+test string-10.18 {string map, empty argument} {
+ string map -nocase {{} abc} foo
+} foo
+test string-10.19 {string map, empty arguments} {
+ string map -nocase {{} abc f bar {} def} foo
+} baroo
test string-11.1 {string match, too few args} {
list [catch {string match a} msg] $msg
test string-11.38 {string match case, reverse range} {
string match {[A-fh-Z]} g
} 1
+test string-11.39 {string match, *\ case} {
+ string match {*\abc} abc
+} 1
+test string-11.40 {string match, *special case} {
+ string match {*[ab]} abc
+} 0
+test string-11.41 {string match, *special case} {
+ string match {*[ab]*} abc
+} 1
+test string-11.42 {string match, *special case} {
+ string match "*\\" "\\"
+} 0
+test string-11.43 {string match, *special case} {
+ string match "*\\\\" "\\"
+} 1
+test string-11.44 {string match, *special case} {
+ string match "*???" "12345"
+} 1
+test string-11.45 {string match, *special case} {
+ string match "*???" "12"
+} 0
+test string-11.46 {string match, *special case} {
+ string match "*\\*" "abc*"
+} 1
+test string-11.47 {string match, *special case} {
+ string match "*\\*" "*"
+} 1
+test string-11.48 {string match, *special case} {
+ string match "*\\*" "*abc"
+} 0
+test string-11.49 {string match, *special case} {
+ string match "?\\*" "a*"
+} 1
+test string-11.50 {string match, *special case} {
+ string match "\\" "\\"
+} 0
+test string-11.51 {string match; *, -nocase and UTF-8} {
+ string match -nocase [binary format I 717316707] \
+ [binary format I 2028036707]
+} 1
+
test string-12.1 {string range} {
list [catch {string range} msg] $msg
set b [binary format I* {0x50515253 0x52}]
set r1 [string range $b 1 end-1]
set r2 [string range $b 1 6]
- string compare $r1 $r2
-} 0
+ string equal $r1 $r2
+} 1
test string-12.20 {string range, out of bounds indices} {
string range \u00ff 0 1
} \u00ff
test string-13.7 {string repeat} {
list [catch {string repeat abc end} msg] $msg
} {1 {expected integer but got "end"}}
+test string-13.8 {string repeat} {
+ string repeat {} -1000
+} {}
+test string-13.9 {string repeat} {
+ string repeat {} 0
+} {}
+test string-13.10 {string repeat} {
+ string repeat def 0
+} {}
+test string-13.11 {string repeat} {
+ string repeat def 1
+} def
+test string-13.12 {string repeat} {
+ string repeat ab\u7266cd 3
+} ab\u7266cdab\u7266cdab\u7266cd
+test string-13.13 {string repeat} {
+ string repeat \x00 3
+} \x00\x00\x00
+test string-13.14 {string repeat} {
+ # The string range will ensure us that string repeat gets a unicode string
+ string repeat [string range ab\u7266cd 2 3] 3
+} \u7266c\u7266c\u7266c
test string-14.1 {string replace} {
list [catch {string replace} msg] $msg
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
test subst-1.2 {basics} {
list [catch {subst a b c} msg] $msg
-} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
+} {1 {bad switch "a": must be -nobackslashes, -nocommands, or -novariables}}
test subst-2.1 {simple strings} {
subst {}
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
} "x\$x\[foo bar]\\"
+test subst-3.2 {backslash substitutions with utf chars} {
+ # 'j' is just a char that doesn't mean anything, and \344 is 'ä'
+ # that also doesn't mean anything, but is multi-byte in UTF-8.
+ list [subst \j] [subst \\j] [subst \\344] [subst \\\344]
+} "j j \344 \344"
test subst-4.1 {variable substitutions} {
set a 44
test subst-5.4 {command substitutions} {
list [catch {subst {$long [set long] [bogus_command]}} msg] $msg
} {1 {invalid command name "bogus_command"}}
+test subst-5.5 {command substitutions} {
+ set a 0
+ list [catch {subst {[set a 1}} msg] $a $msg
+} {1 0 {missing close-bracket}}
+test subst-5.6 {command substitutions} {
+ set a 0
+ list [catch {subst {0[set a 1}} msg] $a $msg
+} {1 0 {missing close-bracket}}
+test subst-5.7 {command substitutions} {
+ set a 0
+ list [catch {subst {0[set a 1; set a 2}} msg] $a $msg
+} {1 1 {missing close-bracket}}
+
+# repeat the tests above simulating cmd line input
+test subst-5.8 {command substitutions} {
+ set script {[subst {[set a 1}]}
+ list [catch {exec [info nameofexecutable] << $script} msg] $msg
+} {1 {missing close-bracket}}
+test subst-5.9 {command substitutions} {
+ set script {[subst {0[set a 1}]}
+ list [catch {exec [info nameofexecutable] << $script} msg] $msg
+} {1 {missing close-bracket}}
+test subst-5.10 {command substitutions} {
+ set script {[subst {0[set a 1; set a 2}]}
+ list [catch {exec [info nameofexecutable] << $script} msg] $msg
+} {1 {missing close-bracket}}
test subst-6.1 {clear the result after command substitution} {
catch {unset a}
test subst-7.1 {switches} {
list [catch {subst foo bar} msg] $msg
-} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}}
+} {1 {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables}}
test subst-7.2 {switches} {
list [catch {subst -no bar} msg] $msg
} {1 {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}}
subst -nov -nob -noc {abc $x [expr 1+2] \\\x41}
} {abc $x [expr 1+2] \\\x41}
+test subst-8.1 {return in a subst} {
+ subst {foo [return {x}; bogus code] bar}
+} {foo x bar}
+test subst-8.2 {return in a subst} {
+ subst {foo [return x ; bogus code] bar}
+} {foo x bar}
+test subst-8.3 {return in a subst} {
+ subst {foo [if 1 { return {x}; bogus code }] bar}
+} {foo x bar}
+test subst-8.4 {return in a subst} {
+ subst {[eval {return hi}] there}
+} {hi there}
+test subst-8.5 {return in a subst} {
+ subst {foo [return {]}; bogus code] bar}
+} {foo ] bar}
+test subst-8.6 {return in a subst} {
+ subst {foo [return {x}; bogus code bar}
+} {foo x}
+test subst-8.7 {return in a subst, parse error} {
+ subst {foo [return {x} ; set a {}" ; stuff] bar}
+} {foo xset a {}" ; stuff] bar}
+test subst-8.8 {return in a subst, parse error} {
+ subst {foo [return {x} ; set bar baz ; set a {}" ; stuff] bar}
+} {foo xset bar baz ; set a {}" ; stuff] bar}
+test subst-8.9 {return in a variable subst} {
+ subst {foo $var([return {x}]) bar}
+} {foo x bar}
+
+test subst-9.1 {error in a subst} {
+ list [catch {subst {[error foo; bogus code]bar}} msg] $msg
+} {1 foo}
+test subst-9.2 {error in a subst} {
+ list [catch {subst {[if 1 { error foo; bogus code}]bar}} msg] $msg
+} {1 foo}
+test subst-9.3 {error in a variable subst} {
+ list [catch {subst {foo $var([error foo]) bar}} msg] $msg
+} {1 foo}
+
+test subst-10.1 {break in a subst} {
+ subst {foo [break; bogus code] bar}
+} {foo }
+test subst-10.2 {break in a subst} {
+ subst {foo [break; return x; bogus code] bar}
+} {foo }
+test subst-10.3 {break in a subst} {
+ subst {foo [if 1 { break; bogus code}] bar}
+} {foo }
+test subst-10.4 {break in a subst, parse error} {
+ subst {foo [break ; set a {}{} ; stuff] bar}
+} {foo }
+test subst-10.5 {break in a subst, parse error} {
+ subst {foo [break ;set bar baz ;set a {}{} ; stuff] bar}
+} {foo }
+test subst-10.6 {break in a variable subst} {
+ subst {foo $var([break]) bar}
+} {foo }
+
+test subst-11.1 {continue in a subst} {
+ subst {foo [continue; bogus code] bar}
+} {foo bar}
+test subst-11.2 {continue in a subst} {
+ subst {foo [continue; return x; bogus code] bar}
+} {foo bar}
+test subst-11.3 {continue in a subst} {
+ subst {foo [if 1 { continue; bogus code}] bar}
+} {foo bar}
+test subst-11.4 {continue in a subst, parse error} {
+ subst {foo [continue ; set a {}{} ; stuff] bar}
+} {foo set a {}{} ; stuff] bar}
+test subst-11.5 {continue in a subst, parse error} {
+ subst {foo [continue ;set bar baz ;set a {}{} ; stuff] bar}
+} {foo set bar baz ;set a {}{} ; stuff] bar}
+test subst-11.6 {continue in a variable subst} {
+ subst {foo $var([continue]) bar}
+} {foo bar}
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
c -
}
} msg] $msg
-} {1 {no body specified for pattern "a"}}
+} {1 {no body specified for pattern "c"}}
test switch-7.3 {"-" bodies} {
list [catch {
switch a {
c -
}
} msg] $msg
-} {1 {invalid command name "-foo"}}
+} {1 {no body specified for pattern "c"}}
test switch-8.1 {empty body} {
set msg {}
}
} {}
+test switch-9.1 {empty pattern/body list} {
+ list [catch {switch x} msg] $msg
+} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
+test switch-9.2 {empty pattern/body list} {
+ list [catch {switch -- x} msg] $msg
+} {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}}
+test switch-9.3 {empty pattern/body list} {
+ list [catch {switch x {}} msg] $msg
+} {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}}
+test switch-9.4 {empty pattern/body list} {
+ list [catch {switch -- x {}} msg] $msg
+} {1 {wrong # args: should be "switch ?switches? string {pattern body ... ?default body?}"}}
+test switch-9.5 {unpaired pattern} {
+ list [catch {switch x a {} b} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.6 {unpaired pattern} {
+ list [catch {switch x {a {} b}} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.7 {unpaired pattern} {
+ list [catch {switch x a {} # comment b} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.8 {unpaired pattern} {
+ list [catch {switch x {a {} # comment b}} msg] $msg
+} {1 {extra switch pattern with no body, this may be due to a comment incorrectly placed outside of a switch body - see the "switch" documentation}}
+test switch-9.9 {unpaired pattern} {
+ list [catch {switch x a {} x {} # comment b} msg] $msg
+} {1 {extra switch pattern with no body}}
+test switch-9.10 {unpaired pattern} {
+ list [catch {switch x {a {} x {} # comment b}} msg] $msg
+} {1 {extra switch pattern with no body, this may be due to a comment incorrectly placed outside of a switch body - see the "switch" documentation}}
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-# Command line options covered:
-# -help, -verbose, -match, -skip, -file, -notfile, -constraints,
-# -limitconstraints, -preservecore, -tmpdir, -debug, -outfile,
-# -errfile, -args
-#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
+# Note that there are several places where the value of
+# tcltest::currentFailure is stored/reset in the -setup/-cleanup
+# of a test that has a body that runs [test] that will fail.
+# This is a workaround of using the same tcltest code that we are
+# testing to run the test itself. Ditto on things like [verbose].
+#
+# It would be better to have the -body of the tests run the tcltest
+# commands in a slave interp so the [test] being tested would not
+# interfere with the [test] doing the testing.
+#
+
+if {[catch {package require tcltest 2.1}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
+ return
}
+namespace eval ::tcltest::test {
+
+namespace import ::tcltest::*
+
makeFile {
package require tcltest
- namespace import -force ::tcltest::*
+ namespace import ::tcltest::test
test a-1.0 {test a} {
list 0
} {0}
} {0}
test c-1.0 {test c} {knownBug} {
} {}
- ::tcltest::cleanupTests
+ test d-1.0 {test d} {
+ error "foo" foo 9
+ } {}
+ tcltest::cleanupTests
exit
} test.tcl
+cd [temporaryDirectory]
+testConstraint exec [llength [info commands exec]]
# test -help
-test tcltest-1.1 {tcltest -help} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -help} msg]
- set result [catch {runCmd $cmd}]
+# Child processes because -help [exit]s.
+test tcltest-1.1 {tcltest -help} {exec} {
+ set result [catch {exec [interpreter] test.tcl -help} msg]
list $result [regexp Usage $msg]
} {1 1}
-test tcltest-1.2 {tcltest -help -something} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -help -something} msg]
+test tcltest-1.2 {tcltest -help -something} {exec} {
+ set result [catch {exec [interpreter] test.tcl -help -something} msg]
list $result [regexp Usage $msg]
} {1 1}
-test tcltest-1.3 {tcltest -h} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -h} msg]
+test tcltest-1.3 {tcltest -h} {exec} {
+ set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
-} {1 1}
+} {1 0}
+
+# -verbose, implicit & explicit testing of [verbose]
+proc slave {msgVar args} {
+ upvar 1 $msgVar msg
+
+ interp create [namespace current]::i
+ # Fake the slave interp into dumping output to a file
+ i eval {namespace eval ::tcltest {}}
+ i eval "set tcltest::outputChannel \[open [makeFile {} output] w]"
+ i eval "set tcltest::errorChannel \[open [makeFile {} error] w]"
+ i eval [list set argv0 [lindex $args 0]]
+ i eval [list set argv [lrange $args 1 end]]
+ i eval [list package ifneeded tcltest [package provide tcltest] \
+ [package ifneeded tcltest [package provide tcltest]]]
+ i eval {proc exit args {}}
+
+ # Need to capture output in msg
-# -verbose
+ set code [catch {i eval {source $argv0}} foo]
+if $code {
+#puts "$code: $foo\n$::errorInfo"
+}
+ i eval {close $tcltest::outputChannel}
+ interp delete [namespace current]::i
+ set f [open [file join [temporaryDirectory] output]]
+ set msg [read -nonewline $f]
+ close $f
+ set f [open [file join [temporaryDirectory] error]]
+ set err [read -nonewline $f]
+ close $f
+ if {[string length $err]} {
+ set code 1
+ append msg \n$err
+ }
+ return $code
+
+# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg]
+}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl} msg]
+ set result [slave msg test.tcl]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
-test tcltest-2.1 {tcltest -v 'b'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -v 'b'} msg]
+test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
+ set result [slave msg test.tcl -verbose 'b']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
-test tcltest-2.2 {tcltest -v 'p'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -v 'p'} msg]
+test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
+ set result [slave msg test.tcl -verbose 'p']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
-test tcltest-2.3 {tcltest -v 's'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -v 's'} msg]
+test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
+ set result [slave msg test.tcl -verbose 's']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
-test tcltest-2.4 {tcltest -v 'ps'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -verbose 'ps'} msg]
+test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
+ set result [slave msg test.tcl -verbose 'ps']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
-test tcltest-2.5 {tcltest -v 'psb'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -v 'psb'} msg]
+test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
+ set result [slave msg test.tcl -verbose 'psb']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
-# -match
+test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
+ set result [slave msg test.tcl -verbose "pass skip body"]
+ list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
+ [regexp c-1.0 $msg] \
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
+} {0 1 1 1 1}
+
+test tcltest-2.6 {tcltest -verbose 't'} {
+ -constraints {unixOrPc}
+ -body {
+ set result [slave msg test.tcl -verbose 't']
+ list $result $msg
+ }
+ -result {^0 .*a-1.0 start.*b-1.0 start}
+ -match regexp
+}
+
+test tcltest-2.6a {tcltest -verbose 'start'} {
+ -constraints {unixOrPc}
+ -body {
+ set result [slave msg test.tcl -verbose start]
+ list $result $msg
+ }
+ -result {^0 .*a-1.0 start.*b-1.0 start}
+ -match regexp
+}
+
+test tcltest-2.7 {tcltest::verbose} {
+ -body {
+ set oldVerbosity [verbose]
+ verbose bar
+ set currentVerbosity [verbose]
+ verbose foo
+ set newVerbosity [verbose]
+ verbose $oldVerbosity
+ list $currentVerbosity $newVerbosity
+ }
+ -result {body {}}
+}
+
+test tcltest-2.8 {tcltest -verbose 'error'} {
+ -constraints {unixOrPc}
+ -body {
+ set result [slave msg test.tcl -verbose error]
+ list $result $msg
+ }
+ -result {errorInfo: foo.*errorCode: 9}
+ -match regexp
+}
+# -match, [match]
test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -match a* -v 'ps'} msg]
+ set result [slave msg test.tcl -match a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -m b* -v 'ps'} msg]
+ set result [slave msg test.tcl -match b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -match c* -v 'ps'} msg]
+ set result [slave msg test.tcl -match c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg]
+ [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -v 'ps'} msg]
+ set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 1 0 1}
-# -skip
+test tcltest-3.5 {tcltest::match} {
+ -body {
+ set oldMatch [match]
+ match foo
+ set currentMatch [match]
+ match bar
+ set newMatch [match]
+ match $oldMatch
+ list $currentMatch $newMatch
+ }
+ -result {foo bar}
+}
+
+# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -skip a* -v 'ps'} msg]
+ set result [slave msg test.tcl -skip a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -s b* -v 'ps'} msg]
+ set result [slave msg test.tcl -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -skip c* -v 'ps'} msg]
+ set result [slave msg test.tcl -skip c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+1.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -skip {a* b*} -v 'ps'} msg]
+ set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+0.+Skipped.+3.+Failed.+0" $msg]
+ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -match {a* b*} -skip b* -v 'ps'} msg]
+ set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
-# -constraints, -limitconstraints
+test tcltest-4.6 {tcltest::skip} {
+ -body {
+ set oldSkip [skip]
+ skip foo
+ set currentSkip [skip]
+ skip bar
+ set newSkip [skip]
+ skip $oldSkip
+ list $currentSkip $newSkip
+ }
+ -result {foo bar}
+}
+
+# -constraints, -limitconstraints, [testConstraint],
+# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -v 'ps'} msg]
+ set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+2.+Skipped.+0.+Failed.+1" $msg]
+ [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
-test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest test.tcl -constraints knownBug -v 'p' -limitconstraints 1} msg]
+test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
+ set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
- [regexp "Total.+3.+Passed.+1.+Skipped.+2.+Failed.+0" $msg]
+ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}
-makeFile {
+test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
+ -body {
+ set r1 [testConstraint tcltestFakeConstraint]
+ set r2 [testConstraint tcltestFakeConstraint 4]
+ set r3 [testConstraint tcltestFakeConstraint]
+ list $r1 $r2 $r3
+ }
+ -result {0 4 4}
+ -cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)}
+}
+
+# Removed this test of internals of tcltest. Those internals have changed.
+#test tcltest-5.4 {tcltest::constraintsSpecified} {
+# -setup {
+# set constraintlist $::tcltest::constraintsSpecified
+# set ::tcltest::constraintsSpecified {}
+# }
+# -body {
+# set r1 $::tcltest::constraintsSpecified
+# testConstraint tcltestFakeConstraint1 1
+# set r2 $::tcltest::constraintsSpecified
+# testConstraint tcltestFakeConstraint2 1
+# set r3 $::tcltest::constraintsSpecified
+# list $r1 $r2 $r3
+# }
+# -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
+# -cleanup {
+# set ::tcltest::constraintsSpecified $constraintlist
+# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
+# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
+# }
+#}
+
+test tcltest-5.5 {InitConstraints: list of built-in constraints} \
+ -constraints {!singleTestInterp} \
+ -setup {tcltest::InitConstraints} \
+ -body { lsort [array names ::tcltest::testConstraints] } \
+ -result [lsort {
+ 95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive
+ knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles
+ nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket
+ stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs
+ unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly
+}]
+
+# Removed this broken test. Its usage of [limitConstraints] was not
+# in agreement with the documentation. [limitConstraints] is supposed
+# to take an optional boolean argument, and "knownBug" ain't no boolean!
+#test tcltest-5.6 {tcltest::limitConstraints} {
+# -setup {
+# set keeplc $::tcltest::limitConstraints
+# set keepkb [testConstraint knownBug]
+# }
+# -body {
+# set r1 [limitConstraints]
+# set r2 [limitConstraints knownBug]
+# set r3 [limitConstraints]
+# list $r1 $r2 $r3
+# }
+# -cleanup {
+# limitConstraints $keeplc
+# testConstraint knownBug $keepkb
+# }
+# -result {false knownBug knownBug}
+#}
+
+# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
+set printerror [makeFile {
package require tcltest
- namespace import -force ::tcltest::*
- puts $::tcltest::outputChannel "a test"
+ namespace import ::tcltest::*
+ puts [outputChannel] "a test"
::tcltest::PrintError "a really short string"
::tcltest::PrintError "a really really really really really really long \
string containing \"quotes\" and other bad bad stuff"
\"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
-} printerror.tcl
+} printerror.tcl]
-# -outfile, -errfile
-test tcltest-6.1 {tcltest -outfile, -errfile defaults} {unixOrPc} {
- catch {exec $::tcltest::tcltest printerror.tcl} msg
- list [regexp "a test" $msg] [regexp "a really" $msg]
-} {1 1}
-test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc} {
- catch {exec $::tcltest::tcltest printerror.tcl -outfile a.tmp} msg
+test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
+ -constraints unixOrPc
+ -body {
+ slave msg $printerror
+ return $msg
+ }
+ -result {a test.*a really}
+ -match regexp
+}
+test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
+ slave msg $printerror -outfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
-test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc} {
- catch {exec $::tcltest::tcltest printerror.tcl -errfile a.tmp} msg
+test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
+ slave msg $printerror -errfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
-test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc} {
- catch {exec $::tcltest::tcltest printerror.tcl -o a.tmp -e b.tmp} msg
+test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
+ slave msg printerror.tcl -outfile a.tmp -errfile b.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" b.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
[file exists b.tmp] [file delete b.tmp]
} {0 0 0 0 1 {} 1 {}}
-# -debug
-test tcltest-7.1 {tcltest test.tcl -d 0} {unixOrPc} {
- catch {exec $::tcltest::tcltest test.tcl -d 0} msg
+test tcltest-6.5 {tcltest::errorChannel - retrieval} {
+ -setup {
+ set of [errorChannel]
+ set ::tcltest::errorChannel stderr
+ }
+ -body {
+ errorChannel
+ }
+ -result {stderr}
+ -cleanup {
+ set ::tcltest::errorChannel $of
+ }
+}
+
+test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} {
+ -setup {
+ set ef [makeFile {} efile]
+ set of [errorFile]
+ set ::tcltest::errorChannel stderr
+ set ::tcltest::errorFile stderr
+ }
+ -body {
+ set f0 [errorChannel]
+ set f1 [errorFile]
+ set f2 [errorFile $ef]
+ set f3 [errorChannel]
+ set f4 [errorFile]
+ subst {$f0;$f1;$f2;$f3;$f4}
+ }
+ -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile}
+ -match regexp
+ -cleanup {
+ errorFile $of
+ }
+}
+test tcltest-6.7 {tcltest::outputChannel - retrieval} {
+ -setup {
+ set of [outputChannel]
+ set ::tcltest::outputChannel stdout
+ }
+ -body {
+ outputChannel
+ }
+ -result {stdout}
+ -cleanup {
+ set tcltest::outputChannel $of
+ }
+}
+
+test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
+ -setup {
+ set ef [makeFile {} efile]
+ set of [outputFile]
+ set ::tcltest::outputChannel stdout
+ set ::tcltest::outputFile stdout
+ }
+ -body {
+ set f0 [outputChannel]
+ set f1 [outputFile]
+ set f2 [outputFile $ef]
+ set f3 [outputChannel]
+ set f4 [outputFile]
+ subst {$f0;$f1;$f2;$f3;$f4}
+ }
+ -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile}
+ -match regexp
+ -cleanup {
+ outputFile $of
+ }
+}
+
+# -debug, [debug]
+# Must use child processes to test -debug because it always writes
+# messages to stdout, and we have no way to capture stdout of a
+# slave interp
+test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
+ catch {exec [interpreter] test.tcl -debug 0} msg
regexp "Flags passed into tcltest" $msg
} {0}
-test tcltest-7.2 {tcltest test.tcl -d 1} {unixOrPc} {
- catch {exec $::tcltest::tcltest test.tcl -d 1 -s b*} msg
+test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
+ catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
list [regexp userSpecifiedSkip $msg] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
-test tcltest-7.3 {tcltest test.tcl -d 1} {unixOrPc} {
- catch {exec $::tcltest::tcltest test.tcl -d 1 -m b*} msg
+test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
+ catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
list [regexp userSpecifiedNonMatch $msg] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
-test tcltest-7.4 {tcltest test.tcl -d 2} {unixOrPc} {
- catch {exec $::tcltest::tcltest test.tcl -d 2} msg
+test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
+ catch {exec [interpreter] test.tcl -debug 2} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 0}
-test tcltest-7.5 {tcltest test.tcl -d 3} {unixOrPc} {
- catch {exec $::tcltest::tcltest test.tcl -d 3} msg
+test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
+ catch {exec [interpreter] test.tcl -debug 3} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 1}
+test tcltest-7.6 {tcltest::debug} {
+ -setup {
+ set old $::tcltest::debug
+ set ::tcltest::debug 0
+ }
+ -body {
+ set f1 [debug]
+ set f2 [debug 1]
+ set f3 [debug]
+ set f4 [debug 2]
+ set f5 [debug]
+ list $f1 $f2 $f3 $f4 $f5
+ }
+ -result {0 1 1 2 2}
+ -cleanup {
+ set ::tcltest::debug $old
+ }
+}
+
+# directory tests
+
makeFile {
package require tcltest
- namespace import -force ::tcltest::*
- makeFile {} a.tmp
+ tcltest::makeFile {} a.tmp
+ puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
exit
} a.tcl
-makeFile {} thisdirectoryisafile
+makeFile {} thisdirectoryisafile
-# -tmpdir
+set normaldirectory [makeDirectory normaldirectory]
+if {$::tcl_platform(platform) == "macintosh"} {
+set normaldirectory [file normalize $normaldirectory]
+}
+
+# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
file delete -force thisdirectorydoesnotexist
- exec $::tcltest::tcltest a.tcl -tmpdir thisdirectorydoesnotexist
+ slave msg a.tcl -tmpdir thisdirectorydoesnotexist
list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
[file delete -force thisdirectorydoesnotexist]
} {1 {}}
-test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {unixOrPc} {
- catch {exec $::tcltest::tcltest a.tcl -tmpdir thisdirectoryisafile} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp "not a directory" [join $msg]]
-} {1}
+test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
+ -constraints unixOrPc
+ -body {
+ slave msg a.tcl -tmpdir thisdirectoryisafile
+ set msg
+ }
+ -result {*not a directory*}
+ -match glob
+}
-# Test non-writeable directories, non-readable directories with tmpdir
-set notReadableDir [file join $::tcltest::temporaryDirectory notreadable]
-set notWriteableDir [file join $::tcltest::temporaryDirectory notwriteable]
+# Test non-writeable directories, non-readable directories with directory flags
+set notReadableDir [file join [temporaryDirectory] notreadable]
+set notWriteableDir [file join [temporaryDirectory] notwriteable]
-::tcltest::makeDirectory notreadable
-::tcltest::makeDirectory notwriteable
+makeDirectory notreadable
+makeDirectory notwriteable
switch $tcl_platform(platform) {
"unix" {
file attributes $notWriteableDir -permissions 00555
}
default {
- file attributes $notWriteableDir -readonly 1
+ catch {file attributes $notWriteableDir -readonly 1}
}
}
-test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} {
- catch {exec $::tcltest::tcltest a.tcl -tmpdir $notReadableDir} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp {not readable} [join $msg]]
+test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly nonRoot} {
+ slave msg a.tcl -tmpdir $notReadableDir
+ string match {*not readable*} $msg
} {1}
-test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} {
- catch {exec $::tcltest::tcltest a.tcl -tmpdir $notWriteableDir} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp {not writeable} [join $msg]]
+test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc nonRoot} {
+ slave msg a.tcl -tmpdir $notWriteableDir
+ string match {*not writeable*} $msg
} {1}
-# -testdir
-test tcltest-8.5 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
+test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
+ slave msg a.tcl -tmpdir $normaldirectory
+ # The join is necessary because the message can be split on multiple lines
+ list [file exists [file join $normaldirectory a.tmp]] \
+ [file delete [file join $normaldirectory a.tmp]]
+} {1 {}}
+cd [workingDirectory]
+
+test tcltest-8.6 {temporaryDirectory} {
+ -setup {
+ set old $::tcltest::temporaryDirectory
+ set ::tcltest::temporaryDirectory $normaldirectory
+ }
+ -body {
+ set f1 [temporaryDirectory]
+ set f2 [temporaryDirectory [workingDirectory]]
+ set f3 [temporaryDirectory]
+ list $f1 $f2 $f3
+ }
+ -result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
+ -cleanup {
+ set ::tcltest::temporaryDirectory $old
+ }
+}
+
+test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
+ set old $::tcltest::temporaryDirectory
+ set ::tcltest::temporaryDirectory $normaldirectory
+} -body {
+ set f1 [temporaryDirectory]
+ set f2 [temporaryDirectory [workingDirectory]]
+ set f3 [temporaryDirectory]
+ list $f1 $f2 $f3
+} -cleanup {
+ set ::tcltest::temporaryDirectory $old
+} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
+
+cd [temporaryDirectory]
+# -testdir, [testsDirectory]
+test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
file delete -force thisdirectorydoesnotexist
- catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectorydoesnotexist} msg
- list [regexp "does not exist" [join $msg]]
+ slave msg a.tcl -testdir thisdirectorydoesnotexist
+ string match "*does not exist*" $msg
} {1}
-test tcltest-8.6 {tcltest a.tcl -testdir thisdirectoryisafile} {
- catch {exec $::tcltest::tcltest a.tcl -testdir thisdirectoryisafile} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp "not a directory" [join $msg]]
+test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
+ slave msg a.tcl -testdir thisdirectoryisafile
+ string match "*not a directory*" $msg
} {1}
-test tcltest-8.7 {tcltest a.tcl -testdir notReadableDir} {unixOnly} {
- catch {exec $::tcltest::tcltest a.tcl -testdir $notReadableDir} msg
- # The join is necessary because the message can be split on multiple lines
- list [regexp {not readable} [join $msg]]
+test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly nonRoot} {
+ slave msg a.tcl -testdir $notReadableDir
+ string match {*not readable*} $msg
} {1}
+test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
+ slave msg a.tcl -testdir $normaldirectory
+ # The join is necessary because the message can be split on multiple lines
+ list [string first "testdir: $normaldirectory" [join $msg]] \
+ [file exists [file join [temporaryDirectory] a.tmp]] \
+ [file delete [file join [temporaryDirectory] a.tmp]]
+} {0 1 {}}
+cd [workingDirectory]
+
+set current [pwd]
+test tcltest-8.14 {testsDirectory} {
+ -setup {
+ set old $::tcltest::testsDirectory
+ set ::tcltest::testsDirectory $normaldirectory
+ }
+ -body {
+ set f1 [testsDirectory]
+ set f2 [testsDirectory $current]
+ set f3 [testsDirectory]
+ list $f1 $f2 $f3
+ }
+ -result "[list $normaldirectory $current $current]"
+ -cleanup {
+ set ::tcltest::testsDirectory $old
+ }
+}
+
+# [workingDirectory]
+test tcltest-8.60 {::workingDirectory} {
+ -setup {
+ set old $::tcltest::workingDirectory
+ set current [pwd]
+ set ::tcltest::workingDirectory $normaldirectory
+ cd $normaldirectory
+ }
+ -body {
+ set f1 [workingDirectory]
+ set f2 [pwd]
+ set f3 [workingDirectory $current]
+ set f4 [pwd]
+ set f5 [workingDirectory]
+ list $f1 $f2 $f3 $f4 $f5
+ }
+ -result "[list $normaldirectory \
+ $normaldirectory \
+ $current \
+ $current \
+ $current]"
+ -cleanup {
+ set ::tcltest::workingDirectory $old
+ cd $current
+ }
+}
+
+# clean up from directory testing
+
switch $tcl_platform(platform) {
"unix" {
file attributes $notReadableDir -permissions 777
file attributes $notWriteableDir -permissions 777
}
default {
- file attributes $notWriteableDir -readonly 0
+ catch {file attributes $notWriteableDir -readonly 0}
}
}
file delete -force $notReadableDir $notWriteableDir
-# -file -notfile
+# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file a*.tcl} {unixOrPc} {
- catch {exec $::tcltest::tcltest \
- [file join $::tcltest::testsDirectory all.tcl] -file a*.test} msg
+ slave msg [file join [testsDirectory] all.tcl] -file a*.test
list [regexp assocd\.test $msg]
} {1}
test tcltest-9.2 {-file a*.tcl} {unixOrPc} {
- catch {exec $::tcltest::tcltest \
- [file join $::tcltest::testsDirectory all.tcl] \
- -file a*.test -notfile assocd*} msg
+ slave msg [file join [testsDirectory] all.tcl] \
+ -file a*.test -notfile assocd*
list [regexp assocd\.test $msg]
} {0}
+test tcltest-9.3 {matchFiles} {
+ -body {
+ set old [matchFiles]
+ matchFiles foo
+ set current [matchFiles]
+ matchFiles bar
+ set new [matchFiles]
+ matchFiles $old
+ list $current $new
+ }
+ -result {foo bar}
+}
+test tcltest-9.4 {skipFiles} {
+ -body {
+ set old [skipFiles]
+ skipFiles foo
+ set current [skipFiles]
+ skipFiles bar
+ set new [skipFiles]
+ skipFiles $old
+ list $current $new
+ }
+ -result {foo bar}
+}
+# -preservecore, [preserveCore]
makeFile {
package require tcltest
- namespace import -force ::tcltest::*
-
+ namespace import ::tcltest::test
test makecore {make a core file} {
set f [open core w]
close $f
return
} makecore.tcl
-# -preservecore
+cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
- catch {exec $::tcltest::tcltest makecore.tcl -preservecore 0} msg
+ slave msg makecore.tcl -preservecore 0
file delete core
- regexp "produced core file" $msg
+ regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrPc} {
- catch {exec $::tcltest::tcltest makecore.tcl -preservecore 1} msg
+ slave msg makecore.tcl -preservecore 1
file delete core
- regexp "produced core file" $msg
+ regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrPc} {
- catch {exec $::tcltest::tcltest makecore.tcl -preservecore 2} msg
+ slave msg makecore.tcl -preservecore 2
file delete core
- list [regexp "==== makecore produced core file" $msg] [regexp "Moving file to" $msg] \
+ list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrPc} {
- catch {exec $::tcltest::tcltest makecore.tcl -preservecore 3} msg
+ slave msg makecore.tcl -preservecore 3
file delete core
- list [regexp "produced core file" $msg] [regexp "Moving file to" $msg] \
+ list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
-makeFile {
+# Removing this test. It makes no sense to test the ability of
+# [preserveCore] to accept an invalid value that will cause errors
+# in other parts of tcltest's operation.
+#test tcltest-10.5 {preserveCore} {
+# -body {
+# set old [preserveCore]
+# set result [preserveCore foo]
+# set result2 [preserveCore]
+# preserveCore $old
+# list $result $result2
+# }
+# -result {foo foo}
+#}
+
+# -load, -loadfile, [loadScript], [loadFile]
+set contents {
package require tcltest
- namespace import -force ::tcltest::*
- puts "=$::tcltest::parameters="
+ namespace import tcltest::*
+ puts [outputChannel] $::tcltest::loadScript
exit
-} args.tcl
+}
+set loadfile [makeFile $contents load.tcl]
+
+test tcltest-12.1 {-load xxx} {unixOrPc} {
+ slave msg load.tcl -load xxx
+ set msg
+} {xxx}
+
+# Using child process because of -debug usage.
+test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
+ catch {exec [interpreter] load.tcl -debug 2 -loadfile load.tcl} msg
+ list \
+ [regexp {tcltest} [join [list $msg] [split $msg \n]]] \
+ [regexp {loadScript} [join [list $msg] [split $msg \n]]]
+} {1 1}
+
+test tcltest-12.3 {loadScript} {
+ -setup {
+ set old $::tcltest::loadScript
+ }
+ -body {
+ set f1 [loadScript]
+ set f2 [loadScript xxx]
+ set f3 [loadScript]
+ list $f1 $f2 $f3
+ }
+ -result {{} xxx xxx}
+ -cleanup {
+ set ::tcltest::loadScript $old
+ }
+}
-# -args
-test tcltest-11.1 {-args foo} {unixOrPc} {
- catch {exec $::tcltest::tcltest args.tcl -args foo} msg
- list $msg
-} {=foo=}
+test tcltest-12.4 {loadFile} {
+ -setup {
+ set olds $::tcltest::loadScript
+ set oldf $::tcltest::loadFile
+ set ::tcltest::loadFile {}
+ }
+ -body {
+ set f1 [loadScript]
+ set f2 [loadFile]
+ set f3 [loadFile load.tcl]
+ set f4 [loadScript]
+ set f5 [loadFile]
+ list $f1 $f2 $f3 $f4 $f5
+ }
+ -result "[list {} {} $loadfile $contents $loadfile]\n"
+ -cleanup {
+ set ::tcltest::loadScript $olds
+ set ::tcltest::loadFile $oldf
+ }
+}
-test tcltest-11.2 {-args {}} {unixOrPc} {
- catch {exec $::tcltest::tcltest args.tcl -args {}} msg
- list $msg
-} {==}
+# [interpreter]
+test tcltest-13.1 {interpreter} {
+ -setup {
+ set old $::tcltest::tcltest
+ set ::tcltest::tcltest tcltest
+ }
+ -body {
+ set f1 [interpreter]
+ set f2 [interpreter tclsh]
+ set f3 [interpreter]
+ list $f1 $f2 $f3
+ }
+ -result {tcltest tclsh tclsh}
+ -cleanup {
+ set ::tcltest::tcltest $old
+ }
+}
-test tcltest-11.3 {-args {-foo bar -baz}} {unixOrPc} {
- catch {exec $::tcltest::tcltest args.tcl -args {-foo bar -baz}} msg
- list $msg
-} {{=-foo bar -baz=}}
+# -singleproc, [singleProcess]
+makeDirectory singleprocdir
+makeFile {
+ set foo 1
+} [file join singleprocdir single1.test]
-# -load -loadfile
makeFile {
+ unset foo
+} [file join singleprocdir single2.test]
+
+set allfile [makeFile {
package require tcltest
- namespace import -force ::tcltest::*
- puts $::tcltest::loadScript
- exit
-} load.tcl
+ namespace import tcltest::*
+ testsDirectory [file join [temporaryDirectory] singleprocdir]
+ runAllTests
+} [file join singleprocdir all-single.tcl]]
+cd [workingDirectory]
-test tcltest-12.1 {-load xxx} {
- catch {exec $::tcltest::tcltest load.tcl -load xxx} msg
- set msg
-} {xxx}
+test tcltest-14.1 {-singleproc - single process} {
+ -constraints {unixOrPc}
+ -body {
+ slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
+ set msg
+ }
+ -result {Test file error: can't unset .foo.: no such variable}
+ -match regexp
+}
-test tcltest-12.1 {-loadfile load.tcl} {
- catch {exec $::tcltest::tcltest load.tcl -d 2 -loadfile load.tcl} msg
- list \
- [regexp {tcltest} [join $msg [split $msg \n]]] \
- [regexp {loadScript} [join $msg [split $msg \n]]]
-} {1 1}
+test tcltest-14.2 {-singleproc - multiple process} {
+ -constraints {unixOrPc}
+ -body {
+ slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
+ set msg
+ }
+ -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
+ -match regexp
+}
+
+test tcltest-14.3 {singleProcess} {
+ -setup {
+ set old $::tcltest::singleProcess
+ set ::tcltest::singleProcess 0
+ }
+ -body {
+ set f1 [singleProcess]
+ set f2 [singleProcess 1]
+ set f3 [singleProcess]
+ list $f1 $f2 $f3
+ }
+ -result {0 1 1}
+ -cleanup {
+ set ::tcltest::singleProcess $old
+ }
+}
+
+# -asidefromdir, -relateddir, [matchDirectories], [skipDirectories]
+
+# Before running these tests, need to set up test subdirectories with their own
+# all.tcl files.
+
+makeDirectory dirtestdir
+makeDirectory [file join dirtestdir dirtestdir2.1]
+makeDirectory [file join dirtestdir dirtestdir2.2]
+makeDirectory [file join dirtestdir dirtestdir2.3]
+makeFile {
+ package require tcltest
+ namespace import -force tcltest::*
+ testsDirectory [file join [temporaryDirectory] dirtestdir]
+ runAllTests
+} [file join dirtestdir all.tcl]
+makeFile {
+ package require tcltest
+ namespace import -force tcltest::*
+ testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
+ runAllTests
+} [file join dirtestdir dirtestdir2.1 all.tcl]
+makeFile {
+ package require tcltest
+ namespace import -force tcltest::*
+ testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2]
+ runAllTests
+} [file join dirtestdir dirtestdir2.2 all.tcl]
+makeFile {
+ package require tcltest
+ namespace import -force tcltest::*
+ testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
+ runAllTests
+} [file join dirtestdir dirtestdir2.3 all.tcl]
+
+test tcltest-15.1 {basic directory walking} {
+ -constraints {unixOrPc}
+ -body {
+ if {[slave msg \
+ [file join [temporaryDirectory] dirtestdir all.tcl] \
+ -tmpdir [temporaryDirectory]] == 1} {
+ error $msg
+ }
+ }
+ -match regexp
+ -returnCodes 1
+ -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3}
+}
+
+test tcltest-15.2 {-asidefromdir} {
+ -constraints {unixOrPc}
+ -body {
+ if {[slave msg \
+ [file join [temporaryDirectory] dirtestdir all.tcl] \
+ -asidefromdir dirtestdir2.3 \
+ -tmpdir [temporaryDirectory]] == 1} {
+ error $msg
+ }
+ }
+ -match regexp
+ -returnCodes 1
+ -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Error: No test files remain after applying your match and skip patterns!
+Error: No test files remain after applying your match and skip patterns!
+Error: No test files remain after applying your match and skip patterns!$}
+}
+
+test tcltest-15.3 {-relateddir, non-existent dir} {
+ -constraints {unixOrPc}
+ -body {
+ if {[slave msg \
+ [file join [temporaryDirectory] dirtestdir all.tcl] \
+ -relateddir [file join [temporaryDirectory] dirtestdir0] \
+ -tmpdir [temporaryDirectory]] == 1} {
+ error $msg
+ }
+ }
+ -returnCodes 1
+ -match regexp
+ -result {[^~]|dirtestdir[^2]}
+}
+
+test tcltest-15.4 {-relateddir, subdir} {
+ -constraints {unixOrPc}
+ -body {
+ if {[slave msg \
+ [file join [temporaryDirectory] dirtestdir all.tcl] \
+ -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
+ error $msg
+ }
+ }
+ -returnCodes 1
+ -match regexp
+ -result {Tests located in:.*dirtestdir2.[^23]}
+}
+test tcltest-15.5 {-relateddir, -asidefromdir} {
+ -constraints {unixOrPc}
+ -body {
+ if {[slave msg \
+ [file join [temporaryDirectory] dirtestdir all.tcl] \
+ -relateddir "dirtestdir2.1 dirtestdir2.2" \
+ -asidefromdir dirtestdir2.2 \
+ -tmpdir [temporaryDirectory]] == 1} {
+ error $msg
+ }
+ }
+ -match regexp
+ -returnCodes 1
+ -result {Tests located in:.*dirtestdir2.[^23]}
+}
+
+test tcltest-15.6 {matchDirectories} {
+ -setup {
+ set old [matchDirectories]
+ set ::tcltest::matchDirectories {}
+ }
+ -body {
+ set r1 [matchDirectories]
+ set r2 [matchDirectories foo]
+ set r3 [matchDirectories]
+ list $r1 $r2 $r3
+ }
+ -cleanup {
+ set ::tcltest::matchDirectories $old
+ }
+ -result {{} foo foo}
+}
+
+test tcltest-15.7 {skipDirectories} {
+ -setup {
+ set old [skipDirectories]
+ set ::tcltest::skipDirectories {}
+ }
+ -body {
+ set r1 [skipDirectories]
+ set r2 [skipDirectories foo]
+ set r3 [skipDirectories]
+ list $r1 $r2 $r3
+ }
+ -cleanup {
+ set ::tcltest::skipDirectories $old
+ }
+ -result {{} foo foo}
+}
+
+# TCLTEST_OPTIONS
+test tcltest-19.1 {TCLTEST_OPTIONS default} {
+ -constraints {unixOrPc singleTestInterp}
+ -setup {
+ if {[info exists ::env(TCLTEST_OPTIONS)]} {
+ set oldoptions $::env(TCLTEST_OPTIONS)
+ unset ::env(TCLTEST_OPTIONS)
+ } else {
+ set oldoptions none
+ }
+ # set this to { } instead of just {} to get around quirk in
+ # Windows env handling that removes empty elements from env array.
+ set ::env(TCLTEST_OPTIONS) { }
+ set olddebug [debug]
+ debug 2
+ }
+ -cleanup {
+ if {$oldoptions == "none"} {
+ unset ::env(TCLTEST_OPTIONS)
+ } else {
+ set ::env(TCLTEST_OPTIONS) $oldoptions
+ }
+ debug $olddebug
+ }
+ -body {
+ ::tcltest::ProcessCmdLineArgs
+ set ::env(TCLTEST_OPTIONS) "-debug 3"
+ ::tcltest::ProcessCmdLineArgs
+ }
+ -result {^$}
+ -match regexp
+ -output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
+}
# Begin testing of tcltest procs ...
+cd [temporaryDirectory]
# PrintError
test tcltest-20.1 {PrintError} {unixOrPc} {
- set result [catch {exec $::tcltest::tcltest printerror.tcl} msg]
+ set result [slave msg printerror.tcl]
list $result [regexp "Error: a really short string" $msg] \
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
[regexp " \"Really" $msg] [regexp Problem $msg]
} {1 1 1 1 1 1}
+cd [workingDirectory]
-# cleanup
-::tcltest::cleanupTests
-return
+# test::test
+test tcltest-21.0 {name and desc but no args specified} -setup {
+ set v [verbose]
+} -cleanup {
+ verbose $v
+} -body {
+ verbose {}
+ test tcltest-21.0.0 bar
+} -result {}
+
+test tcltest-21.1 {expect with glob} {
+ -body {
+ list a b c d e
+ }
+ -match glob
+ -result {[ab] b c d e}
+}
+
+test tcltest-21.2 {force a test command failure} {
+ -body {
+ test tcltest-21.2.0 {
+ return 2
+ } {1}
+ }
+ -returnCodes 1
+ -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+}
+
+test tcltest-21.3 {test command with setup} {
+ -setup {
+ set foo 1
+ }
+ -body {
+ set foo
+ }
+ -cleanup {unset foo}
+ -result {1}
+}
+
+test tcltest-21.4 {test command with cleanup failure} {
+ -setup {
+ if {[info exists foo]} {
+ unset foo
+ }
+ set fail $::tcltest::currentFailure
+ set v [verbose]
+ }
+ -body {
+ verbose {}
+ test tcltest-21.4.0 {foo-1} {
+ -cleanup {unset foo}
+ }
+ }
+ -result {^$}
+ -match regexp
+ -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
+ -output "Test cleanup failed:.*can't unset \"foo\": no such variable"
+}
+
+test tcltest-21.5 {test command with setup failure} {
+ -setup {
+ if {[info exists foo]} {
+ unset foo
+ }
+ set fail $::tcltest::currentFailure
+ }
+ -body {
+ test tcltest-21.5.0 {foo-2} {
+ -setup {unset foo}
+ }
+ }
+ -result {^$}
+ -match regexp
+ -cleanup {set ::tcltest::currentFailure $fail}
+ -output "Test setup failed:.*can't unset \"foo\": no such variable"
+}
+
+test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
+ -setup {set v [verbose]; set fail $::tcltest::currentFailure}
+ -body {
+ verbose {}
+ test tcltest-21.6.0 {foo-3} {
+ -setup {
+ if {[info exists foo]} {
+ unset foo
+ }
+ set foo 1
+ set expected 2
+ }
+ -body {
+ incr foo
+ set foo
+ }
+ -cleanup {
+ if {$foo != 2} {
+ puts [outputChannel] "foo is wrong"
+ } else {
+ puts [outputChannel] "foo is 2"
+ }
+ }
+ -result {$expected}
+ }
+ }
+ -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
+ -result {^$}
+ -match regexp
+ -output "foo is 2"
+}
+test tcltest-21.7 {test command - bad flag} {
+ -setup {set fail $::tcltest::currentFailure}
+ -cleanup {set ::tcltest::currentFailure $fail}
+ -body {
+ test tcltest-21.7.0 {foo-4} {
+ -foobar {}
+ }
+ }
+ -returnCodes 1
+ -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+}
+
+# alternate test command format (these are the same as 21.1-21.6, with the
+# exception of being in the all-inline format)
+
+test tcltest-21.7a {expect with glob} \
+ -body {list a b c d e} \
+ -result {[ab] b c d e} \
+ -match glob
+
+test tcltest-21.8 {force a test command failure} \
+ -setup {set fail $::tcltest::currentFailure} \
+ -body {
+ test tcltest-21.8.0 {
+ return 2
+ } {1}
+ } \
+ -returnCodes 1 \
+ -cleanup {set ::tcltest::currentFailure $fail} \
+ -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
+
+test tcltest-21.9 {test command with setup} \
+ -setup {set foo 1} \
+ -body {set foo} \
+ -cleanup {unset foo} \
+ -result {1}
+
+test tcltest-21.10 {test command with cleanup failure} -setup {
+ if {[info exists foo]} {
+ unset foo
+ }
+ set fail $::tcltest::currentFailure
+ set v [verbose]
+} -cleanup {
+ verbose $v
+ set ::tcltest::currentFailure $fail
+} -body {
+ verbose {}
+ test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
+} -result {^$} -match regexp \
+ -output {Test cleanup failed:.*can't unset \"foo\": no such variable}
+
+test tcltest-21.11 {test command with setup failure} -setup {
+ if {[info exists foo]} {
+ unset foo
+ }
+ set fail $::tcltest::currentFailure
+} -cleanup {set ::tcltest::currentFailure $fail} -body {
+ test tcltest-21.11.0 {foo-2} -setup {unset foo}
+} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp
+
+test tcltest-21.12 {
+ test command - setup occurs before cleanup & before script
+} -setup {
+ set fail $::tcltest::currentFailure
+ set v [verbose]
+} -cleanup {
+ verbose $v
+ set ::tcltest::currentFailure $fail
+} -body {
+ verbose {}
+ test tcltest-21.12.0 {foo-3} -setup {
+ if {[info exists foo]} {
+ unset foo
+ }
+ set foo 1
+ set expected 2
+ } -body {
+ incr foo
+ set foo
+ } -cleanup {
+ if {$foo != 2} {
+ puts [outputChannel] "foo is wrong"
+ } else {
+ puts [outputChannel] "foo is 2"
+ }
+ } -result {$expected}
+} -result {^$} -output {foo is 2} -match regexp
+
+# test all.tcl usage (runAllTests); simulate .test file failure, as well as
+# crashes to determine whether or not these errors are logged.
+
+makeDirectory alltestdir
+makeFile {
+ package require tcltest
+ namespace import -force tcltest::*
+ testsDirectory [file join [temporaryDirectory] alltestdir]
+ runAllTests
+} [file join alltestdir all.tcl]
+makeFile {
+ exit 1
+} [file join alltestdir exit.test]
+makeFile {
+ error "throw an error"
+} [file join alltestdir error.test]
+makeFile {
+ package require tcltest
+ namespace import -force tcltest::*
+ test foo-1.1 {foo} {
+ -body { return 1 }
+ -result {1}
+ }
+ cleanupTests
+} [file join alltestdir test.test]
+
+# Must use a child process because stdout/stderr parsing can't be
+# duplicated in slave interp.
+test tcltest-22.1 {runAllTests} {
+ -constraints {unixOrPc}
+ -body {
+ exec [interpreter] \
+ [file join [temporaryDirectory] alltestdir all.tcl] \
+ -verbose t -tmpdir [temporaryDirectory]
+ }
+ -match regexp
+ -result "Test files exiting with errors:.*error.test.*exit.test"
+}
+
+# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
+test tcltest-23.1 {makeFile} {
+ -setup {
+ set mfdir [file join [temporaryDirectory] mfdir]
+ file mkdir $mfdir
+ }
+ -body {
+ makeFile {} t1.tmp
+ makeFile {} et1.tmp $mfdir
+ list [file exists [file join [temporaryDirectory] t1.tmp]] \
+ [file exists [file join $mfdir et1.tmp]]
+ }
+ -cleanup {
+ file delete -force $mfdir \
+ [file join [temporaryDirectory] t1.tmp]
+ }
+ -result {1 1}
+}
+test tcltest-23.2 {removeFile} {
+ -setup {
+ set mfdir [file join [temporaryDirectory] mfdir]
+ file mkdir $mfdir
+ makeFile {} t1.tmp
+ makeFile {} et1.tmp $mfdir
+ if {![file exists [file join [temporaryDirectory] t1.tmp]] || \
+ ![file exists [file join $mfdir et1.tmp]]} {
+ error "file creation didn't work"
+ }
+ }
+ -body {
+ removeFile t1.tmp
+ removeFile et1.tmp $mfdir
+ list [file exists [file join [temporaryDirectory] t1.tmp]] \
+ [file exists [file join $mfdir et1.tmp]]
+ }
+ -cleanup {
+ file delete -force $mfdir \
+ [file join [temporaryDirectory] t1.tmp]
+ }
+ -result {0 0}
+}
+test tcltest-23.3 {makeDirectory} {
+ -body {
+ set mfdir [file join [temporaryDirectory] mfdir]
+ file mkdir $mfdir
+ makeDirectory d1
+ makeDirectory d2 $mfdir
+ list [file exists [file join [temporaryDirectory] d1]] \
+ [file exists [file join $mfdir d2]]
+ }
+ -cleanup {
+ file delete -force [file join [temporaryDirectory] d1] $mfdir
+ }
+ -result {1 1}
+}
+test tcltest-23.4 {removeDirectory} {
+ -body {
+ set mfdir [file join [temporaryDirectory] mfdir]
+ file mkdir $mfdir
+ file mkdir [file join [temporaryDirectory] t1]
+ file mkdir [file join [temporaryDirectory] $mfdir t2]
+ if {![file exists $mfdir] || \
+ ![file exists [file join [temporaryDirectory] $mfdir t2]]} {
+ return "setup failed - directory not created"
+ }
+ removeDirectory t1
+ removeDirectory t2 $mfdir
+ list [file exists [file join [temporaryDirectory] t1]] \
+ [file exists [file join $mfdir t2]]
+ }
+ -result {0 0}
+}
+test tcltest-23.5 {viewFile} {
+ -body {
+ set mfdir [file join [temporaryDirectory] mfdir]
+ file mkdir $mfdir
+ makeFile {foobar} t1.tmp
+ makeFile {foobarbaz} t2.tmp $mfdir
+ list [viewFile t1.tmp] [viewFile t2.tmp $mfdir]
+ }
+ -result {foobar foobarbaz}
+ -cleanup {
+ file delete -force $mfdir
+ }
+}
+
+# customMatch
+proc matchNegative { expected actual } {
+ set match 0
+ foreach a $actual e $expected {
+ if { $a != $e } {
+ set match 1
+ break
+ }
+ }
+ return $match
+}
+
+test tcltest-24.0 {
+ customMatch: syntax
+} -body {
+ list [catch {customMatch} result] $result
+} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
+
+test tcltest-24.1 {
+ customMatch: syntax
+} -body {
+ list [catch {customMatch foo} result] $result
+} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
+
+test tcltest-24.2 {
+ customMatch: syntax
+} -body {
+ list [catch {customMatch foo bar baz} result] $result
+} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
+
+test tcltest-24.3 {
+ customMatch: argument checking
+} -body {
+ list [catch {customMatch bad "a \{ b"} result] $result
+} -result [list 1 "invalid customMatch script; can't evaluate after completion"]
+
+test tcltest-24.4 {
+ test: valid -match values
+} -body {
+ list [catch {
+ test tcltest-24.4.0 {} \
+ -match [namespace current]::noSuchMode
+ } result] $result
+} -match glob -result {1 *bad -match value*}
+
+test tcltest-24.5 {
+ test: valid -match values
+} -setup {
+ customMatch [namespace current]::alwaysMatch "format 1 ;#"
+} -body {
+ list [catch {
+ test tcltest-24.5.0 {} \
+ -match [namespace current]::noSuchMode
+ } result] $result
+} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
+
+test tcltest-24.6 {
+ customMatch: -match script that always matches
+} -setup {
+ customMatch [namespace current]::alwaysMatch "format 1 ;#"
+ set v [verbose]
+} -body {
+ verbose {}
+ test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
+ -body {format 1} -result 0
+} -cleanup {
+ verbose $v
+} -result {} -output {} -errorOutput {}
+
+test tcltest-24.7 {
+ customMatch: replace default -exact matching
+} -setup {
+ set saveExactMatchScript $::tcltest::CustomMatch(exact)
+ customMatch exact "format 1 ;#"
+ set v [verbose]
+} -body {
+ verbose {}
+ test tcltest-24.7.0 {} -body {format 1} -result 0
+} -cleanup {
+ verbose $v
+ customMatch exact $saveExactMatchScript
+ unset saveExactMatchScript
+} -result {} -output {}
+
+test tcltest-24.9 {
+ customMatch: error during match
+} -setup {
+ proc errorDuringMatch args {return -code error "match returned error"}
+ customMatch [namespace current]::errorDuringMatch \
+ [namespace code errorDuringMatch]
+ set v [verbose]
+ set fail $::tcltest::currentFailure
+} -body {
+ verbose {}
+ test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
+} -cleanup {
+ verbose $v
+ set ::tcltest::currentFailure $fail
+} -match glob -result {} -output {*FAILED*match returned error*}
+
+test tcltest-24.10 {
+ customMatch: bad return from match command
+} -setup {
+ proc nonBooleanReturn args {return foo}
+ customMatch nonBooleanReturn [namespace code nonBooleanReturn]
+ set v [verbose]
+ set fail $::tcltest::currentFailure
+} -body {
+ verbose {}
+ test tcltest-24.10.0 {} -match nonBooleanReturn
+} -cleanup {
+ verbose $v
+ set ::tcltest::currentFailure $fail
+} -match glob -result {} -output {*FAILED*expected boolean value*}
+
+test tcltest-24.11 {
+ test: -match exact
+} -body {
+ set result {A B C}
+} -match exact -result {A B C}
+
+test tcltest-24.12 {
+ test: -match exact match command eval in ::, not caller namespace
+} -setup {
+ set saveExactMatchScript $::tcltest::CustomMatch(exact)
+ customMatch exact [list string equal]
+ set v [verbose]
+ proc string args {error {called [string] in caller namespace}}
+} -body {
+ verbose {}
+ test tcltest-24.12.0 {} -body {format 1} -result 1
+} -cleanup {
+ rename string {}
+ verbose $v
+ customMatch exact $saveExactMatchScript
+ unset saveExactMatchScript
+} -match exact -result {} -output {}
+
+test tcltest-24.13 {
+ test: -match exact failure
+} -setup {
+ set saveExactMatchScript $::tcltest::CustomMatch(exact)
+ customMatch exact [list string equal]
+ set v [verbose]
+ set fail $::tcltest::currentFailure
+} -body {
+ verbose {}
+ test tcltest-24.13.0 {} -body {format 1} -result 0
+} -cleanup {
+ set ::tcltest::currentFailure $fail
+ verbose $v
+ customMatch exact $saveExactMatchScript
+ unset saveExactMatchScript
+} -match glob -result {} -output {*FAILED*Result was:
+1*(exact matching):
+0*}
+
+test tcltest-24.14 {
+ test: -match glob
+} -body {
+ set result {A B C}
+} -match glob -result {A B*}
+
+test tcltest-24.15 {
+ test: -match glob failure
+} -setup {
+ set v [verbose]
+ set fail $::tcltest::currentFailure
+} -body {
+ verbose {}
+ test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
+ -result {A B* }
+} -cleanup {
+ set ::tcltest::currentFailure $fail
+ verbose $v
+} -match glob -result {} -output {*FAILED*Result was:
+*(glob matching):
+*}
+
+test tcltest-24.16 {
+ test: -match regexp
+} -body {
+ set result {A B C}
+} -match regexp -result {A B.*}
+
+test tcltest-24.17 {
+ test: -match regexp failure
+} -setup {
+ set fail $::tcltest::currentFailure
+ set v [verbose]
+} -body {
+ verbose {}
+ test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
+ -result {A B.* X}
+} -cleanup {
+ set ::tcltest::currentFailure $fail
+ verbose $v
+} -match glob -result {} -output {*FAILED*Result was:
+*(regexp matching):
+*}
+
+test tcltest-24.18 {
+ test: -match custom forget namespace qualification
+} -setup {
+ set fail $::tcltest::currentFailure
+ set v [verbose]
+ customMatch negative matchNegative
+} -body {
+ verbose {}
+ test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
+ -result {A B X}
+} -cleanup {
+ set ::tcltest::currentFailure $fail
+ verbose $v
+} -match glob -result {} -output {*FAILED*Error testing result:*}
+
+test tcltest-24.19 {
+ test: -match custom
+} -setup {
+ set v [verbose]
+ customMatch negative [namespace code matchNegative]
+} -body {
+ verbose {}
+ test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
+ -result {A B X}
+} -cleanup {
+ verbose $v
+} -match exact -result {} -output {}
+
+test tcltest-24.20 {
+ test: -match custom failure
+} -setup {
+ set fail $::tcltest::currentFailure
+ set v [verbose]
+ customMatch negative [namespace code matchNegative]
+} -body {
+ verbose {}
+ test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
+ -result {A B C}
+} -cleanup {
+ set ::tcltest::currentFailure $fail
+ verbose $v
+} -match glob -result {} -output {*FAILED*Result was:
+*(negative matching):
+*}
+
+test tcltest-25.1 {
+ constraint of setup/cleanup (Bug 589859)
+} -setup {
+ set foo 0
+} -body {
+ # Buggy tcltest will generate result of 2
+ test tcltest-25.1.0 {} -constraints knownBug -setup {
+ incr foo
+ } -body {
+ incr foo
+ } -cleanup {
+ incr foo
+ } -match glob -result *
+ set foo
+} -cleanup {
+ unset foo
+} -result 0
+
+test tcltest-25.2 {
+ puts -nonewline (Bug 612786)
+} -body {
+ puts -nonewline stdout bla
+ puts -nonewline stdout bla
+} -output {blabla}
+
+test tcltest-25.3 {
+ reported return code (Bug 611922)
+} -body {
+ # Buggy tcltest will generate result of 2
+ test tcltest-25.3.0 {} -body {
+ error foo
+ }
+} -match glob -output {*generated error; Return code was: 1*}
+
+cleanupTests
+}
+
+namespace delete ::tcltest::test
+return
test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
list [catch {testthread foo} msg] $msg
-} {1 {bad option "foo": must be create, exit, id, names, send, wait, or errorproc}}
+} {1 {bad option "foo": must be create, exit, id, join, names, send, wait, or errorproc}}
test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
list [threadReap] [llength [testthread names]]
threadReap
testthread create {set x 5}
foreach try {0 1 2 4 5 6} {
- # Try various ways to yeild
+ # Try various ways to yield
update
after 10
set l [llength [testthread names]]
list $x $msg $errorCode
} {1 ERR CODE}
+
+test thread-5.0 {Joining threads} {testthread} {
+ threadReap
+ set serverthread [testthread create -joinable]
+ testthread send -async $serverthread {after 1000 ; testthread exit}
+ set res [testthread join $serverthread]
+ threadReap
+ set res
+} {0}
+
+test thread-5.1 {Joining threads after the fact} {testthread} {
+ threadReap
+ set serverthread [testthread create -joinable]
+ testthread send -async $serverthread {testthread exit}
+ after 2000
+ set res [testthread join $serverthread]
+ threadReap
+ set res
+} {0}
+
+test thread-5.2 {Try to join a detached thread} {testthread} {
+ threadReap
+ set serverthread [testthread create]
+ testthread send -async $serverthread {after 1000 ; testthread exit}
+ catch {set res [testthread join $serverthread]} msg
+ threadReap
+ lrange $msg 0 2
+} {cannot join thread}
+
# cleanup
::tcltest::cleanupTests
return
-
proc traceCrtElement {value name1 name2 op} {
uplevel set ${name1}($name2) $value
}
+proc traceCommand {oldName newName op} {
+ global info
+ set info [list $oldName $newName $op]
+}
+
+test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
+ # You may need Purify or Electric Fence to reliably
+ # see this one fail.
+ catch {unset z}
+ trace add variable z array {set z(foo) 1 ;#}
+ set res "names: [array names z]"
+ catch {unset ::z}
+ trace variable ::z w {unset ::z; error "memory corruption";#}
+ list [catch {set ::z 1} msg] $msg
+} {1 {can't set "::z": memory corruption}}
# Read-tracing on variables
test trace-1.1 {trace variable reads} {
catch {unset x}
set info {}
- trace var x r traceScalar
+ trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
-} {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}}
+} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}}
test trace-1.2 {trace variable reads} {
catch {unset x}
set x 123
set info {}
- trace var x r traceScalar
+ trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
-} {0 123 {x {} r 0 123}}
+} {0 123 {x {} read 0 123}}
test trace-1.3 {trace variable reads} {
catch {unset x}
set info {}
- trace var x r traceScalar
+ trace add variable x read traceScalar
set x 123
set info
} {}
test trace-1.4 {trace array element reads} {
catch {unset x}
set info {}
- trace var x(2) r traceArray
+ trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
-} {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}}
+} {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}}
test trace-1.5 {trace array element reads} {
catch {unset x}
set x(2) zzz
set info {}
- trace var x(2) r traceArray
+ trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
-} {0 zzz {x 2 r 0 zzz}}
+} {0 zzz {x 2 read 0 zzz}}
test trace-1.6 {trace array element reads} {
catch {unset x}
set info {}
- trace variable x r traceArray2
+ trace add variable x read traceArray2
proc p {} {
global x
set x(2) willi
return $x(2)
}
list [catch {p} msg] $msg $info
-} {0 willi {x 2 r}}
+} {0 willi {x 2 read}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
catch {unset x}
set info {}
- trace variable x r q
+ trace add variable x read q
proc q {name1 name2 op} {
global info
set info [list $name1 $name2 $op]
return $x(Y)
}
list [catch {p} msg] $msg $info
-} {0 wolf {x Y r}}
+} {0 wolf {x Y read}}
test trace-1.8 {trace reads on whole arrays} {
catch {unset x}
set info {}
- trace var x r traceArray
+ trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
test trace-1.9 {trace reads on whole arrays} {
catch {unset x}
set x(2) zzz
set info {}
- trace var x r traceArray
+ trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
-} {0 zzz {x 2 r 0 zzz}}
+} {0 zzz {x 2 read 0 zzz}}
test trace-1.10 {trace variable reads} {
catch {unset x}
set x 444
set info {}
- trace var x r traceScalar
+ trace add variable x read traceScalar
unset x
set info
} {}
+test trace-1.11 {read traces that modify the array structure} {
+ catch {unset x}
+ set x(bar) 0
+ trace variable x r {set x(foo) 1 ;#}
+ trace variable x r {unset -nocomplain x(bar) ;#}
+ array get x
+} {}
+test trace-1.12 {read traces that modify the array structure} {
+ catch {unset x}
+ set x(bar) 0
+ trace variable x r {unset -nocomplain x(bar) ;#}
+ trace variable x r {set x(foo) 1 ;#}
+ array get x
+} {}
+test trace-1.13 {read traces that modify the array structure} {
+ catch {unset x}
+ set x(bar) 0
+ trace variable x r {set x(foo) 1 ;#}
+ trace variable x r {unset -nocomplain x;#}
+ list [catch {array get x} res] $res
+} {1 {can't read "x(bar)": no such variable}}
+test trace-1.14 {read traces that modify the array structure} {
+ catch {unset x}
+ set x(bar) 0
+ trace variable x r {unset -nocomplain x;#}
+ trace variable x r {set x(foo) 1 ;#}
+ list [catch {array get x} res] $res
+} {1 {can't read "x(bar)": no such variable}}
# Basic write-tracing on variables
test trace-2.1 {trace variable writes} {
catch {unset x}
set info {}
- trace var x w traceScalar
+ trace add variable x write traceScalar
set x 123
set info
-} {x {} w 0 123}
+} {x {} write 0 123}
test trace-2.2 {trace writes to array elements} {
catch {unset x}
set info {}
- trace var x(33) w traceArray
+ trace add variable x(33) write traceArray
set x(33) 444
set info
-} {x 33 w 0 444}
+} {x 33 write 0 444}
test trace-2.3 {trace writes on whole arrays} {
catch {unset x}
set info {}
- trace var x w traceArray
+ trace add variable x write traceArray
set x(abc) qq
set info
-} {x abc w 0 qq}
+} {x abc write 0 qq}
test trace-2.4 {trace variable writes} {
catch {unset x}
set x 1234
set info {}
- trace var x w traceScalar
+ trace add variable x write traceScalar
set x
set info
} {}
catch {unset x}
set x 1234
set info {}
- trace var x w traceScalar
+ trace add variable x write traceScalar
unset x
set info
} {}
test trace-3.1 {trace variable read-modify-writes} {
catch {unset x}
set info {}
- trace var x r traceScalarAppend
+ trace add variable x read traceScalarAppend
append x 123
append x 456
lappend x 789
set info
-} {x {} r 0 123456}
+} {x {} read 0 123456}
test trace-3.2 {trace variable read-modify-writes} {
catch {unset x}
set info {}
- trace var x rw traceScalarAppend
+ trace add variable x {read write} traceScalarAppend
append x 123
lappend x 456
set info
-} {x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}}
+} {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}}
# Basic unset-tracing on variables
test trace-4.1 {trace variable unsets} {
catch {unset x}
set info {}
- trace var x u traceScalar
+ trace add variable x unset traceScalar
catch {unset x}
set info
-} {x {} u 1 {can't read "x": no such variable}}
+} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.2 {variable mustn't exist during unset trace} {
catch {unset x}
set x 1234
set info {}
- trace var x u traceScalar
+ trace add variable x unset traceScalar
unset x
set info
-} {x {} u 1 {can't read "x": no such variable}}
+} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.3 {unset traces mustn't be called during reads and writes} {
catch {unset x}
set info {}
- trace var x u traceScalar
+ trace add variable x unset traceScalar
set x 44
set x
set info
catch {unset x}
set x(0) 18
set info {}
- trace var x(1) u traceArray
+ trace add variable x(1) unset traceArray
catch {unset x(1)}
set info
-} {x 1 u 1 {can't read "x(1)": no such element in array}}
+} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.5 {trace unsets on array elements} {
catch {unset x}
set x(1) 18
set info {}
- trace var x(1) u traceArray
+ trace add variable x(1) unset traceArray
unset x(1)
set info
-} {x 1 u 1 {can't read "x(1)": no such element in array}}
+} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.6 {trace unsets on array elements} {
catch {unset x}
set x(1) 18
set info {}
- trace var x(1) u traceArray
+ trace add variable x(1) unset traceArray
unset x
set info
-} {x 1 u 1 {can't read "x(1)": no such variable}}
+} {x 1 unset 1 {can't read "x(1)": no such variable}}
test trace-4.7 {trace unsets on whole arrays} {
catch {unset x}
set x(1) 18
set info {}
- trace var x u traceProc
+ trace add variable x unset traceProc
catch {unset x(0)}
set info
} {}
set x(2) 144
set x(3) 14
set info {}
- trace var x u traceProc
+ trace add variable x unset traceProc
unset x(1)
set info
-} {x 1 u}
+} {x 1 unset}
test trace-4.9 {trace unsets on whole arrays} {
catch {unset x}
set x(1) 18
set x(2) 144
set x(3) 14
set info {}
- trace var x u traceProc
+ trace add variable x unset traceProc
unset x
set info
-} {x {} u}
+} {x {} unset}
+# Array tracing on variables
+test trace-5.1 {array traces fire on accesses via [array]} {
+ catch {unset x}
+ set x(b) 2
+ trace add variable x array traceArray2
+ set ::info {}
+ array set x {a 1}
+ set ::info
+} {x {} array}
+test trace-5.2 {array traces do not fire on normal accesses} {
+ catch {unset x}
+ set x(b) 2
+ trace add variable x array traceArray2
+ set ::info {}
+ set x(a) 1
+ set x(b) $x(a)
+ set ::info
+} {}
+test trace-5.3 {array traces do not outlive variable} {
+ catch {unset x}
+ trace add variable x array traceArray2
+ set ::info {}
+ set x(a) 1
+ unset x
+ array set x {a 1}
+ set ::info
+} {}
+test trace-5.4 {array traces properly listed in trace information} {
+ catch {unset x}
+ trace add variable x array traceArray2
+ set result [trace info variable x]
+ set result
+} [list [list array traceArray2]]
+test trace-5.5 {array traces properly listed in trace information} {
+ catch {unset x}
+ trace variable x a traceArray2
+ set result [trace vinfo x]
+ set result
+} [list [list a traceArray2]]
+test trace-5.6 {array traces don't fire on scalar variables} {
+ catch {unset x}
+ set x foo
+ trace add variable x array traceArray2
+ set ::info {}
+ catch {array set x {a 1}}
+ set ::info
+} {}
+test trace-5.7 {array traces fire for undefined variables} {
+ catch {unset x}
+ trace add variable x array traceArray2
+ set ::info {}
+ array set x {a 1}
+ set ::info
+} {x {} array}
+test trace-5.8 {array traces fire for undefined variables} {
+ catch {unset x}
+ trace add variable x array {set x(foo) 1 ;#}
+ set res "names: [array names x]"
+} {names: foo}
+
# Trace multiple trace types at once.
-test trace-5.1 {multiple ops traced at once} {
+test trace-6.1 {multiple ops traced at once} {
catch {unset x}
set info {}
- trace var x rwu traceProc
+ trace add variable x {read write unset} traceProc
catch {set x}
set x 22
set x
set x 33
unset x
set info
-} {x {} r x {} w x {} r x {} w x {} u}
-test trace-5.2 {multiple ops traced on array element} {
+} {x {} read x {} write x {} read x {} write x {} unset}
+test trace-6.2 {multiple ops traced on array element} {
catch {unset x}
set info {}
- trace var x(0) rwu traceProc
+ trace add variable x(0) {read write unset} traceProc
catch {set x(0)}
set x(0) 22
set x(0)
unset x(0)
unset x
set info
-} {x 0 r x 0 w x 0 r x 0 w x 0 u}
-test trace-5.3 {multiple ops traced on whole array} {
+} {x 0 read x 0 write x 0 read x 0 write x 0 unset}
+test trace-6.3 {multiple ops traced on whole array} {
catch {unset x}
set info {}
- trace var x rwu traceProc
+ trace add variable x {read write unset} traceProc
catch {set x(0)}
set x(0) 22
set x(0)
unset x(0)
unset x
set info
-} {x 0 w x 0 r x 0 w x 0 u x {} u}
+} {x 0 write x 0 read x 0 write x 0 unset x {} unset}
# Check order of invocation of traces
-test trace-6.1 {order of invocation of traces} {
+test trace-7.1 {order of invocation of traces} {
catch {unset x}
set info {}
- trace var x r "traceTag 1"
- trace var x r "traceTag 2"
- trace var x r "traceTag 3"
+ trace add variable x read "traceTag 1"
+ trace add variable x read "traceTag 2"
+ trace add variable x read "traceTag 3"
catch {set x}
set x 22
set x
set info
} {3 2 1 3 2 1}
-test trace-6.2 {order of invocation of traces} {
+test trace-7.2 {order of invocation of traces} {
catch {unset x}
set x(0) 44
set info {}
- trace var x(0) r "traceTag 1"
- trace var x(0) r "traceTag 2"
- trace var x(0) r "traceTag 3"
+ trace add variable x(0) read "traceTag 1"
+ trace add variable x(0) read "traceTag 2"
+ trace add variable x(0) read "traceTag 3"
set x(0)
set info
} {3 2 1}
-test trace-6.3 {order of invocation of traces} {
+test trace-7.3 {order of invocation of traces} {
catch {unset x}
set x(0) 44
set info {}
- trace var x(0) r "traceTag 1"
- trace var x r "traceTag A1"
- trace var x(0) r "traceTag 2"
- trace var x r "traceTag A2"
- trace var x(0) r "traceTag 3"
- trace var x r "traceTag A3"
+ trace add variable x(0) read "traceTag 1"
+ trace add variable x read "traceTag A1"
+ trace add variable x(0) read "traceTag 2"
+ trace add variable x read "traceTag A2"
+ trace add variable x(0) read "traceTag 3"
+ trace add variable x read "traceTag A3"
set x(0)
set info
} {A3 A2 A1 3 2 1}
# Check effects of errors in trace procedures
-test trace-7.1 {error returns from traces} {
+test trace-8.1 {error returns from traces} {
catch {unset x}
set x 123
set info {}
- trace var x r "traceTag 1"
- trace var x r traceError
+ trace add variable x read "traceTag 1"
+ trace add variable x read traceError
list [catch {set x} msg] $msg $info
} {1 {can't read "x": trace returned error} {}}
-test trace-7.2 {error returns from traces} {
+test trace-8.2 {error returns from traces} {
catch {unset x}
set x 123
set info {}
- trace var x w "traceTag 1"
- trace var x w traceError
+ trace add variable x write "traceTag 1"
+ trace add variable x write traceError
list [catch {set x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
-test trace-7.3 {error returns from traces} {
+test trace-8.3 {error returns from traces} {
catch {unset x}
set x 123
set info {}
- trace var x w traceError
+ trace add variable x write traceError
list [catch {append x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
-test trace-7.4 {error returns from traces} {
+test trace-8.4 {error returns from traces} {
catch {unset x}
set x 123
set info {}
- trace var x u "traceTag 1"
- trace var x u traceError
+ trace add variable x unset "traceTag 1"
+ trace add variable x unset traceError
list [catch {unset x} msg] $msg $info
} {0 {} 1}
-test trace-7.5 {error returns from traces} {
+test trace-8.5 {error returns from traces} {
catch {unset x}
set x(0) 123
set info {}
- trace var x(0) r "traceTag 1"
- trace var x r "traceTag 2"
- trace var x r traceError
- trace var x r "traceTag 3"
+ trace add variable x(0) read "traceTag 1"
+ trace add variable x read "traceTag 2"
+ trace add variable x read traceError
+ trace add variable x read "traceTag 3"
list [catch {set x(0)} msg] $msg $info
} {1 {can't read "x(0)": trace returned error} 3}
-test trace-7.6 {error returns from traces} {
+test trace-8.6 {error returns from traces} {
catch {unset x}
set x 123
- trace var x u traceError
+ trace add variable x unset traceError
list [catch {unset x} msg] $msg
} {0 {}}
-test trace-7.7 {error returns from traces} {
+test trace-8.7 {error returns from traces} {
# This test just makes sure that the memory for the error message
# gets deallocated correctly when the trace is invoked again or
# when the trace is deleted.
catch {unset x}
set x 123
- trace var x r traceError
+ trace add variable x read traceError
catch {set x}
catch {set x}
- trace vdelete x r traceError
+ trace remove variable x read traceError
+} {}
+test trace-8.8 {error returns from traces} {
+ # Yet more elaborate memory corruption testing that checks nothing
+ # bad happens when the trace deletes itself and installs something
+ # new. Alas, there is no neat way to guarantee that this test will
+ # fail if there is a problem, but that's life and with the new code
+ # it should *never* fail.
+ #
+ # Adapted from Bug #219393 reported by Don Porter.
+ catch {rename ::foo {}}
+ proc foo {old args} {
+ trace remove variable ::x write [list foo $old]
+ trace add variable ::x write [list foo $::x]
+ error "foo"
+ }
+ catch {unset ::x ::y}
+ set x junk
+ trace add variable ::x write [list foo $x]
+ for {set y 0} {$y<100} {incr y} {
+ catch {set x junk}
+ }
+ unset x
} {}
# Check to see that variables are expunged before trace
# procedures are invoked, so trace procedure can even manipulate
# a new copy of the variables.
-test trace-8.1 {be sure variable is unset before trace is called} {
+test trace-9.1 {be sure variable is unset before trace is called} {
catch {unset x}
set x 33
set info {}
- trace var x u {traceCheck {uplevel set x}}
+ trace add variable x unset {traceCheck {uplevel set x}}
unset x
set info
} {1 {can't read "x": no such variable}}
-test trace-8.2 {be sure variable is unset before trace is called} {
+test trace-9.2 {be sure variable is unset before trace is called} {
catch {unset x}
set x 33
set info {}
- trace var x u {traceCheck {uplevel set x 22}}
+ trace add variable x unset {traceCheck {uplevel set x 22}}
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
-test trace-8.3 {be sure traces are cleared before unset trace called} {
+test trace-9.3 {be sure traces are cleared before unset trace called} {
catch {unset x}
set x 33
set info {}
- trace var x u {traceCheck {uplevel trace vinfo x}}
+ trace add variable x unset {traceCheck {uplevel trace info variable x}}
unset x
set info
} {0 {}}
-test trace-8.4 {set new trace during unset trace} {
+test trace-9.4 {set new trace during unset trace} {
catch {unset x}
set x 33
set info {}
- trace var x u {traceCheck {global x; trace var x u traceProc}}
+ trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
unset x
- concat $info [trace vinfo x]
-} {0 {} {u traceProc}}
+ concat $info [trace info variable x]
+} {0 {} {unset traceProc}}
-test trace-9.1 {make sure array elements are unset before traces are called} {
+test trace-10.1 {make sure array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
- trace var x(0) u {traceCheck {uplevel set x(0)}}
+ trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
unset x(0)
set info
} {1 {can't read "x(0)": no such element in array}}
-test trace-9.2 {make sure array elements are unset before traces are called} {
+test trace-10.2 {make sure array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
- trace var x(0) u {traceCheck {uplevel set x(0) zzz}}
+ trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
-test trace-9.3 {array elements are unset before traces are called} {
+test trace-10.3 {array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
- trace var x(0) u {traceCheck {global x; trace vinfo x(0)}}
+ trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
unset x(0)
set info
} {0 {}}
-test trace-9.4 {set new array element trace during unset trace} {
+test trace-10.4 {set new array element trace during unset trace} {
catch {unset x}
set x(0) 33
set info {}
- trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}}
+ trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
catch {unset x(0)}
- concat $info [trace vinfo x(0)]
-} {0 {} {r {}}}
+ concat $info [trace info variable x(0)]
+} {0 {} {read {}}}
-test trace-10.1 {make sure arrays are unset before traces are called} {
+test trace-11.1 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
- trace var x u {traceCheck {uplevel set x(0)}}
+ trace add variable x unset {traceCheck {uplevel set x(0)}}
unset x
set info
} {1 {can't read "x(0)": no such variable}}
-test trace-10.2 {make sure arrays are unset before traces are called} {
+test trace-11.2 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
- trace var x u {traceCheck {uplevel set x(y) 22}}
+ trace add variable x unset {traceCheck {uplevel set x(y) 22}}
unset x
concat $info [list [catch {set x(y)} msg] $msg]
} {0 22 0 22}
-test trace-10.3 {make sure arrays are unset before traces are called} {
+test trace-11.3 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
- trace var x u {traceCheck {uplevel array exists x}}
+ trace add variable x unset {traceCheck {uplevel array exists x}}
unset x
set info
} {0 0}
-test trace-10.4 {make sure arrays are unset before traces are called} {
+test trace-11.4 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
- set cmd {traceCheck {uplevel {trace vinfo x}}}
- trace var x u $cmd
+ set cmd {traceCheck {uplevel {trace info variable x}}}
+ trace add variable x unset $cmd
unset x
set info
} {0 {}}
-test trace-10.5 {set new array trace during unset trace} {
+test trace-11.5 {set new array trace during unset trace} {
catch {unset x}
set x(y) 33
set info {}
- trace var x u {traceCheck {global x; trace var x r {}}}
+ trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
unset x
- concat $info [trace vinfo x]
-} {0 {} {r {}}}
-test trace-10.6 {create scalar during array unset trace} {
+ concat $info [trace info variable x]
+} {0 {} {read {}}}
+test trace-11.6 {create scalar during array unset trace} {
catch {unset x}
set x(y) 33
set info {}
- trace var x u {traceCheck {global x; set x 44}}
+ trace add variable x unset {traceCheck {global x; set x 44}}
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 44 0 44}
# Check special conditions (e.g. errors) in Tcl_TraceVar2.
-test trace-11.1 {creating array when setting variable traces} {
+test trace-12.1 {creating array when setting variable traces} {
catch {unset x}
set info {}
- trace var x(0) w traceProc
+ trace add variable x(0) write traceProc
list [catch {set x 22} msg] $msg
} {1 {can't set "x": variable is array}}
-test trace-11.2 {creating array when setting variable traces} {
+test trace-12.2 {creating array when setting variable traces} {
catch {unset x}
set info {}
- trace var x(0) w traceProc
+ trace add variable x(0) write traceProc
list [catch {set x(0)} msg] $msg
} {1 {can't read "x(0)": no such element in array}}
-test trace-11.3 {creating array when setting variable traces} {
+test trace-12.3 {creating array when setting variable traces} {
catch {unset x}
set info {}
- trace var x(0) w traceProc
+ trace add variable x(0) write traceProc
set x(0) 22
set info
-} {x 0 w}
-test trace-11.4 {creating variable when setting variable traces} {
+} {x 0 write}
+test trace-12.4 {creating variable when setting variable traces} {
catch {unset x}
set info {}
- trace var x w traceProc
+ trace add variable x write traceProc
list [catch {set x} msg] $msg
} {1 {can't read "x": no such variable}}
-test trace-11.5 {creating variable when setting variable traces} {
+test trace-12.5 {creating variable when setting variable traces} {
catch {unset x}
set info {}
- trace var x w traceProc
+ trace add variable x write traceProc
set x 22
set info
-} {x {} w}
-test trace-11.6 {creating variable when setting variable traces} {
+} {x {} write}
+test trace-12.6 {creating variable when setting variable traces} {
catch {unset x}
set info {}
- trace var x w traceProc
+ trace add variable x write traceProc
set x(0) 22
set info
-} {x 0 w}
-test trace-11.7 {create array element during read trace} {
+} {x 0 write}
+test trace-12.7 {create array element during read trace} {
catch {unset x}
set x(2) zzz
- trace var x r {traceCrtElement xyzzy}
+ trace add variable x read {traceCrtElement xyzzy}
list [catch {set x(3)} msg] $msg
} {0 xyzzy}
-test trace-11.8 {errors when setting variable traces} {
+test trace-12.8 {errors when setting variable traces} {
catch {unset x}
set x 44
- list [catch {trace var x(0) w traceProc} msg] $msg
+ list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}
# Check deleting one trace from another.
-test trace-12.1 {delete one trace from another} {
+test trace-13.1 {delete one trace from another} {
proc delTraces {args} {
global x
- trace vdel x r {traceTag 2}
- trace vdel x r {traceTag 3}
- trace vdel x r {traceTag 4}
+ trace remove variable x read {traceTag 2}
+ trace remove variable x read {traceTag 3}
+ trace remove variable x read {traceTag 4}
}
catch {unset x}
set x 44
set info {}
- trace var x r {traceTag 1}
- trace var x r {traceTag 2}
- trace var x r {traceTag 3}
- trace var x r {traceTag 4}
- trace var x r delTraces
- trace var x r {traceTag 5}
+ trace add variable x read {traceTag 1}
+ trace add variable x read {traceTag 2}
+ trace add variable x read {traceTag 3}
+ trace add variable x read {traceTag 4}
+ trace add variable x read delTraces
+ trace add variable x read {traceTag 5}
set x
set info
} {5 1}
# Check operation and syntax of "trace" command.
-test trace-13.1 {trace command (overall)} {
+# Syntax for adding/removing variable and command traces is basically the
+# same:
+# trace add variable name opList command
+# trace remove variable name opList command
+#
+# The following loops just get all the common "wrong # args" tests done.
+
+set i 0
+set start "wrong # args:"
+foreach type {variable command} {
+ foreach op {add remove} {
+ test trace-14.0.[incr i] "trace command, wrong # args errors" {
+ list [catch {trace $op $type} msg] $msg
+ } [list 1 "$start should be \"trace $op $type name opList command\""]
+ test trace-14.0.[incr i] "trace command wrong # args errors" {
+ list [catch {trace $op $type foo} msg] $msg
+ } [list 1 "$start should be \"trace $op $type name opList command\""]
+ test trace-14.0.[incr i] "trace command, wrong # args errors" {
+ list [catch {trace $op $type foo bar} msg] $msg
+ } [list 1 "$start should be \"trace $op $type name opList command\""]
+ test trace-14.0.[incr i] "trace command, wrong # args errors" {
+ list [catch {trace $op $type foo bar baz boo} msg] $msg
+ } [list 1 "$start should be \"trace $op $type name opList command\""]
+ }
+ test trace-14.0.[incr i] "trace command, wrong # args errors" {
+ list [catch {trace info $type foo bar} msg] $msg
+ } [list 1 "$start should be \"trace info $type name\""]
+ test trace-14.0.[incr i] "trace command, wrong # args errors" {
+ list [catch {trace info $type} msg] $msg
+ } [list 1 "$start should be \"trace info $type name\""]
+}
+
+test trace-14.1 "trace command, wrong # args errors" {
list [catch {trace} msg] $msg
-} {1 {wrong # args: should be "trace option [arg arg ...]"}}
-test trace-13.2 {trace command (overall)} {
+} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
+test trace-14.2 "trace command, wrong # args errors" {
+ list [catch {trace add} msg] $msg
+} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
+test trace-14.3 "trace command, wrong # args errors" {
+ list [catch {trace remove} msg] $msg
+} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
+test trace-14.4 "trace command, wrong # args errors" {
+ list [catch {trace info} msg] $msg
+} [list 1 "wrong # args: should be \"trace info type ?arg arg ...?\""]
+
+test trace-14.5 {trace command, invalid option} {
list [catch {trace gorp} msg] $msg
-} {1 {bad option "gorp": must be variable, vdelete, or vinfo}}
-test trace-13.3 {trace command ("variable" option)} {
+} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
+
+# Again, [trace ... command] and [trace ... variable] share syntax and
+# error message styles for their opList options; these loops test those
+# error messages.
+
+set i 0
+set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"]
+set abbvs [list {a r u w} {d r} {}]
+proc x {} {}
+foreach type {variable command execution} err $errs abbvlist $abbvs {
+ foreach op {add remove} {
+ test trace-14.6.[incr i] "trace $op $type errors" {
+ list [catch {trace $op $type x {y z w} a} msg] $msg
+ } [list 1 "bad operation \"y\": must be $err"]
+ foreach abbv $abbvlist {
+ test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {
+ list [catch {trace $op $type x $abbv a} msg] $msg
+ } [list 1 "bad operation \"$abbv\": must be $err"]
+ }
+ test trace-14.6.[incr i] "trace $op $type rejects null opList" {
+ list [catch {trace $op $type x {} a} msg] $msg
+ } [list 1 "bad operation list \"\": must be one or more of $err"]
+ }
+}
+rename x {}
+
+test trace-14.7 {trace command, "trace variable" errors} {
+ list [catch {trace variable} msg] $msg
+} [list 1 "wrong # args: should be \"trace variable name ops command\""]
+test trace-14.8 {trace command, "trace variable" errors} {
+ list [catch {trace variable x} msg] $msg
+} [list 1 "wrong # args: should be \"trace variable name ops command\""]
+test trace-14.9 {trace command, "trace variable" errors} {
list [catch {trace variable x y} msg] $msg
-} {1 {wrong # args: should be "trace variable name ops command"}}
-test trace-13.4 {trace command ("variable" option)} {
- list [catch {trace var x y z z2} msg] $msg
-} {1 {wrong # args: should be "trace variable name ops command"}}
-test trace-13.5 {trace command ("variable" option)} {
- list [catch {trace var x y z} msg] $msg
-} {1 {bad operations "y": should be one or more of rwu}}
-test trace-13.6 {trace command ("vdelete" option)} {
- list [catch {trace vdelete x y} msg] $msg
-} {1 {wrong # args: should be "trace vdelete name ops command"}}
-test trace-13.7 {trace command ("vdelete" option)} {
- list [catch {trace vdelete x y z foo} msg] $msg
-} {1 {wrong # args: should be "trace vdelete name ops command"}}
-test trace-13.8 {trace command ("vdelete" option)} {
- list [catch {trace vdelete x y z} msg] $msg
-} {1 {bad operations "y": should be one or more of rwu}}
-test trace-13.9 {trace command ("vdelete" option)} {
- catch {unset x}
- set info {}
- trace var x w traceProc
- trace vdelete x w traceProc
+} [list 1 "wrong # args: should be \"trace variable name ops command\""]
+test trace-14.10 {trace command, "trace variable" errors} {
+ list [catch {trace variable x y z w} msg] $msg
+} [list 1 "wrong # args: should be \"trace variable name ops command\""]
+test trace-14.11 {trace command, "trace variable" errors} {
+ list [catch {trace variable x y z} msg] $msg
+} [list 1 "bad operations \"y\": should be one or more of rwua"]
+
+
+test trace-14.9 {trace command ("remove variable" option)} {
+ catch {unset x}
+ set info {}
+ trace add variable x write traceProc
+ trace remove variable x write traceProc
} {}
-test trace-13.10 {trace command ("vdelete" option)} {
+test trace-14.10 {trace command ("remove variable" option)} {
catch {unset x}
set info {}
- trace var x w traceProc
- trace vdelete x w traceProc
+ trace add variable x write traceProc
+ trace remove variable x write traceProc
set x 12345
set info
} {}
-test trace-13.11 {trace command ("vdelete" option)} {
+test trace-14.11 {trace command ("remove variable" option)} {
catch {unset x}
set info {}
- trace var x w {traceTag 1}
- trace var x w traceProc
- trace var x w {traceTag 2}
+ trace add variable x write {traceTag 1}
+ trace add variable x write traceProc
+ trace add variable x write {traceTag 2}
set x yy
- trace vdelete x w traceProc
+ trace remove variable x write traceProc
set x 12345
- trace vdelete x w {traceTag 1}
+ trace remove variable x write {traceTag 1}
set x foo
- trace vdelete x w {traceTag 2}
+ trace remove variable x write {traceTag 2}
set x gorp
set info
-} {2 x {} w 1 2 1 2}
-test trace-13.12 {trace command ("vdelete" option)} {
+} {2 x {} write 1 2 1 2}
+test trace-14.12 {trace command ("remove variable" option)} {
catch {unset x}
set info {}
- trace var x w {traceTag 1}
- trace vdelete x w non_existent
+ trace add variable x write {traceTag 1}
+ trace remove variable x write non_existent
set x 12345
set info
} {1}
-test trace-13.13 {trace command ("vinfo" option)} {
- list [catch {trace vinfo} msg] $msg]
-} {1 {wrong # args: should be "trace vinfo name"]}}
-test trace-13.14 {trace command ("vinfo" option)} {
- list [catch {trace vinfo x y} msg] $msg]
-} {1 {wrong # args: should be "trace vinfo name"]}}
-test trace-13.15 {trace command ("vinfo" option)} {
- catch {unset x}
- trace var x w {traceTag 1}
- trace var x w traceProc
- trace var x w {traceTag 2}
- trace vinfo x
-} {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}}
-test trace-13.16 {trace command ("vinfo" option)} {
- catch {unset x}
- trace vinfo x
+test trace-14.15 {trace command ("list variable" option)} {
+ catch {unset x}
+ trace add variable x write {traceTag 1}
+ trace add variable x write traceProc
+ trace add variable x write {traceTag 2}
+ trace info variable x
+} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
+test trace-14.16 {trace command ("list variable" option)} {
+ catch {unset x}
+ trace info variable x
} {}
-test trace-13.17 {trace command ("vinfo" option)} {
+test trace-14.17 {trace command ("list variable" option)} {
catch {unset x}
- trace vinfo x(0)
+ trace info variable x(0)
} {}
-test trace-13.18 {trace command ("vinfo" option)} {
+test trace-14.18 {trace command ("list variable" option)} {
catch {unset x}
set x 44
- trace vinfo x(0)
+ trace info variable x(0)
} {}
-test trace-13.19 {trace command ("vinfo" option)} {
+test trace-14.19 {trace command ("list variable" option)} {
catch {unset x}
set x 44
- trace var x w {traceTag 1}
- proc check {} {global x; trace vinfo x}
+ trace add variable x write {traceTag 1}
+ proc check {} {global x; trace info variable x}
check
-} {{w {traceTag 1}}}
+} {{write {traceTag 1}}}
# Check fancy trace commands (long ones, weird arguments, etc.)
-test trace-14.1 {long trace command} {
+test trace-15.1 {long trace command} {
catch {unset x}
set info {}
- trace var x w {traceTag {This is a very very long argument. It's \
+ trace add variable x write {traceTag {This is a very very long argument. It's \
designed to test out the facilities of TraceVarProc for dealing \
with such long arguments by malloc-ing space. One possibility \
is that space doesn't get freed properly. If this happens, then \
with such long arguments by malloc-ing space. One possibility \
is that space doesn't get freed properly. If this happens, then \
invoking this test over and over again will eventually leak memory.}
-test trace-14.2 {long trace command result to ignore} {
+test trace-15.2 {long trace command result to ignore} {
proc longResult {args} {return "quite a bit of text, designed to
generate a core leak if this command file is invoked over and over again
and memory isn't being recycled correctly"}
catch {unset x}
- trace var x w longResult
+ trace add variable x write longResult
set x 44
set x 5
set x abcde
} abcde
-test trace-14.3 {special list-handling in trace commands} {
+test trace-15.3 {special list-handling in trace commands} {
catch {unset "x y z"}
set "x y z(a\n\{)" 44
set info {}
- trace var "x y z(a\n\{)" w traceProc
+ trace add variable "x y z(a\n\{)" write traceProc
set "x y z(a\n\{)" 33
set info
-} "{x y z} a\\n\\{ w"
+} "{x y z} a\\n\\\{ write"
# Check for proper handling of unsets during traces.
lappend info $string
}
-test trace-15.1 {unsets during read traces} {
+test trace-16.1 {unsets during read traces} {
catch {unset y}
set y 1234
set info {}
- trace var y r {traceUnset y}
- trace var y u {traceAppend unset}
+ trace add variable y read {traceUnset y}
+ trace add variable y unset {traceAppend unset}
lappend info [catch {set y} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
-test trace-15.2 {unsets during read traces} {
+test trace-16.2 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) r {traceUnset y(0)}
+ trace add variable y(0) read {traceUnset y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
-test trace-15.3 {unsets during read traces} {
+test trace-16.3 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) r {traceUnset y}
+ trace add variable y(0) read {traceUnset y}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
-test trace-15.4 {unsets during read traces} {
+test trace-16.4 {unsets during read traces} {
catch {unset y}
set y 1234
set info {}
- trace var y r {traceReset y y}
+ trace add variable y read {traceReset y y}
lappend info [catch {set y} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
-test trace-15.5 {unsets during read traces} {
+test trace-16.5 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) r {traceReset y(0) y(0)}
+ trace add variable y(0) read {traceReset y(0) y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
-test trace-15.6 {unsets during read traces} {
+test trace-16.6 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) r {traceReset y y(0)}
+ trace add variable y(0) read {traceReset y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}}
-test trace-15.7 {unsets during read traces} {
+test trace-16.7 {unsets during read traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) r {traceReset2 y y(0)}
+ trace add variable y(0) read {traceReset2 y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
-test trace-15.8 {unsets during write traces} {
+test trace-16.8 {unsets during write traces} {
catch {unset y}
set y 1234
set info {}
- trace var y w {traceUnset y}
- trace var y u {traceAppend unset}
+ trace add variable y write {traceUnset y}
+ trace add variable y unset {traceAppend unset}
lappend info [catch {set y xxx} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
-test trace-15.9 {unsets during write traces} {
+test trace-16.9 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) w {traceUnset y(0)}
+ trace add variable y(0) write {traceUnset y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
-test trace-15.10 {unsets during write traces} {
+test trace-16.10 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) w {traceUnset y}
+ trace add variable y(0) write {traceUnset y}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
-test trace-15.11 {unsets during write traces} {
+test trace-16.11 {unsets during write traces} {
catch {unset y}
set y 1234
set info {}
- trace var y w {traceReset y y}
+ trace add variable y write {traceReset y y}
lappend info [catch {set y xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
-test trace-15.12 {unsets during write traces} {
+test trace-16.12 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) w {traceReset y(0) y(0)}
+ trace add variable y(0) write {traceReset y(0) y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
-test trace-15.13 {unsets during write traces} {
+test trace-16.13 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) w {traceReset y y(0)}
+ trace add variable y(0) write {traceReset y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
-test trace-15.14 {unsets during write traces} {
+test trace-16.14 {unsets during write traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) w {traceReset2 y y(0)}
+ trace add variable y(0) write {traceReset2 y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
-test trace-15.15 {unsets during unset traces} {
+test trace-16.15 {unsets during unset traces} {
catch {unset y}
set y 1234
set info {}
- trace var y u {traceUnset y}
+ trace add variable y unset {traceUnset y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}}
-test trace-15.16 {unsets during unset traces} {
+test trace-16.16 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) u {traceUnset y(0)}
+ trace add variable y(0) unset {traceUnset y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}}
-test trace-15.17 {unsets during unset traces} {
+test trace-16.17 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) u {traceUnset y}
+ trace add variable y(0) unset {traceUnset y}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
-test trace-15.18 {unsets during unset traces} {
+test trace-16.18 {unsets during unset traces} {
catch {unset y}
set y 1234
set info {}
- trace var y u {traceReset2 y y}
+ trace add variable y unset {traceReset2 y y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
-test trace-15.19 {unsets during unset traces} {
+test trace-16.19 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) u {traceReset2 y(0) y(0)}
+ trace add variable y(0) unset {traceReset2 y(0) y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
-test trace-15.20 {unsets during unset traces} {
+test trace-16.20 {unsets during unset traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) u {traceReset2 y y(0)}
+ trace add variable y(0) unset {traceReset2 y y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
-test trace-15.21 {unsets cancelling traces} {
+test trace-16.21 {unsets cancelling traces} {
catch {unset y}
set y 1234
set info {}
- trace var y r {traceAppend first}
- trace var y r {traceUnset y}
- trace var y r {traceAppend third}
- trace var y u {traceAppend unset}
+ trace add variable y read {traceAppend first}
+ trace add variable y read {traceUnset y}
+ trace add variable y read {traceAppend third}
+ trace add variable y unset {traceAppend unset}
lappend info [catch {set y} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
-test trace-15.22 {unsets cancelling traces} {
+test trace-16.22 {unsets cancelling traces} {
catch {unset y}
set y(0) 1234
set info {}
- trace var y(0) r {traceAppend first}
- trace var y(0) r {traceUnset y}
- trace var y(0) r {traceAppend third}
- trace var y(0) u {traceAppend unset}
+ trace add variable y(0) read {traceAppend first}
+ trace add variable y(0) read {traceUnset y}
+ trace add variable y(0) read {traceAppend third}
+ trace add variable y(0) unset {traceAppend unset}
lappend info [catch {set y(0)} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
# Check various non-interference between traces and other things.
-test trace-16.1 {trace doesn't prevent unset errors} {
+test trace-17.1 {trace doesn't prevent unset errors} {
catch {unset x}
set info {}
- trace var x u {traceProc}
+ trace add variable x unset {traceProc}
list [catch {unset x} msg] $msg $info
-} {1 {can't unset "x": no such variable} {x {} u}}
-test trace-16.2 {traced variables must survive procedure exits} {
+} {1 {can't unset "x": no such variable} {x {} unset}}
+test trace-17.2 {traced variables must survive procedure exits} {
catch {unset x}
- proc p1 {} {global x; trace var x w traceProc}
+ proc p1 {} {global x; trace add variable x write traceProc}
p1
- trace vinfo x
-} {{w traceProc}}
-test trace-16.3 {traced variables must survive procedure exits} {
+ trace info variable x
+} {{write traceProc}}
+test trace-17.3 {traced variables must survive procedure exits} {
catch {unset x}
set info {}
- proc p1 {} {global x; trace var x w traceProc}
+ proc p1 {} {global x; trace add variable x write traceProc}
p1
set x 44
set info
-} {x {} w}
+} {x {} write}
# Be sure that procedure frames are released before unset traces
# are invoked.
-test trace-17.1 {unset traces on procedure returns} {
+test trace-18.1 {unset traces on procedure returns} {
proc p1 {x y} {set a 44; p2 14}
- proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}}
+ proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}}
set info {}
p1 foo bar
set info
} {0 {a x y}}
+test trace-18.2 {namespace delete / trace vdelete combo} {
+ namespace eval ::foo {
+ variable x 123
+ }
+ proc p1 args {
+ trace vdelete ::foo::x u p1
+ }
+ trace variable ::foo::x u p1
+ namespace delete ::foo
+ info exists ::foo::x
+} 0
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
catch {unset x}
catch {unset y}
-# cleanup
-::tcltest::cleanupTests
-return
+test trace-18.2 {trace add command (command existence)} {
+ # Just in case!
+ catch {rename nosuchname ""}
+ list [catch {trace add command nosuchname rename traceCommand} msg] $msg
+} {1 {unknown command "nosuchname"}}
+test trace-18.3 {trace add command (command existence in ns)} {
+ list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg
+} {1 {unknown command "nosuchns::nosuchname"}}
+
+
+test trace-19.1 {trace add command (rename option)} {
+ proc foo {} {}
+ catch {rename bar {}}
+ trace add command foo rename traceCommand
+ rename foo bar
+ set info
+} {foo bar rename}
+test trace-19.2 {traces stick with renamed commands} {
+ proc foo {} {}
+ catch {rename bar {}}
+ trace add command foo rename traceCommand
+ rename foo bar
+ rename bar foo
+ set info
+} {bar foo rename}
+test trace-19.2.1 {trace add command rename trace exists} {
+ proc foo {} {}
+ trace add command foo rename traceCommand
+ trace info command foo
+} {{rename traceCommand}}
+test trace-19.3 {command rename traces don't fire on command deletion} {
+ proc foo {} {}
+ set info {}
+ trace add command foo rename traceCommand
+ rename foo {}
+ set info
+} {}
+test trace-19.4 {trace add command rename doesn't trace recreated commands} {
+ proc foo {} {}
+ catch {rename bar {}}
+ trace add command foo rename traceCommand
+ proc foo {} {}
+ rename foo bar
+ set info
+} {}
+test trace-19.5 {trace add command deleted removes traces} {
+ proc foo {} {}
+ trace add command foo rename traceCommand
+ proc foo {} {}
+ trace info command foo
+} {}
+
+namespace eval tc {}
+proc tc::tcfoo {} {}
+test trace-19.6 {trace add command rename in namespace} {
+ trace add command tc::tcfoo rename traceCommand
+ rename tc::tcfoo tc::tcbar
+ set info
+} {tc::tcfoo tc::tcbar rename}
+test trace-19.7 {trace add command rename in namespace back again} {
+ rename tc::tcbar tc::tcfoo
+ set info
+} {tc::tcbar tc::tcfoo rename}
+test trace-19.8 {trace add command rename in namespace to out of namespace} {
+ rename tc::tcfoo tcbar
+ set info
+} {tc::tcfoo tcbar rename}
+test trace-19.9 {trace add command rename back into namespace} {
+ rename tcbar tc::tcfoo
+ set info
+} {tcbar tc::tcfoo rename}
+test trace-19.10 {trace add command failed rename doesn't trigger trace} {
+ set info {}
+ proc foo {} {}
+ proc bar {} {}
+ trace add command foo {rename delete} traceCommand
+ catch {rename foo bar}
+ set info
+} {}
+catch {rename foo {}}
+catch {rename bar {}}
+
+# Make sure it exists again
+proc foo {} {}
+
+test trace-20.1 {trace add command (delete option)} {
+ trace add command foo delete traceCommand
+ rename foo ""
+ set info
+} {::foo {} delete}
+test trace-20.2 {trace add command delete doesn't trace recreated commands} {
+ set info {}
+ proc foo {} {}
+ rename foo ""
+ set info
+} {}
+test trace-20.2.1 {trace add command delete trace info} {
+ proc foo {} {}
+ trace add command foo delete traceCommand
+ trace info command foo
+} {{delete traceCommand}}
+test trace-20.3 {trace add command implicit delete} {
+ proc foo {} {}
+ trace add command foo delete traceCommand
+ proc foo {} {}
+ set info
+} {::foo {} delete}
+test trace-20.3.1 {trace add command delete trace info} {
+ proc foo {} {}
+ trace info command foo
+} {}
+test trace-20.4 {trace add command rename followed by delete} {
+ set infotemp {}
+ proc foo {} {}
+ trace add command foo {rename delete} traceCommand
+ rename foo bar
+ lappend infotemp $info
+ rename bar {}
+ lappend infotemp $info
+ set info $infotemp
+ unset infotemp
+ set info
+} {{foo bar rename} {::bar {} delete}}
+catch {rename foo {}}
+catch {rename bar {}}
+
+test trace-20.5 {trace add command rename and delete} {
+ set infotemp {}
+ set info {}
+ proc foo {} {}
+ trace add command foo {rename delete} traceCommand
+ rename foo bar
+ lappend infotemp $info
+ rename bar {}
+ lappend infotemp $info
+ set info $infotemp
+ unset infotemp
+ set info
+} {{foo bar rename} {::bar {} delete}}
+
+test trace-20.6 {trace add command rename and delete in subinterp} {
+ set tc [interp create]
+ foreach p {traceCommand} {
+ $tc eval [list proc $p [info args $p] [info body $p]]
+ }
+ $tc eval [list set infotemp {}]
+ $tc eval [list set info {}]
+ $tc eval [list proc foo {} {}]
+ $tc eval [list trace add command foo {rename delete} traceCommand]
+ $tc eval [list rename foo bar]
+ $tc eval {lappend infotemp $info}
+ $tc eval [list rename bar {}]
+ $tc eval {lappend infotemp $info}
+ $tc eval {set info $infotemp}
+ $tc eval [list unset infotemp]
+ set info [$tc eval [list set info]]
+ interp delete $tc
+ set info
+} {{foo bar rename} {::bar {} delete}}
+
+# I'd like it if this test could give 'foo {} d' as a result,
+# but interp deletion means there is no interp to evaluate
+# the trace in.
+test trace-20.7 {trace add command delete in subinterp while being deleted} {
+ set info {}
+ set tc [interp create]
+ interp alias $tc traceCommand {} traceCommand
+ $tc eval [list proc foo {} {}]
+ $tc eval [list trace add command foo {rename delete} traceCommand]
+ interp delete $tc
+ set info
+} {}
+
+proc traceDelete {cmd old new op} {
+ eval trace remove command $cmd [lindex [trace info command $cmd] 0]
+ global info
+ set info [list $old $new $op]
+}
+proc traceCmdrename {cmd old new op} {
+ rename $old someothername
+}
+proc traceCmddelete {cmd old new op} {
+ rename $old ""
+}
+test trace-20.8 {trace delete while trace is active} {
+ set info {}
+ proc foo {} {}
+ catch {rename bar {}}
+ trace add command foo {rename delete} [list traceDelete foo]
+ rename foo bar
+ list [set info] [trace info command bar]
+} {{foo bar rename} {}}
+
+test trace-20.9 {rename trace deletes command} {
+ set info {}
+ proc foo {} {}
+ catch {rename bar {}}
+ catch {rename someothername {}}
+ trace add command foo rename [list traceCmddelete foo]
+ rename foo bar
+ list [info commands foo] [info commands bar] [info commands someothername]
+} {{} {} {}}
+
+test trace-20.10 {rename trace renames command} {
+ set info {}
+ proc foo {} {}
+ catch {rename bar {}}
+ catch {rename someothername {}}
+ trace add command foo rename [list traceCmdrename foo]
+ rename foo bar
+ set info [list [info commands foo] [info commands bar] [info commands someothername]]
+ rename someothername {}
+ set info
+} {{} {} someothername}
+
+test trace-20.11 {delete trace deletes command} {
+ set info {}
+ proc foo {} {}
+ catch {rename bar {}}
+ catch {rename someothername {}}
+ trace add command foo delete [list traceCmddelete foo]
+ rename foo {}
+ list [info commands foo] [info commands bar] [info commands someothername]
+} {{} {} {}}
+
+test trace-20.12 {delete trace renames command} {
+ set info {}
+ proc foo {} {}
+ catch {rename bar {}}
+ catch {rename someothername {}}
+ trace add command foo delete [list traceCmdrename foo]
+ rename foo bar
+ rename bar {}
+ # None of these should exist.
+ list [info commands foo] [info commands bar] [info commands someothername]
+} {{} {} {}}
+
+proc foo {b} { set a $b }
+
+
+# Delete arrays when done, so they can be re-used as scalars
+# elsewhere.
+
+catch {unset x}
+catch {unset y}
+
+# Delete procedures when done, so we don't clash with other tests
+# (e.g. foobar will clash with 'unknown' tests).
+catch {rename foobar {}}
+catch {rename foo {}}
+catch {rename bar {}}
+
+proc foo {a} {
+ set b $a
+}
+
+proc traceExecute {args} {
+ global info
+ lappend info $args
+}
+
+test trace-21.1 {trace execution: enter} {
+ set info {}
+ trace add execution foo enter [list traceExecute foo]
+ foo 1
+ trace remove execution foo enter [list traceExecute foo]
+ set info
+} {{foo {foo 1} enter}}
+
+test trace-21.2 {trace exeuction: leave} {
+ set info {}
+ trace add execution foo leave [list traceExecute foo]
+ foo 2
+ trace remove execution foo leave [list traceExecute foo]
+ set info
+} {{foo {foo 2} 0 2 leave}}
+
+test trace-21.3 {trace exeuction: enter, leave} {
+ set info {}
+ trace add execution foo {enter leave} [list traceExecute foo]
+ foo 3
+ trace remove execution foo {enter leave} [list traceExecute foo]
+ set info
+} {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}}
+
+test trace-21.4 {trace execution: enter, leave, enterstep} {
+ set info {}
+ trace add execution foo {enter leave enterstep} [list traceExecute foo]
+ foo 3
+ trace remove execution foo {enter leave enterstep} [list traceExecute foo]
+ set info
+} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}}
+
+test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} {
+ set info {}
+ trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo]
+ foo 3
+ trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo]
+ set info
+} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}}
+
+test trace-21.6 {trace execution: enterstep, leavestep} {
+ set info {}
+ trace add execution foo {enterstep leavestep} [list traceExecute foo]
+ foo 3
+ trace remove execution foo {enterstep leavestep} [list traceExecute foo]
+ set info
+} {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}}
+
+test trace-21.7 {trace execution: enterstep} {
+ set info {}
+ trace add execution foo {enterstep} [list traceExecute foo]
+ foo 3
+ trace remove execution foo {enterstep} [list traceExecute foo]
+ set info
+} {{foo {set b 3} enterstep}}
+
+test trace-21.8 {trace execution: leavestep} {
+ set info {}
+ trace add execution foo {leavestep} [list traceExecute foo]
+ foo 3
+ trace remove execution foo {leavestep} [list traceExecute foo]
+ set info
+} {{foo {set b 3} 0 3 leavestep}}
+
+proc factorial {n} {
+ if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
+ return 1
+}
+
+test trace-22.1 {recursive(1) trace execution: enter} {
+ set info {}
+ trace add execution factorial {enter} [list traceExecute factorial]
+ factorial 1
+ trace remove execution factorial {enter} [list traceExecute factorial]
+ set info
+} {{factorial {factorial 1} enter}}
+
+test trace-22.2 {recursive(2) trace execution: enter} {
+ set info {}
+ trace add execution factorial {enter} [list traceExecute factorial]
+ factorial 2
+ trace remove execution factorial {enter} [list traceExecute factorial]
+ set info
+} {{factorial {factorial 2} enter} {factorial {factorial 1} enter}}
+
+test trace-22.3 {recursive(3) trace execution: enter} {
+ set info {}
+ trace add execution factorial {enter} [list traceExecute factorial]
+ factorial 3
+ trace remove execution factorial {enter} [list traceExecute factorial]
+ set info
+} {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}}
+
+test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} {
+ set info {}
+ trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
+ factorial 1
+ trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
+ join $info "\n"
+} {{factorial 1} enter
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
+{return 1} enterstep
+{return 1} 2 1 leavestep
+{factorial 1} 0 1 leave}
+
+test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} {
+ set info {}
+ trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
+ factorial 2
+ trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
+ join $info "\n"
+} {{factorial 2} enter
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
+{expr {$n -1 }} enterstep
+{expr {$n -1 }} 0 1 leavestep
+{factorial 1} enterstep
+{factorial 1} enter
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
+{return 1} enterstep
+{return 1} 2 1 leavestep
+{factorial 1} 0 1 leave
+{factorial 1} 0 1 leavestep
+{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
+{return 2} enterstep
+{return 2} 2 2 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
+{factorial 2} 0 2 leave}
+
+test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} {
+ set info {}
+ trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
+ factorial 3
+ trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
+ join $info "\n"
+} {{factorial 3} enter
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
+{expr {$n -1 }} enterstep
+{expr {$n -1 }} 0 2 leavestep
+{factorial 2} enterstep
+{factorial 2} enter
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
+{expr {$n -1 }} enterstep
+{expr {$n -1 }} 0 1 leavestep
+{factorial 1} enterstep
+{factorial 1} enter
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
+{return 1} enterstep
+{return 1} 2 1 leavestep
+{factorial 1} 0 1 leave
+{factorial 1} 0 1 leavestep
+{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
+{return 2} enterstep
+{return 2} 2 2 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
+{factorial 2} 0 2 leave
+{factorial 2} 0 2 leavestep
+{expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep
+{return 6} enterstep
+{return 6} 2 6 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep
+{factorial 3} 0 6 leave}
+
+proc traceDelete {cmd args} {
+ eval trace remove execution $cmd [lindex [trace info execution $cmd] 0]
+ global info
+ set info $args
+}
+
+test trace-24.1 {delete trace during enter trace} {
+ set info {}
+ trace add execution foo enter [list traceDelete foo]
+ foo 1
+ list $info [trace info execution foo]
+} {{{foo 1} enter} {}}
+
+test trace-24.2 {delete trace during leave trace} {
+ set info {}
+ trace add execution foo leave [list traceDelete foo]
+ foo 1
+ list $info [trace info execution foo]
+} {{{foo 1} 0 1 leave} {}}
+
+test trace-24.3 {delete trace during enter-leave trace} {
+ set info {}
+ trace add execution foo {enter leave} [list traceDelete foo]
+ foo 1
+ list $info [trace info execution foo]
+} {{{foo 1} enter} {}}
+
+test trace-24.4 {delete trace during all exec traces} {
+ set info {}
+ trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo]
+ foo 1
+ list $info [trace info execution foo]
+} {{{foo 1} enter} {}}
+
+test trace-24.5 {delete trace during all exec traces except enter} {
+ set info {}
+ trace add execution foo {leave enterstep leavestep} [list traceDelete foo]
+ foo 1
+ list $info [trace info execution foo]
+} {{{set b 1} enterstep} {}}
+
+proc traceDelete {cmd args} {
+ rename $cmd {}
+ global info
+ set info $args
+}
+
+proc foo {a} {
+ set b $a
+}
+test trace-25.1 {delete command during enter trace} {
+ set info {}
+ trace add execution foo enter [list traceDelete foo]
+ catch {foo 1} err
+ list $err $info [trace info execution foo]
+} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
+
+proc foo {a} {
+ set b $a
+}
+
+test trace-25.2 {delete command during leave trace} {
+ set info {}
+ trace add execution foo leave [list traceDelete foo]
+ foo 1
+ list $info [trace info execution foo]
+} {{{foo 1} 0 1 leave} {unknown command "foo"}}
+
+proc foo {a} {
+ set b $a
+}
+
+test trace-25.3 {delete command during enter then leave trace} {
+ set info {}
+ trace add execution foo enter [list traceDelete foo]
+ trace add execution foo leave [list traceDelete foo]
+ catch {foo 1} err
+ list $err $info [trace info execution foo]
+} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
+
+proc foo {a} {
+ set b $a
+}
+proc traceExecute2 {args} {
+ global info
+ lappend info $args
+}
+
+# This shows the peculiar consequences of having two traces
+# at the same time: as well as tracing the procedure you want
+test trace-25.4 {order dependencies of two enter traces} {
+ set info {}
+ trace add execution foo enter [list traceExecute traceExecute]
+ trace add execution foo enter [list traceExecute2 traceExecute2]
+ catch {foo 1} err
+ trace remove execution foo enter [list traceExecute traceExecute]
+ trace remove execution foo enter [list traceExecute2 traceExecute2]
+ join [list $err [join $info \n] [trace info execution foo]] "\n"
+} {1
+traceExecute2 {foo 1} enter
+traceExecute {foo 1} enter
+}
+
+test trace-25.5 {order dependencies of two step traces} {
+ set info {}
+ trace add execution foo enterstep [list traceExecute traceExecute]
+ trace add execution foo enterstep [list traceExecute2 traceExecute2]
+ catch {foo 1} err
+ trace remove execution foo enterstep [list traceExecute traceExecute]
+ trace remove execution foo enterstep [list traceExecute2 traceExecute2]
+ join [list $err [join $info \n] [trace info execution foo]] "\n"
+} {1
+traceExecute2 {set b 1} enterstep
+traceExecute {set b 1} enterstep
+}
+
+# We don't want the result string (5th argument), or the results
+# will get unmanageable.
+proc tracePostExecute {args} {
+ global info
+ lappend info [concat [lrange $args 0 2] [lindex $args 4]]
+}
+proc tracePostExecute2 {args} {
+ global info
+ lappend info [concat [lrange $args 0 2] [lindex $args 4]]
+}
+
+test trace-25.6 {order dependencies of two leave traces} {
+ set info {}
+ trace add execution foo leave [list tracePostExecute tracePostExecute]
+ trace add execution foo leave [list tracePostExecute2 tracePostExecute2]
+ catch {foo 1} err
+ trace remove execution foo leave [list tracePostExecute tracePostExecute]
+ trace remove execution foo leave [list tracePostExecute2 tracePostExecute2]
+ join [list $err [join $info \n] [trace info execution foo]] "\n"
+} {1
+tracePostExecute {foo 1} 0 leave
+tracePostExecute2 {foo 1} 0 leave
+}
+
+test trace-25.7 {order dependencies of two leavestep traces} {
+ set info {}
+ trace add execution foo leavestep [list tracePostExecute tracePostExecute]
+ trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2]
+ catch {foo 1} err
+ trace remove execution foo leavestep [list tracePostExecute tracePostExecute]
+ trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2]
+ join [list $err [join $info \n] [trace info execution foo]] "\n"
+} {1
+tracePostExecute {set b 1} 0 leavestep
+tracePostExecute2 {set b 1} 0 leavestep
+}
+proc foo {a} {
+ set b $a
+}
+
+proc traceDelete {cmd args} {
+ rename $cmd {}
+ global info
+ set info $args
+}
+
+test trace-25.8 {delete command during enter leave and enter/leave-step traces} {
+ set info {}
+ trace add execution foo enter [list traceDelete foo]
+ trace add execution foo leave [list traceDelete foo]
+ trace add execution foo enterstep [list traceDelete foo]
+ trace add execution foo leavestep [list traceDelete foo]
+ catch {foo 1} err
+ list $err $info [trace info execution foo]
+} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
+
+proc foo {a} {
+ set b $a
+}
+test trace-25.9 {delete command during enter leave and leavestep traces} {
+ set info {}
+ trace add execution foo enter [list traceDelete foo]
+ trace add execution foo leave [list traceDelete foo]
+ trace add execution foo leavestep [list traceDelete foo]
+ catch {foo 1} err
+ list $err $info [trace info execution foo]
+} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
+
+proc foo {a} {
+ set b $a
+}
+
+test trace-25.10 {delete command during leave and leavestep traces} {
+ set info {}
+ trace add execution foo leave [list traceDelete foo]
+ trace add execution foo leavestep [list traceDelete foo]
+ catch {foo 1} err
+ list $err $info [trace info execution foo]
+} {1 {{set b 1} 0 1 leavestep} {unknown command "foo"}}
+
+proc foo {a} {
+ set b $a
+}
+test trace-25.11 {delete command during enter and enterstep traces} {
+ set info {}
+ trace add execution foo enter [list traceDelete foo]
+ trace add execution foo enterstep [list traceDelete foo]
+ catch {foo 1} err
+ list $err $info [trace info execution foo]
+} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
+test trace-26.1 {trace targetCmd when invoked through an alias} {
+ proc foo {args} {
+ set b $args
+ }
+ set info {}
+ trace add execution foo enter [list traceExecute foo]
+ interp alias {} bar {} foo 1
+ bar 2
+ trace remove execution foo enter [list traceExecute foo]
+ set info
+} {{foo {foo 1 2} enter}}
+test trace-26.2 {trace targetCmd when invoked through an alias} {
+ proc foo {args} {
+ set b $args
+ }
+ set info {}
+ trace add execution foo enter [list traceExecute foo]
+ interp create child
+ interp alias child bar {} foo 1
+ child eval bar 2
+ interp delete child
+ trace remove execution foo enter [list traceExecute foo]
+ set info
+} {{foo {foo 1 2} enter}}
+test trace-27.1 {memory leak in rename trace (604609)} {
+ catch {rename bar {}}
+ proc foo {} {error foo}
+ trace add command foo rename {rename foo "" ;#}
+ rename foo bar
+ info commands foo
+} {}
+test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} {
+ catch {rename foo {}}
+ proc foo {} {
+ set a 1
+ update idletasks
+ set b 1
+ }
+ set info {}
+ trace add execution foo {enter enterstep leavestep leave} \
+ [list traceExecute foo]
+ update
+ after idle {puts idle}
+ foo
+ trace remove execution foo {enter enterstep leavestep leave} \
+ [list traceExecute foo]
+ rename foo {}
+ join $info "\n"
+} {foo foo enter
+foo {set a 1} enterstep
+foo {set a 1} 0 1 leavestep
+foo {update idletasks} enterstep
+foo {puts idle} enterstep
+foo {puts idle} 0 {} leavestep
+foo {update idletasks} 0 {} leavestep
+foo {set b 1} enterstep
+foo {set b 1} 0 1 leavestep
+foo foo 0 1 leave}
+# Delete procedures when done, so we don't clash with other tests
+# (e.g. foobar will clash with 'unknown' tests).
+catch {rename foobar {}}
+catch {rename foo {}}
+catch {rename bar {}}
+# Unset the varaible when done
+catch {unset info}
+# cleanup
+::tcltest::cleanupTests
+return
namespace import -force ::tcltest::*
}
+# These tests really need to be run from a writable directory, which
+# it is assumed [temporaryDirectory] is.
+set oldcwd [pwd]
+cd [temporaryDirectory]
+
# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
testchmod 777 $path
if {[file isdirectory $path]} {
catch {
- foreach p [glob [file join $path *]] {
+ foreach p [glob -directory $path *] {
openup $p
}
}
foreach p ". $args" {
set x ""
catch {
- set x [glob [file join $p tf*] [file join $p td*]]
+ set x [glob -directory $p tf* td*]
}
foreach file $x {
if {[catch {file delete -force -- $file}]} {
test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
cleanup
file mkdir td1/td2/td3
- exec chmod 000 td1/td2
+ file attributes td1/td2 -permissions 0000
set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
- exec chmod 755 td1/td2
+ file attributes td1/td2 -permissions 0755
set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} {
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
{unixOnly notRoot} {
cleanup
- exec touch tf1
- exec touch tf2
+ close [open tf1 a]
+ close [open tf2 a]
file copy -force tf1 tf2
} {}
-test unixFCmd-2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {
+test unixFCmd-2.2.1 {TclpCopyFile: src is symlink} {unixOnly notRoot dontCopyLinks} {
+ # copying links should end up with real files
cleanup
- exec ln -s tf1 tf2
+ close [open tf1 a]
+ file link -symbolic tf2 tf1
+ file copy tf2 tf3
+ file type tf3
+} {file}
+test unixFCmd-2.2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {
+ # copying links should end up with the links copied
+ cleanup
+ close [open tf1 a]
+ file link -symbolic tf2 tf1
file copy tf2 tf3
file type tf3
} {link}
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
cleanup
- exec touch tf1
- exec chmod 472 tf1
+ close [open tf1 a]
+ file attributes tf1 -permissions 0472
file copy tf1 tf2
- string range [exec ls -l tf2] 0 9
-} {-r--rwx-w-}
+ file attributes tf2 -permissions
+} 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
} {}
close [open foo.test w]
set ::i 4
-proc permcheck {permstr expected} {
- test unixFCmd-17.[incr ::i] {SetPermissionsAttribute} {unixOnly notRoot} \
- [subst {
+proc permcheck {testnum permstr expected} {
+ test $testnum {SetPermissionsAttribute} {unixOnly notRoot} {
file attributes foo.test -permissions $permstr
file attributes foo.test -permissions
- }
- ] $expected
+ } $expected
}
-permcheck rwxrwxrwx 00777
-permcheck r--r---w- 00442
-permcheck 0 00000
-permcheck u+rwx,g+r 00740
-permcheck u-w 00540
-permcheck o+rwx 00547
-permcheck --x--x--x 00111
-permcheck a+rwx 00777
+permcheck unixFCmd-17.4 rwxrwxrwx 00777
+permcheck unixFCmd-17.5 r--r---w- 00442
+permcheck unixFCmd-17.6 0 00000
+permcheck unixFCmd-17.7 u+rwx,g+r 00740
+permcheck unixFCmd-17.8 u-w 00540
+permcheck unixFCmd-17.9 o+rwx 00547
+permcheck unixFCmd-17.10 --x--x--x 00111
+permcheck unixFCmd-17.11 a+rwx 00777
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
set nd $cd/tstdir
file mkdir $nd
cd $nd
- exec chmod 000 $nd
+ file attributes $nd -permissions 0000
set r [list [catch {pwd} res] [string range $res 0 36]];
cd $cd;
- exec chmod 755 $nd
+ file attributes $nd -permissions 0755
file delete $nd
set r
} {1 {error getting working directory name:}}
# cleanup
cleanup
+cd $oldcwd
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
return
}
+set oldpwd [pwd]
+cd [temporaryDirectory]
+
catch {
set oldPath $env(PATH)
- close [open junk w]
- file attributes junk -perm 0777
+ file attributes [makeFile "" junk] -perm 0777
}
-set absPath [file join [pwd] junk]
+set absPath [file join [temporaryDirectory] junk]
test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} {
set env(PATH) ""
# cleanup
catch {set env(PATH) $oldPath}
-file delete junk
+removeFile junk
+cd $oldpwd
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
if {[info exists env(TCL_LIBRARY)]} {
set oldlibrary $env(TCL_LIBRARY)
catch {set oldlang $env(LANG)}
set env(LANG) C
-# Some tests will fail if they are run on a machine that doesn't have
-# this Tcl version installed (as opposed to built) on it.
-if {[catch {
- set f [open "|[list $::tcltest::tcltest exit]" w+]
- exec kill -PIPE [pid $f]
- close $f
-}]} {
- set ::tcltest::testConstraints(installedTcl) 0
-} else {
- set ::tcltest::testConstraints(installedTcl) 1
-}
-
-test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} {
+test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly stdio} {
set x {}
# Watch out for a race condition here. If tcltest is too slow to start
# then we'll kill it before it has a chance to set up its signal handler.
- set f [open "|[list $::tcltest::tcltest]" w+]
+ set f [open "|[list [interpreter]]" w+]
puts $f "puts hi"
flush $f
gets $f
exec kill -PIPE [pid $f]
lappend x [catch {close $f}]
- set f [open "|[list $::tcltest::tcltest]" w+]
+ set f [open "|[list [interpreter]]" w+]
puts $f "puts hi"
flush $f
gets $f
set x
} {0 1}
-proc getlibpath "{program [list $::tcltest::tcltest]}" {
- set f [open "|$program" w+]
+# This test is really a test of code in tclUnixChan.c, but the
+# channels are set up as part of initialisation of the interpreter so
+# the test seems to me to fit here as well as anywhere else.
+test unixInit-1.2 {initialisation: standard channel type deduction} {unixOnly stdio} {
+ # pipe1 is a connection to a server that reports what port it
+ # starts on, and delivers a constant string to the first client to
+ # connect to that port before exiting.
+ set pipe1 [open "|[list [interpreter]]" r+]
+ puts $pipe1 {
+ proc accept {channel host port} {
+ puts $channel {puts [fconfigure stdin -peername]; exit}
+ close $channel
+ exit
+ }
+ puts [fconfigure [socket -server accept 0] -sockname]
+ vwait forever \
+ }
+ # Note the backslash above; this is important to make sure that the
+ # whole string is read before an [exit] can happen...
+ flush $pipe1
+ set port [lindex [gets $pipe1] 2]
+ set sock [socket localhost $port]
+ # pipe2 is a connection to a Tcl interpreter that takes its orders
+ # from the socket we hand it (i.e. the server we create above.)
+ # These orders will tell it to print out the details about the
+ # socket it is taking instructions from, hopefully identifying it
+ # as a socket. Which is what this test is all about.
+ set pipe2 [open "|[list [interpreter] <@$sock]" r]
+ set result [gets $pipe2]
+
+ # Clear any pending data; stops certain kinds of (non-important) errors
+ fconfigure $pipe1 -blocking 0; gets $pipe1
+ fconfigure $pipe2 -blocking 0; gets $pipe2
+
+ # Close the pipes and the socket.
+ close $pipe2
+ close $pipe1
+ catch {close $sock}
+
+ # Can't use normal comparison, as hostname varies due to some
+ # installations having a messed up /etc/hosts file.
+ if {
+ [string equal 127.0.0.1 [lindex $result 0]] &&
+ [string equal $port [lindex $result 2]]
+ } then {
+ subst "OK"
+ } else {
+ subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
+ }
+} {OK}
+
+proc getlibpath [list [list program [interpreter]]] {
+ set f [open "|[list $program]" w+]
fconfigure $f -buffering none
puts $f {puts $tcl_libPath; exit}
set path [gets $f]
# Some tests require the testgetdefenc command
-set ::tcltest::testConstraints(testgetdefenc) \
- [expr {[info commands testgetdefenc] != {}}]
+testConstraint testgetdefenc [llength [info commands testgetdefenc]]
test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
{unixOnly testgetdefenc} {
set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
- {unixOnly installedTcl} {
+ {unixOnly stdio} {
set path [getlibpath]
set installLib lib/tcl[info tclversion]
- if {[string match {*[ab]*} [info patchlevel]]} {
- set developLib tcl[info patchlevel]/library
- } else {
- set developLib tcl[info tclversion]/library
- }
- set prefix [file dirname [file dirname $::tcltest::tcltest]]
+ set developLib tcl[info patchlevel]/library
+ set prefix [file dirname [file dirname [interpreter]]]
set x {}
lappend x [string compare [lindex $path 0] $prefix/$installLib]
lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
set x
} {0 0}
-test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly installedTcl} {
+test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly stdio} {
# ((str != NULL) && (str[0] != '\0'))
set env(TCL_LIBRARY) sparkly
lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
- {unixOnly installedTcl} {
+ {unixOnly stdio} {
# ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))
set env(TCL_LIBRARY) /a/b/tcl1.7
lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
- {unixOnly installedTcl} {
+ {unixOnly stdio} {
# Child process translates env variable from native encoding.
set env(TCL_LIBRARY) "\xa7"
# cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
- {unixOnly installedTcl} {
- file delete -force /tmp/sparkly
- file mkdir /tmp/sparkly/bin
- file copy $::tcltest::tcltest /tmp/sparkly/bin/tcltest
+ {unixOnly stdio} {
+ makeDirectory tmp
+ makeDirectory [file join tmp sparkly]
+ makeDirectory [file join tmp sparkly bin]
+ file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \
+ bin tcltest]
+ makeDirectory [file join tmp sparkly lib]
+ makeDirectory [file join tmp sparkly lib tcl[info tclversion]]
+ makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl]
- file mkdir /tmp/sparkly/lib/tcl[info tclversion]
- close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w]
-
- set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 1]
- file delete -force /tmp/sparkly
+ set x [lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \
+ bin tcltest]] 0 1]
+ removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl]
+ removeDirectory [file join tmp sparkly lib tcl[info tclversion]]
+ removeDirectory [file join tmp sparkly lib]
+ removeDirectory [file join tmp sparkly bin]
+ removeDirectory [file join tmp sparkly]
+ removeDirectory tmp
set x
-} [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/lib/tcl[info tclversion]]
+} [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
{emptyTest unixOnly} {
# would need test command to get defaultLibDir and compare it to
# [lindex $auto_path end]
} {}
-test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly installedTcl} {
+#
+# The following two tests write to the directory /tmp/sparkly instead
+# of to [temporaryDirectory]. This is because the failures tested by
+# these tests need paths near the "root" of the file system to present
+# themselves.
+#
+testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}]
+testConstraint noTmpInstall [expr {![file exists \
+ [file join /tmp lib tcl[info tclversion]]]}]
+test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly noTmpInstall} {
+ # Checking for Bug 219416
+ # When a program that embeds the Tcl library, like tcltest, is
+ # installed near the "root" of the file system, there was a problem
+ # constructing directories relative to the executable. When a
+ # relative ".." went past the root, relative path names were created
+ # rather than absolute pathnames. In some cases, accessing past the
+ # root caused memory access violations too.
+ #
+ # The bug is now fixed, but here we check for it by making sure that
+ # the directories constructed relative to the executable are all
+ # absolute pathnames, even when the executable is installed near
+ # the root of the filesystem.
+ #
+ # The only directory near the root we are likely to have write access
+ # to is /tmp.
+ file delete -force /tmp/sparkly
+ file delete -force /tmp/lib/tcl[info tclversion]
+ file mkdir /tmp/sparkly
+ file copy [interpreter] /tmp/sparkly/tcltest
+
+ # Keep any existing /tmp/lib directory
+ set deletelib 1
+ if {[file exists /tmp/lib]} {
+ if {[file isdirectory /tmp/lib]} {
+ set deletelib 0
+ } else {
+ file delete -force /tmp/lib
+ }
+ }
+
+ # For a successful Tcl_Init, we need a [source]-able init.tcl in
+ # ../lib/tcl$version relative to the executable.
+ file mkdir /tmp/lib/tcl[info tclversion]
+ close [open /tmp/lib/tcl[info tclversion]/init.tcl w]
+
+ # Check that all directories in the library path are absolute pathnames
+ set allAbsolute 1
+ foreach dir [getlibpath /tmp/sparkly/tcltest] {
+ set allAbsolute [expr {$allAbsolute \
+ && [string equal absolute [file pathtype $dir]]}]
+ }
+
+ # Clean up temporary installation
+ file delete -force /tmp/sparkly
+ file delete -force /tmp/lib/tcl[info tclversion]
+ if {$deletelib} {file delete -force /tmp/lib}
+ set allAbsolute
+} 1
+testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}]
+test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSparkly noTmpBuild} {
+ # Checking for Bug 438014
+ file delete -force /tmp/sparkly
+ file delete -force /tmp/library
+ file mkdir /tmp/sparkly
+ file copy [interpreter] /tmp/sparkly/tcltest
+
+ file mkdir /tmp/library/
+ close [open /tmp/library/init.tcl w]
+
+ set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]
+
+ file delete -force /tmp/sparkly
+ file delete -force /tmp/library
+ set x
+} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
+ /tmp/library /library /tcl[info patchlevel]/library]
+test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
+ unixOnly stdio
+} -body {
set env(LANG) C
- set f [open "|[list $::tcltest::tcltest]" w+]
+ set f [open "|[list [interpreter]]" w+]
fconfigure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
unset env(LANG)
set enc
-} {iso8859-1}
-test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly installedTcl} {
+} -match regexp -result ^iso8859-15?$
+test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly stdio} {
set env(LANG) japanese
catch {set oldlc_all $env(LC_ALL)}
set env(LC_ALL) japanese
- set f [open "|[list $::tcltest::tcltest]" w+]
+ set f [open "|[list [interpreter]]" w+]
fconfigure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
unset env(LC_ALL)
catch {set env(LC_ALL) $oldlc_all}
- switch $tcl_platform(os) {
- HP-UX {set expectedEncoding shiftjis}
- default {set expectedEncoding euc-jp}
+ set validEncodings [list euc-jp]
+ if {[string match HP-UX $tcl_platform(os)]} {
+ # Some older HP-UX systems need us to accept this as valid
+ # Bug 453883 reports that newer HP-UX systems report euc-jp
+ # like everybody else.
+ lappend validEncodings shiftjis
}
- string compare $enc $expectedEncoding
+ expr {[lsearch -exact $validEncodings $enc] < 0}
} 0
test unixInit-4.1 {TclpSetVariables} {unixOnly} {
test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unixOnly} {
} {}
-
+
# cleanup
if {[info exists oldlibrary]} {
set env(TCL_LIBRARY) $oldlibrary
}
-catch {unset env(LANG); set env(LANG) $oldlang}
+catch {unset env(LANG)}
+catch {set env(LANG) $oldlang}
::tcltest::cleanupTests
return
-
test unixNotfy-1.1 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
catch {vwait x}
- set f [open foo w]
+ set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
} {1 {can't wait for variable "x": would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
catch {vwait x}
- set f1 [open foo w]
- set f2 [open foo2 w]
+ set f1 [open [makeFile "" foo] w]
+ set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
test unixNotfy-2.1 {Tcl_DeleteFileHandler} {unixOnly testthread} {
update
- set f [open foo w]
+ set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
vwait x
set x
} {ok}
-test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly testthread} {
+test unixNotfy-2.2 {Tcl_DeleteFileHandler} {unixOnly testthread} {
update
- set f1 [open foo w]
- set f2 [open foo2 w]
+ set f1 [open [makeFile "" foo] w]
+ set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
} {ok}
-
# cleanup
-file delete foo
-file delete foo2
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3
+namespace eval ns1 {
+ proc set args {return ::ns1}
+}
+proc a2 {} {
+ uplevel {set x ::}
+}
+test uplevel-6.1 {uplevel and shadowed cmds} {
+ set res [namespace eval ns1 a2]
+ lappend res [namespace eval ns2 a2]
+ lappend res [namespace eval ns1 a2]
+ namespace eval ns1 {rename set {}}
+ lappend res [namespace eval ns1 a2]
+} {::ns1 :: ::ns1 ::}
+
+
# cleanup
::tcltest::cleanupTests
return
-
} {}
test utf-21.1 {TclUniCharIsAlnum} {
-} {}
+ # this returns 1 with Unicode 3 compliance
+ string is alnum \u1040\u021f
+} {1}
+test utf-21.2 {unicode alnum char in regc_locale.c} {
+ # this returns 1 with Unicode 3 compliance
+ list [regexp {^[[:alnum:]]+$} \u1040\u021f] [regexp {^\w+$} \u1040\u021f]
+} {1 1}
test utf-22.1 {TclUniCharIsWordChar} {
string wordend "xyz123_bar fg" 0
test utf-22.2 {TclUniCharIsWordChar} {
string wordend "x\u5080z123_bar\u203c fg" 0
} 10
-
+
test utf-23.1 {TclUniCharIsAlpha} {
-} {}
+ # this returns 1 with Unicode 3 compliance
+ string is alpha \u021f
+} {1}
+test utf-23.2 {unicode alpha char in regc_locale.c} {
+ # this returns 1 with Unicode 3 compliance
+ regexp {^[[:alpha:]]+$} \u021f
+} {1}
test utf-24.1 {TclUniCharIsDigit} {
-} {}
-
-test utf-24.2 {TclUniCharIsSpace} {
-} {}
+ # this returns 1 with Unicode 3 compliance
+ string is digit \u1040
+} {1}
+test utf-24.2 {unicode digit char in regc_locale.c} {
+ # this returns 1 with Unicode 3 compliance
+ list [regexp {^[[:digit:]]+$} \u1040] [regexp {^\d+$} \u1040]
+} {1 1}
+
+test utf-24.1 {TclUniCharIsSpace} {
+ # this returns 1 with Unicode 3 compliance
+ string is space \u1680
+} {1}
+test utf-24.2 {unicode space char in regc_locale.c} {
+ # this returns 1 with Unicode 3 compliance
+ list [regexp {^[[:space:]]+$} \u1680] [regexp {^\s+$} \u1680]
+} {1 1}
# cleanup
::tcltest::cleanupTests
-
test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} {
concat a { } c
} {a c}
-
+test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} {
+ # Check for Bug #227512. If this violates C isspace, then it returns \xc3.
+ concat \xe0
+} \xe0
+
+proc Wrapper_Tcl_StringMatch {pattern string} {
+ # Forces use of Tcl_StringMatch, not Tcl_UniCharCaseMatch
+ switch -glob -- $string $pattern {return 1} default {return 0}
+}
test util-5.1 {Tcl_StringMatch} {
- string match ab*c abc
+ Wrapper_Tcl_StringMatch ab*c abc
} 1
test util-5.2 {Tcl_StringMatch} {
- string match ab**c abc
+ Wrapper_Tcl_StringMatch ab**c abc
} 1
test util-5.3 {Tcl_StringMatch} {
- string match ab* abcdef
+ Wrapper_Tcl_StringMatch ab* abcdef
} 1
test util-5.4 {Tcl_StringMatch} {
- string match *c abc
+ Wrapper_Tcl_StringMatch *c abc
} 1
test util-5.5 {Tcl_StringMatch} {
- string match *3*6*9 0123456789
+ Wrapper_Tcl_StringMatch *3*6*9 0123456789
} 1
test util-5.6 {Tcl_StringMatch} {
- string match *3*6*9 01234567890
+ Wrapper_Tcl_StringMatch *3*6*9 01234567890
} 0
test util-5.7 {Tcl_StringMatch: UTF-8} {
- string match *u \u4e4fu
+ Wrapper_Tcl_StringMatch *u \u4e4fu
} 1
test util-5.8 {Tcl_StringMatch} {
- string match a?c abc
+ Wrapper_Tcl_StringMatch a?c abc
} 1
test util-5.9 {Tcl_StringMatch: UTF-8} {
# skip one character in string
- string match a?c a\u4e4fc
+ Wrapper_Tcl_StringMatch a?c a\u4e4fc
} 1
test util-5.10 {Tcl_StringMatch} {
- string match a??c abc
+ Wrapper_Tcl_StringMatch a??c abc
} 0
test util-5.11 {Tcl_StringMatch} {
- string match ?1??4???8? 0123456789
+ Wrapper_Tcl_StringMatch ?1??4???8? 0123456789
} 1
test util-5.12 {Tcl_StringMatch} {
- string match {[abc]bc} abc
+ Wrapper_Tcl_StringMatch {[abc]bc} abc
} 1
test util-5.13 {Tcl_StringMatch: UTF-8} {
# string += Tcl_UtfToUniChar(string, &ch);
- string match "\[\u4e4fxy\]bc" "\u4e4fbc"
+ Wrapper_Tcl_StringMatch "\[\u4e4fxy\]bc" "\u4e4fbc"
} 1
test util-5.14 {Tcl_StringMatch} {
# if ((*pattern == ']') || (*pattern == '\0'))
# badly formed pattern
- string match {[]} {[]}
+ Wrapper_Tcl_StringMatch {[]} {[]}
} 0
test util-5.15 {Tcl_StringMatch} {
# if ((*pattern == ']') || (*pattern == '\0'))
# badly formed pattern
- string match {[} {[}
+ Wrapper_Tcl_StringMatch {[} {[}
} 0
test util-5.16 {Tcl_StringMatch} {
- string match {a[abc]c} abc
+ Wrapper_Tcl_StringMatch {a[abc]c} abc
} 1
test util-5.17 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
- string match "a\[a\u4e4fc]c" "a\u4e4fc"
+ Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
test util-5.18 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
- string match {a[a\u4e4fc]c} [bytestring a\u008fc]
+ Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance.
- string match {a[a\u4e4fc]c} "acc"
+ Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc"
} 1
test util-5.20 {Tcl_StringMatch} {
- string match {a[xyz]c} abc
+ Wrapper_Tcl_StringMatch {a[xyz]c} abc
} 0
test util-5.21 {Tcl_StringMatch} {
- string match {12[2-7]45} 12345
+ Wrapper_Tcl_StringMatch {12[2-7]45} 12345
} 1
test util-5.22 {Tcl_StringMatch: UTF-8 range} {
- string match "\[\u4e00-\u4e4f]" "0"
+ Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "0"
} 0
test util-5.23 {Tcl_StringMatch: UTF-8 range} {
- string match "\[\u4e00-\u4e4f]" "\u4e33"
+ Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\u4e33"
} 1
test util-5.24 {Tcl_StringMatch: UTF-8 range} {
- string match "\[\u4e00-\u4e4f]" "\uff08"
+ Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\uff08"
} 0
test util-5.25 {Tcl_StringMatch} {
- string match {12[ab2-4cd]45} 12345
+ Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12345
} 1
test util-5.26 {Tcl_StringMatch} {
- string match {12[ab2-4cd]45} 12b45
+ Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12b45
} 1
test util-5.27 {Tcl_StringMatch} {
- string match {12[ab2-4cd]45} 12d45
+ Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12d45
} 1
test util-5.28 {Tcl_StringMatch} {
- string match {12[ab2-4cd]45} 12145
+ Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12145
} 0
test util-5.29 {Tcl_StringMatch} {
- string match {12[ab2-4cd]45} 12545
+ Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12545
} 0
test util-5.30 {Tcl_StringMatch: forwards range} {
- string match {[k-w]} "z"
+ Wrapper_Tcl_StringMatch {[k-w]} "z"
} 0
test util-5.31 {Tcl_StringMatch: forwards range} {
- string match {[k-w]} "w"
+ Wrapper_Tcl_StringMatch {[k-w]} "w"
} 1
test util-5.32 {Tcl_StringMatch: forwards range} {
- string match {[k-w]} "r"
+ Wrapper_Tcl_StringMatch {[k-w]} "r"
} 1
test util-5.33 {Tcl_StringMatch: forwards range} {
- string match {[k-w]} "k"
+ Wrapper_Tcl_StringMatch {[k-w]} "k"
} 1
test util-5.34 {Tcl_StringMatch: forwards range} {
- string match {[k-w]} "a"
+ Wrapper_Tcl_StringMatch {[k-w]} "a"
} 0
test util-5.35 {Tcl_StringMatch: reverse range} {
- string match {[w-k]} "z"
+ Wrapper_Tcl_StringMatch {[w-k]} "z"
} 0
test util-5.36 {Tcl_StringMatch: reverse range} {
- string match {[w-k]} "w"
+ Wrapper_Tcl_StringMatch {[w-k]} "w"
} 1
test util-5.37 {Tcl_StringMatch: reverse range} {
- string match {[w-k]} "r"
+ Wrapper_Tcl_StringMatch {[w-k]} "r"
} 1
test util-5.38 {Tcl_StringMatch: reverse range} {
- string match {[w-k]} "k"
+ Wrapper_Tcl_StringMatch {[w-k]} "k"
} 1
test util-5.39 {Tcl_StringMatch: reverse range} {
- string match {[w-k]} "a"
+ Wrapper_Tcl_StringMatch {[w-k]} "a"
} 0
test util-5.40 {Tcl_StringMatch: skip correct number of ']'} {
- string match {[A-]x} Ax
+ Wrapper_Tcl_StringMatch {[A-]x} Ax
} 0
test util-5.41 {Tcl_StringMatch: skip correct number of ']'} {
- string match {[A-]]x} Ax
+ Wrapper_Tcl_StringMatch {[A-]]x} Ax
} 1
test util-5.42 {Tcl_StringMatch: skip correct number of ']'} {
- string match {[A-]]x} \ue1x
+ Wrapper_Tcl_StringMatch {[A-]]x} \ue1x
} 0
test util-5.43 {Tcl_StringMatch: skip correct number of ']'} {
- string match \[A-]\ue1]x \ue1x
+ Wrapper_Tcl_StringMatch \[A-]\ue1]x \ue1x
} 1
test util-5.44 {Tcl_StringMatch: skip correct number of ']'} {
- string match {[A-]h]x} hx
+ Wrapper_Tcl_StringMatch {[A-]h]x} hx
} 1
test util-5.45 {Tcl_StringMatch} {
# if (*pattern == '\0')
# badly formed pattern, still treats as a set
- string match {[a} a
+ Wrapper_Tcl_StringMatch {[a} a
} 1
test util-5.46 {Tcl_StringMatch} {
- string match {a\*b} a*b
+ Wrapper_Tcl_StringMatch {a\*b} a*b
} 1
test util-5.47 {Tcl_StringMatch} {
- string match {a\*b} ab
+ Wrapper_Tcl_StringMatch {a\*b} ab
} 0
test util-5.48 {Tcl_StringMatch} {
- string match {a\*\?\[\]\\\x} "a*?\[\]\\x"
+ Wrapper_Tcl_StringMatch {a\*\?\[\]\\\x} "a*?\[\]\\x"
} 1
test util-5.49 {Tcl_StringMatch} {
- string match ** ""
+ Wrapper_Tcl_StringMatch ** ""
} 1
test util-5.50 {Tcl_StringMatch} {
- string match *. ""
+ Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
- string match "" ""
+ Wrapper_Tcl_StringMatch "" ""
} 1
test util-6.1 {Tcl_PrintDouble - using tcl_precision} {
set tcl_precision 12
+# This test always succeeded in the C locale anyway...
+test util-8.1 {TclNeedSpace - correct UTF8 handling} {
+ interp create \u5420
+ interp create [list \u5420 foo]
+ interp alias {} fooset [list \u5420 foo] set
+ set result [interp target {} fooset]
+ interp delete \u5420
+ set result
+} "\u5420 foo"
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
#
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2.2
namespace import -force ::tcltest::*
}
set result
}
} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
+test var-1.19 {TclLookupVar, right error message when parsing variable name} {
+ list [catch {[format set] thisvar(doesntexist)} msg] $msg
+} {1 {can't read "thisvar(doesntexist)": no such variable}}
test var-2.1 {Tcl_LappendObjCmd, create var if new} {
catch {unset x}
catch {unset aaaaa}
set aaaaa 789789
list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
-} {1 {bad variable name "test_ns_fred::lnk": unknown namespace}}
+} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}
if {[info commands testgetvarfullname] != {}} {
test var-4.1 {Tcl_GetVariableName, global variable} {
}
p
} {24}
+test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} {
+ # Test for Tcl Bug 480176
+ set :v broken
+ proc p {} {
+ global :v
+ set :v fixed
+ }
+ p
+ set :v
+} {fixed}
test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} {
catch {namespace delete test_ns_var}
} res
set res
} "can't define \"arrayvar(1)\": name refers to an element in an array"
+test var-7.16 {Tcl_VariableObjCmd, no args} {
+ list [catch {variable} msg] $msg
+} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
+test var-7.17 {Tcl_VariableObjCmd, no args} {
+ namespace eval test_ns_var {
+ list [catch {variable} msg] $msg
+ }
+} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {
catch {namespace delete test_ns_var}
set x "If you see this, it worked"
} "If you see this, it worked"
+test var-14.1 {array names syntax} -body {
+ array names foo bar baz snafu
+} -returnCodes 1 -match glob -result *
+
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
# cleanup
::tcltest::cleanupTests
return
-
set i 0
catch {while {$i<} break} msg
set errorInfo
-} {syntax error in expression "$i<"
+} {syntax error in expression "$i<": premature end of expression
("while" test expression)
while compiling
"while {$i<} break"}
set z while
catch {$z {$i<} {set x 1}} msg
set errorInfo
-} {syntax error in expression "$i<"
+} {syntax error in expression "$i<": premature end of expression
while executing
"$z {$i<} {set x 1}"}
test while-4.4 {while (not compiled): error in test expression} {
# Test for incorrect "double evaluation" semantics
-test while-7.1 {delayed substitution of body} {knownBug} {
+test while-7.1 {delayed substitution of body} {
set i 0
while {[incr i] < 10} "
set result $i
"
- set result
-} {0}
+ proc p {} {
+ set i 0
+ while {[incr i] < 10} "
+ set result $i
+ "
+ set result
+ }
+ append result [p]
+} {00}
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
::tcltest::cleanupTests
return
-
if {$tcl_platform(platform) == "windows"} {
if [catch {
- set lib [lindex [glob [file join [pwd] [file dirname \
- [info nameofexecutable]] tcldde*.dll]] 0]
+ set lib [lindex [glob -directory [file join [pwd] [file dirname \
+ [info nameofexecutable]]] tcldde*.dll] 0]
load $lib dde
}] {
- puts "Unable to find the dde package. Skipping registry tests."
+ puts "WARNING: Unable to find the dde package. Skipping dde tests."
::tcltest::cleanupTests
return
}
set scriptName script1.tcl
-
proc createChildProcess { ddeServerName } {
-
file delete -force $::scriptName
-
+
set f [open $::scriptName w+]
puts $f {
+ if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+ }
if [catch {
- set lib [lindex [glob [file join [pwd] [file dirname \
- [info nameofexecutable]] tcldde*.dll]] 0]
+ set lib [lindex [glob -directory \
+ [file join [pwd] [file dirname [info nameofexecutable]]] \
+ tcldde*.dll] 0]
load $lib dde
}] {
- puts "Unable to find the dde package. Skipping registry tests."
+ puts "Unable to find the dde package. Skipping dde tests."
::tcltest::cleanupTests
return
}
}
- puts $f "dde servername $ddeServerName"
+ puts $f [list dde servername $ddeServerName]
puts $f {
puts ready
vwait done
}
close $f
- set f [open "|$tcltest::tcltest $::scriptName" r]
+ set f [open |[list [interpreter] $::scriptName] r]
gets $f
return $f
}
dde eval self set a "foo"
} foo
-test winDde-4.1 {DDE execute remotely} {pcOnly} {
+test winDde-3.5 {DDE request locally} {pcOnly} {
+ set a ""
+ dde execute TclEval self {set a "foo"}
+ dde request -binary TclEval self a
+} "foo\x00"
+
+test winDde-4.1 {DDE execute remotely} {stdio pcOnly} {
set a ""
set child [createChildProcess child]
dde execute TclEval child {set a "foo"}
-
dde execute TclEval child {set done 1}
set a
} ""
-test winDde-4.2 {DDE execute remotely} {pcOnly} {
+test winDde-4.2 {DDE execute remotely} {stdio pcOnly} {
set a ""
set child [createChildProcess child]
dde execute -async TclEval child {set a "foo"}
-
dde execute TclEval child {set done 1}
set a
} ""
-test winDde-4.3 {DDE request locally} {pcOnly} {
+test winDde-4.3 {DDE request locally} {stdio pcOnly} {
set a ""
set child [createChildProcess child]
dde execute TclEval child {set a "foo"}
set a [dde request TclEval child a]
-
-
dde execute TclEval child {set done 1}
set a
} foo
-test winDde-4.4 {DDE eval locally} {pcOnly} {
+test winDde-4.4 {DDE eval locally} {stdio pcOnly} {
set a ""
set child [createChildProcess child]
set a [dde eval child set a "foo"]
-
dde execute TclEval child {set done 1}
set a
set result
} {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
-
#cleanup
file delete -force $::scriptName
::tcltest::cleanupTests
return
-
-
foreach p ". $args" {
set x ""
catch {
- set x [glob [file join $p tf*] [file join $p td*]]
+ set x [glob -directory $p tf* td*]
}
if {$x != ""} {
catch {eval file delete -force -- $x}
}
}
+if {[string equal $tcl_platform(platform) "windows"]} {
+ if {[string equal $tcl_platform(os) "Windows NT"] \
+ && [string equal [string index $tcl_platform(osVersion) 0] "5"]} {
+ tcltest::testConstraint win2000orXP 1
+ tcltest::testConstraint winOlderThan2000 0
+ } else {
+ tcltest::testConstraint win2000orXP 0
+ tcltest::testConstraint winOlderThan2000 1
+ }
+} else {
+ tcltest::testConstraint win2000orXP 0
+ tcltest::testConstraint winOlderThan2000 0
+}
+
set ::tcltest::testConstraints(cdrom) 0
set ::tcltest::testConstraints(exdev) 0
close $fd
set msg
} {1 EACCES}
-test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly} {
+test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly win2000orXP} {
+ cleanup
+ list [catch {testfile mv nul tf1} msg] $msg
+} {1 EINVAL}
+test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} {pcOnly winOlderThan2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
-test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {95} {
+test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {pcOnly 95} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
-test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {nt} {
+test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {pcOnly nt} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
cleanup
list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
-test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly} {
+test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly win2000orXP} {
+ cleanup
+ list [catch {testfile mv nul tf1} msg] $msg
+} {1 EINVAL}
+test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} {pcOnly winOlderThan2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
-test winFCmd-1.20 {TclpRenameFile: src is dir} {nt} {
+test winFCmd-1.20 {TclpRenameFile: src is dir} {pcOnly nt} {
# under 95, this would actually succeed and move the current dir out from
# under the current process!
cleanup
createfile tf1
createfile tf2
testfile mv tf1 tf2
- list [file exist tf1] [file exist tf2]
+ list [file exists tf1] [file exists tf2]
} {0 1}
test winFCmd-1.29 {TclpRenameFile: src is dir} {pcOnly} {
cleanup
file mkdir td1/td2
file mkdir td2
testfile mv td1 td2
- list [file exist td1] [file exist td2] [file exist td2/td2]
+ list [file exists td1] [file exists td2] [file exists td2/td2]
} {0 1 1}
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \
{pcOnly exdev} {
createfile tf1
list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
-test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {95} {
+test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {pcOnly 95} {
cleanup
createfile tf1
set fd [open tf2 w]
close $fd
set msg
} {1 EACCES}
-test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {nt} {
+test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {pcOnly win2000orXP} {
+ cleanup
+ list [catch {testfile cp nul tf1} msg] $msg
+} {1 EINVAL}
+test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} {pcOnly nt winOlderThan2000} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
-test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {95} {
+test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {pcOnly 95} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
testfile cp tf1 tf2
list [file writable tf2] [contents tf2]
} {1 tf1}
-test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {95} {
+test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {pcOnly 95} {
cleanup
createfile tf1
createfile tf2
cleanup
createfile tf1
testfile rm tf1
- file exist tf1
+ file exists tf1
} {0}
test winFCmd-3.8 {TclpDeleteFile: DeleteFile fails} {pcOnly} {
cleanup
set msg
} {1 EACCES}
-test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {nt cdrom} {
+test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {pcOnly nt cdrom} {
list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
-test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {95 cdrom} {
+test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {pcOnly 95 cdrom} {
list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 ENOSPC}
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {pcOnly} {
file mkdir td1
testchmod 000 td1
testfile rmdir td1
- file exist td1
+ file exists td1
} {0}
test winFCmd-6.2 {TclpRemoveDirectory: errno: EEXIST} {pcOnly} {
cleanup
file mkdir td1/td2
- list [catch {testfile rmdir td1} msg] $msg
+ list [catch {testfile rmdir td1} msg] [file tail $msg]
} {1 {td1 EEXIST}}
test winFCmd-6.3 {TclpRemoveDirectory: errno: EACCES} {pcOnly} {
# can't test this w/o removing everything on your hard disk first!
} {}
test winFCmd-6.4 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} {
cleanup
- list [catch {testfile rmdir td1} msg] $msg
+ list [catch {testfile rmdir td1} msg] [file tail $msg]
} {1 {td1 ENOENT}}
test winFCmd-6.5 {TclpRemoveDirectory: errno: ENOENT} {pcOnly} {
cleanup
test winFCmd-6.6 {TclpRemoveDirectory: errno: ENOTDIR} {pcOnly} {
cleanup
createfile tf1
- list [catch {testfile rmdir tf1} msg] $msg
+ list [catch {testfile rmdir tf1} msg] [file tail $msg]
} {1 {tf1 ENOTDIR}}
test winFCmd-6.7 {TclpRemoveDirectory: RemoveDirectory succeeds} {pcOnly} {
cleanup
test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} {pcOnly} {
cleanup
createfile tf1
- list [catch {testfile rmdir tf1} msg] $msg
+ list [catch {testfile rmdir tf1} msg] [file tail $msg]
} {1 {tf1 ENOTDIR}}
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly} {
cleanup
testfile rmdir td1
file exists td1
} {0}
-test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {95} {
+test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {pcOnly 95} {
cleanup
list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
-test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {nt} {
+test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {pcOnly nt} {
cleanup
list [catch {testfile rmdir /} msg] $msg
-} {1 {\ EACCES}}
-test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {95} {
+} {1 {/ EACCES}}
+test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {pcOnly 95} {
cleanup
createfile tf1
list [catch {testfile rmdir tf1} msg] $msg
testfile rmdir td1
file exists td1
} {0}
-test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {95} {
+test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {pcOnly 95} {
cleanup
file mkdir td1/td2
list [catch {testfile rmdir td1} msg] $msg
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {pcOnly} {
cleanup
file mkdir td1/td2
- list [catch {testfile rmdir td1} msg] $msg
+ list [catch {testfile rmdir td1} msg] [file tail $msg]
} {1 {td1 EEXIST}}
test winFCmd-6.16 {TclpRemoveDirectory: recursive, but errno != EEXIST} {pcOnly} {
cleanup
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
-test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {95 cdrom} {
- list [catch {testfile rmdir $cdrom/} msg] $msg
-} "1 {$cdrom\\ EEXIST}"
-test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {nt cdrom} {
- list [catch {testfile rmdir $cdrom/} msg] $msg
-} "1 {$cdrom\\ EACCES}"
+test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {pcOnly 95 cdrom} {
+ # cdrom can return either d:\ or D:/, but we only care about the errcode
+ list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
+} {1 EEXIST}
+test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {pcOnly nt cdrom} {
+ list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
+} {1 EACCES}
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
{pcOnly} {
# can't make it happen
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
-test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {95} {
+test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {pcOnly 95} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
-} {1 {\ EEXIST}}
-test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {nt} {
+} {1 {/ EEXIST}}
+test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {pcOnly nt} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
-} {1 {\ EACCES}}
+} {1 {/ EACCES}}
test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} {}
-test winFCmd-9.2 {TraversalDelete: DOTREE_F} {95} {
+test winFCmd-9.2 {TraversalDelete: DOTREE_F} {pcOnly 95} {
cleanup
file mkdir td1
set fd [open td1/tf1 w]
close [open td1 w]
list [catch {file attributes td1 -system} msg] $msg [cleanup]
} {0 0 {}}
-test winfcmd-11.5 {GetWinFileAttributes} {pcOnly} {
+test winFCmd-11.5 {GetWinFileAttributes} {pcOnly} {
# attr of relative paths that resolve to root was failing
# don't care about answer, just that test runs.
file attr .
cd $old
} {}
+test winFCmd-11.6 {GetWinFileAttributes} {pcOnly} {
+ file attr c:/ -hidden
+} {0}
test winFCmd-12.1 {ConvertFileNameFormat} {pcOnly} {
cleanup
cleanup
catch {file attributes $cdfile -archive 1}
} {1}
+test winFCmd-16.1 {Windows file normalization} {pcOnly} {
+ list [file normalize c:/] [file normalize C:/]
+} {C:/ C:/}
# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
test winFile-1.1 {TclpGetUserHome} {pcOnly} {
list [catch {glob ~nosuchuser} msg] $msg
} {1 {user "nosuchuser" doesn't exist}}
-test winFile-1.2 {TclpGetUserHome} {nt nonPortable} {
+test winFile-1.2 {TclpGetUserHome} {pcOnly nt nonPortable} {
# The administrator account should always exist.
catch {glob ~administrator}
} {0}
-test winFile-1.2 {TclpGetUserHome} {95} {
+test winFile-1.2 {TclpGetUserHome} {pcOnly 95} {
# Find some user in system.ini and then see if they have a home.
set f [open $::env(windir)/system.ini]
close $f
set x
} {0}
-test winFile-1.3 {TclpGetUserHome} {nt nonPortable} {
+test winFile-1.3 {TclpGetUserHome} {pcOnly nt nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
set result
} {globlower globlower}
+test winFile-3.1 {file system} {pcOnly} {
+ set res "volume types ok"
+ foreach vol [file volumes] {
+ # Have to catch in case there is a removable drive (CDROM, floppy)
+ # with nothing in it.
+ catch {
+ if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} {
+ set res "For $vol, we found [file system $vol]\
+ and [testvolumetype $vol] are different"
+ break
+ }
+ }
+ }
+ set res
+} {volume types ok}
+
# cleanup
::tcltest::cleanupTests
return
-
#
# RCS: @(#) $Id$
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import -force ::tcltest::*
+
+testConstraint exec [llength [info commands exec]]
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
-set cat16 [file join $bindir cat16.exe]
set cat32 [file join $bindir cat32.exe]
set ::tcltest::testConstraints(cat32) [file exists $cat32]
-set ::tcltest::testConstraints(cat16) [file exists $cat16]
if {[catch {puts console1 ""}]} {
set ::tcltest::testConstraints(AllocConsole) 1
append big $big
append big $big
-set f [open "little" w]
+set path(little) [makeFile {} little]
+set f [open $path(little) w]
puts -nonewline $f "little"
close $f
-set f [open "big" w]
+set path(big) [makeFile {} big]
+set f [open $path(big) w]
puts -nonewline $f $big
close $f
set r
}
-set f [open more w]
-puts $f {
+set path(more) [makeFile {
while {[eof stdin] == 0} {
puts -nonewline [read stdin]
}
-}
-close $f
+} more]
+
+set path(stdout) [makeFile {} stdout]
+set path(stderr) [makeFile {} stderr]
-test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly stdio cat32} {
- exec $cat32 < little > stdout 2> stderr
- list [contents stdout] [contents stderr]
+test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly exec cat32} {
+ exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
-test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly stdio cat32} {
- exec $cat32 < big > stdout 2> stderr
- list [contents stdout] [contents stderr]
+test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly exec cat32} {
+ exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
-test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {nt stdio cat32} {
- exec $::tcltest::tcltest more < little | $cat32 > stdout 2> stderr
- list [contents stdout] [contents stderr]
+test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {pcOnly nt exec cat32} {
+ exec [interpreter] more < little | $cat32 > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
-test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {nt stdio cat32} {
- exec $::tcltest::tcltest more < big | $cat32 > stdout 2> stderr
- list [contents stdout] [contents stderr]
+test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {pcOnly nt exec cat32} {
+ exec [interpreter] more < big | $cat32 > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
-test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {95 stdio cat32} {
- exec command /c type big |& $cat32 > stdout 2> stderr
- list [contents stdout] [contents stderr]
+test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {pcOnly 95 exec cat32} {
+ exec command /c type big |& $cat32 > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
- {pcOnly stdio cat32 AllocConsole} {
+ {pcOnly cat32 AllocConsole} {
# would block waiting for human input
} {}
-test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly stdio cat32} {
- exec $cat32 < nul > stdout 2> stderr
- list [contents stdout] [contents stderr]
+test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly exec cat32} {
+ exec $cat32 < nul > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
-test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly stdio cat32} {
+test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly cat32} {
# doesn't work
} {}
test winpipe-1.9 {32 bit comprehensive tests: from nowhere} \
- {pcOnly stdio cat32 .console} {
- exec $cat32 > stdout 2> stderr
- list [contents stdout] [contents stderr]
+ {pcOnly exec cat32 .console} {
+ exec $cat32 > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
test winpipe-1.10 {32 bit comprehensive tests: from file handle} \
- {pcOnly stdio cat32} {
- set f [open "little" r]
- exec $cat32 <@$f > stdout 2> stderr
+ {pcOnly exec cat32} {
+ set f [open $path(little) r]
+ exec $cat32 <@$f > $path(stdout) 2> $path(stderr)
close $f
- list [contents stdout] [contents stderr]
+ list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.11 {32 bit comprehensive tests: read from application} \
- {pcOnly stdio cat32} {
- set f [open "|$cat32 < little" r]
+ {pcOnly exec cat32} {
+ set f [open "|[list $cat32] < $path(little)" r]
gets $f line
catch {close $f} msg
list $line $msg
} {little stderr32}
test winpipe-1.12 {32 bit comprehensive tests: a little to file} \
- {pcOnly stdio cat32} {
- exec $cat32 < little > stdout 2> stderr
- list [contents stdout] [contents stderr]
+ {pcOnly exec cat32} {
+ exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.13 {32 bit comprehensive tests: a lot to file} \
- {pcOnly stdio cat32} {
- exec $cat32 < big > stdout 2> stderr
- list [contents stdout] [contents stderr]
+ {pcOnly exec cat32} {
+ exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} \
- {pcOnly stdio cat32} {
- exec $cat32 < little | $::tcltest::tcltest more > stdout 2> stderr
- list [contents stdout] [contents stderr]
+ {pcOnly exec stdio cat32} {
+ exec $cat32 < $path(little) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} \
- {pcOnly stdio cat32} {
- exec $cat32 < big | $::tcltest::tcltest more > stdout 2> stderr
- list [contents stdout] [contents stderr]
+ {pcOnly exec stdio cat32} {
+ exec $cat32 < $path(big) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
+ list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
-test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly stdio cat32} {
+test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly exec cat32} {
catch {exec $cat32 << "You should see this\n" >@stdout} msg
set msg
} stderr32
-test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly stdio cat32} {
+test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly exec cat32} {
# some apps hang when sending a large amount to NUL. $cat32 isn't one.
- catch {exec $cat32 < big > nul} msg
+ catch {exec $cat32 < $path(big) > nul} msg
set msg
} stderr32
test winpipe-1.18 {32 bit comprehensive tests: to nowhere} \
- {pcOnly stdio cat32 .console} {
- exec $cat32 < big >&@stdout
+ {pcOnly exec cat32 .console} {
+ exec $cat32 < $path(big) >&@stdout
} {}
-test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly stdio cat32} {
- set f1 [open "stdout" w]
- set f2 [open "stderr" w]
- exec $cat32 < little >@$f1 2>@$f2
+test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly exec cat32} {
+ set f1 [open $path(stdout) w]
+ set f2 [open $path(stderr) w]
+ exec $cat32 < $path(little) >@$f1 2>@$f2
close $f1
close $f2
- list [contents stdout] [contents stderr]
+ list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.20 {32 bit comprehensive tests: write to application} \
- {pcOnly stdio cat32} {
- set f [open "|$cat32 > stdout" w]
+ {pcOnly exec cat32} {
+ set f [open |[list $cat32 >$path(stdout)] w]
puts -nonewline $f "foo"
catch {close $f} msg
- list [contents stdout] $msg
+ list [contents $path(stdout)] $msg
} {foo stderr32}
test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
- {pcOnly stdio cat32} {
- set f [open "|$cat32" r+]
+ {pcOnly exec cat32} {
+ set f [open "|[list $cat32]" r+]
puts $f $big
puts $f \032
flush $f
catch {close $f}
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
-test winpipe-1.22 {Checking command.com for Win95/98 hanging} \
- {pcOnly stdio} {
+test winpipe-1.22 {Checking command.com for Win95/98 hanging} {pcOnly 95 exec} {
exec command.com /c dir /b
set result 1
} 1
-
-test winpipe-2.1 {16 bit comprehensive tests: from little file} {pcOnly stdio cat16} {
- exec $cat16 < little > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "little stderr16"
-test winpipe-2.2 {16 bit comprehensive tests: from big file} {pcOnly stdio cat16} {
- exec $cat16 < big > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "{$big} stderr16"
-test winpipe-2.3 {16 bit comprehensive tests: a little from pipe} {pcOnly stdio cat16} {
- exec $::tcltest::tcltest more < little | $cat16 > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} {little stderr16}
-test winpipe-2.4 {16 bit comprehensive tests: a lot from pipe} {nt stdio cat16} {
- exec $cat16 < big | $cat16 > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "{$big} stderr16stderr16"
-test winpipe-2.5 {16 bit comprehensive tests: a lot from pipe} {95 stdio cat16} {
- exec $::tcltest::tcltest more < big | $cat16 > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "{$big} stderr16"
-test winpipe-2.6 {16 bit comprehensive tests: from console} \
- {pcOnly stdio cat16 AllocConsole} {
- # would block waiting for human input
-} {}
-test winpipe-2.7 {16 bit comprehensive tests: from NUL} {nt stdio cat16} {
- exec $cat16 < nul > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "{} stderr16"
-test winpipe-2.8 {16 bit comprehensive tests: from socket} {pcOnly stdio cat16} {
- # doesn't work
-} {}
-test winpipe-2.9 {16 bit comprehensive tests: from nowhere} {pcOnly stdio cat16 .console} {
- exec $cat16 > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "{} stderr16"
-test winpipe-2.10 {16 bit comprehensive tests: from file handle} {pcOnly stdio cat16} {
- set f [open "little" r]
- exec $cat16 <@$f > stdout 2> stderr
- close $f
- list [contents stdout] [contents stderr]
-} "little stderr16"
-test winpipe-2.11 {16 bit comprehensive tests: read from application} {pcOnly stdio cat16} {
- set f [open "|$cat16 < little" r]
- gets $f line
- catch {close $f} msg
- list $line $msg
-} "little stderr16"
-test winpipe-2.12 {16 bit comprehensive tests: a little to file} {pcOnly stdio cat16} {
- exec $cat16 < little > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "little stderr16"
-test winpipe-2.13 {16 bit comprehensive tests: a lot to file} {pcOnly stdio cat16} {
- exec $cat16 < big > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "{$big} stderr16"
-test winpipe-2.14 {16 bit comprehensive tests: a little to pipe} {pcOnly stdio cat16} {
- exec $cat16 < little | $::tcltest::tcltest more > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} {little stderr16}
-test winpipe-2.15 {16 bit comprehensive tests: a lot to pipe} {pcOnly stdio cat16} {
- exec $cat16 < big | $::tcltest::tcltest more > stdout 2> stderr
- list [contents stdout] [contents stderr]
-} "{$big} stderr16"
-test winpipe-2.16 {16 bit comprehensive tests: to console} {pcOnly stdio cat16} {
- catch {exec $cat16 << "You should see this\n" >@stdout} msg
- set msg
-} [lindex stderr16 0]
-test winpipe-2.17 {16 bit comprehensive tests: to NUL} {nt stdio cat16} {
- # some apps hang when sending a large amount to NUL. cat16 isn't one.
- catch {exec $cat16 < big > nul} msg
- set msg
-} stderr16
-test winpipe-2.18 {16 bit comprehensive tests: to nowhere} {pcOnly stdio cat16 .console} {
- exec $cat16 < big >&@stdout
-} {}
-test winpipe-2.19 {16 bit comprehensive tests: to file handle} {pcOnly stdio cat16} {
- set f1 [open "stdout" w]
- set f2 [open "stderr" w]
- exec $cat16 < little >@$f1 2>@$f2
- close $f1
- close $f2
- list [contents stdout] [contents stderr]
-} "little stderr16"
-test winpipe-2.20 {16 bit comprehensive tests: write to application} {pcOnly stdio cat16} {
- set f [open "|$cat16 > stdout" w]
- puts -nonewline $f "foo"
- catch {close $f} msg
- list [contents stdout] $msg
-} "foo stderr16"
-test winpipe-2.21 {16 bit comprehensive tests: read/write application} {nt stdio cat16} {
- set f [open "|$cat16" r+]
- puts $f $big
- puts $f \032
- flush $f
- set r [read $f 64]
- catch {close $f}
- set r
-} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
file delete more
-test winpipe-4.1 {Tcl_WaitPid} {nt stdio} {
+test winpipe-4.1 {Tcl_WaitPid} {pcOnly nt exec cat32} {
proc readResults {f} {
global x result
if { [eof $f] } {
}
}
- set f [open "|$cat32 < big 2> stderr" r]
+ set f [open "|[list $cat32] < big 2> $path(stderr)" r]
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
- list $result $x [contents stderr]
+ list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
-close [open nothing w]
+set path(nothing) [makeFile {} nothing]
+close [open $path(nothing) w]
catch {set env_tmp $env(TMP)}
catch {set env_temp $env(TEMP)}
set env(TMP) c:/
set env(TEMP) c:/
-test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly stdio} {
+test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly exec} {
set x {}
set existing [glob -nocomplain c:/tcl*.tmp]
- exec $::tcltest::tcltest < nothing
+ exec [interpreter] < nothing
foreach p [glob -nocomplain c:/tcl*.tmp] {
if {[lsearch $existing $p] == -1} {
lappend x $p
}
set x
} {}
-test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly stdio} {
+test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly exec} {
set tmp $env(TMP)
set temp $env(TEMP)
unset env(TMP)
unset env(TEMP)
- exec $::tcltest::tcltest < nothing
+ exec [interpreter] < nothing
set env(TMP) $tmp
set env(TEMP) $temp
set x {}
} {}
test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \
- {pcOnly stdio} {
+ {pcOnly exec } {
set tmp $env(TMP)
set env(TMP) snarky
- exec $::tcltest::tcltest < nothing
+ exec [interpreter] < nothing
set env(TMP) $tmp
set x {}
} {}
test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \
- {pcOnly stdio} {
+ {pcOnly exec} {
set tmp $env(TMP)
set temp $env(TEMP)
unset env(TMP)
set env(TEMP) snarky
- exec $::tcltest::tcltest < nothing
+ exec [interpreter] < nothing
set env(TMP) $tmp
set env(TEMP) $temp
set x {}
} {}
test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \
- {pcOnly stdio cat32} {
- set f [open "|$cat32" r+]
+ {pcOnly exec cat32} {
+ set f [open "|[list $cat32]" r+]
fconfigure $f -blocking 0
fileevent $f writable { set x writable }
set x {}
} {writable timeout readable {foobar
} timeout 1 stderr32}
test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
- {pcOnly stdio cat32} {
- set f [open "|$cat32" r+]
+ {pcOnly exec cat32} {
+ set f [open "|[list $cat32]" r+]
fconfigure $f -blocking 0
fileevent $f writable { set x writable }
set x {}
lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}
-makeFile {
+set path(echoArgs.tcl) [makeFile {
puts "[list $argv0 $argv]"
-} echoArgs.tcl
+} echoArgs.tcl]
-test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly stdio} {
- exec $::tcltest::tcltest echoArgs.tcl foo "" bar
-} {echoArgs.tcl {foo {} bar}}
-test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly stdio} {
- exec $::tcltest::tcltest echoArgs.tcl foo \" bar
-} {echoArgs.tcl {foo {"} bar}}
+test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly exec} {
+ exec [interpreter] $path(echoArgs.tcl) foo "" bar
+} [list $path(echoArgs.tcl) {foo {} bar}]
+test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly exec} {
+ exec [interpreter] $path(echoArgs.tcl) foo \" bar
+} [list $path(echoArgs.tcl) {foo {"} bar}]
# restore old values for env(TMP) and env(TEMP)
file delete big little stdout stderr nothing echoArgs.tcl
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
set result
} {1969}
+# Next test tries to make sure that the Tcl clock stays in step
+# with the Windows clock. 3000 iterations really isn't enough,
+# but how many does a tester have patience for?
+
+test winTime-2.1 {Synchronization of Tcl and Windows clocks} {pcOnly} {
+ set failed 0
+ foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] {}
+ set olddiff [expr { abs ( $tcl_sec - $sys_sec
+ + 1.0e-6 * ( $tcl_usec - $sys_usec ) ) }]
+ set ok 1
+ for { set i 0 } { $i < 3000 } { incr i } {
+ foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] {}
+ set diff [expr { abs ( $tcl_sec - $sys_sec
+ + 1.0e-6 * ( $tcl_usec - $sys_usec ) ) }]
+ if { ( $diff > $olddiff + 1000 )
+ || ( $diff > 11000 ) } {
+ set failed 1
+ break
+ } else {
+ set olddiff $diff
+ after 1
+ }
+ }
+ set failed
+} {0}
+
# cleanup
::tcltest::cleanupTests
return
-
Tcl_Encoding \
Tcl_EncodingState \
Tcl_EncodingType \
- Tcl_EolTranslation \
Tcl_HashEntry \
Tcl_HashSearch \
Tcl_HashTable \
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated automatically using autoconf version 2.9
+# Generated automatically using autoconf version 2.13
# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
#
# This configure script is free software; the Free Software Foundation
ac_default_prefix=/usr/local
# Any additions from configure.in:
ac_help="$ac_help
- --with-tcl=DIR use Tcl 8.1 binaries from DIR"
+ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR"
# Initialize some variables set by options.
# The variables have the same names as the options, with
# Initialize some other variables.
subdirs=
MFLAGS= MAKEFLAGS=
+SHELL=${CONFIG_SHELL-/bin/sh}
+# Maximum number of lines to put in a shell here document.
+ac_max_here_lines=12
ac_prev=
for ac_option
verbose=yes ;;
-version | --version | --versio | --versi | --vers)
- echo "configure generated by autoconf version 2.9"
+ echo "configure generated by autoconf version 2.13"
exit 0 ;;
-with-* | --with-*)
done
# NLS nuisances.
-# Only set LANG and LC_ALL to C if already set.
-# These must not be set unconditionally because not all systems understand
-# e.g. LANG=C (notably SCO).
-if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+# Only set these to C if already set. These must not be set unconditionally
+# because not all systems understand e.g. LANG=C (notably SCO).
+# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
+# Non-C LC_CTYPE values break the ctype check.
if test "${LANG+set}" = set; then LANG=C; export LANG; fi
+if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
+if test "${LC_CTYPE+set}" = set; then LC_CTYPE=C; export LC_CTYPE; fi
# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -rf conftest* confdefs.h
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
-ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+cross_compiling=$ac_cv_prog_cc_cross
+ac_exeext=
+ac_objext=o
if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
# Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
# not, assume that its top-level directory is a sibling of ours.
#--------------------------------------------------------------------
+DEF_VER=8.4
+
# Check whether --with-tcl or --without-tcl was given.
if test "${with_tcl+set}" = set; then
withval="$with_tcl"
TCL_BIN_DIR=$withval
else
- TCL_BIN_DIR=`cd ../../tcl8.1$TCL_PATCH_LEVEL/unix; pwd`
+ TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`
fi
if test ! -d $TCL_BIN_DIR; then
# --recheck option to rerun configure.
#
EOF
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, don't put newlines in cache variables' values.
# Ultrix sh set writes to stderr and can't be redirected directly,
# and sets the high bit in the cache file unless we assign to the vars.
(set) 2>&1 |
- sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \
- >> confcache
+ case `(ac_space=' '; set | grep ac_space) 2>&1` in
+ *ac_space=\ *)
+ # `set' does not quote correctly, so add quotes (double-quote substitution
+ # turns \\\\ into \\, and sed turns \\ into \).
+ sed -n \
+ -e "s/'/'\\\\''/g" \
+ -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
+ ;;
+ *)
+ # `set' quotes correctly as required by POSIX, so do not add quotes.
+ sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
+ ;;
+ esac >> confcache
if cmp -s $cache_file confcache; then
:
else
echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
-version | --version | --versio | --versi | --vers | --ver | --ve | --v)
- echo "$CONFIG_STATUS generated by autoconf version 2.9"
+ echo "$CONFIG_STATUS generated by autoconf version 2.13"
exit 0 ;;
-help | --help | --hel | --he | --h)
echo "\$ac_cs_usage"; exit 0 ;;
s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
$ac_vpsub
$extrasub
+s%@SHELL@%$SHELL%g
s%@CFLAGS@%$CFLAGS%g
s%@CPPFLAGS@%$CPPFLAGS%g
s%@CXXFLAGS@%$CXXFLAGS%g
+s%@FFLAGS@%$FFLAGS%g
s%@DEFS@%$DEFS%g
s%@LDFLAGS@%$LDFLAGS%g
s%@LIBS@%$LIBS%g
CEOF
EOF
+
+cat >> $CONFIG_STATUS <<\EOF
+
+# Split the substitutions into bite-sized pieces for seds with
+# small command number limits, like on Digital OSF/1 and HP-UX.
+ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
+ac_file=1 # Number of current file.
+ac_beg=1 # First line for current file.
+ac_end=$ac_max_sed_cmds # Line after last line for current file.
+ac_more_lines=:
+ac_sed_cmds=""
+while $ac_more_lines; do
+ if test $ac_beg -gt 1; then
+ sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
+ else
+ sed "${ac_end}q" conftest.subs > conftest.s$ac_file
+ fi
+ if test ! -s conftest.s$ac_file; then
+ ac_more_lines=false
+ rm -f conftest.s$ac_file
+ else
+ if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds="sed -f conftest.s$ac_file"
+ else
+ ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
+ fi
+ ac_file=`expr $ac_file + 1`
+ ac_beg=$ac_end
+ ac_end=`expr $ac_end + $ac_max_sed_cmds`
+ fi
+done
+if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds=cat
+fi
+EOF
+
cat >> $CONFIG_STATUS <<EOF
CONFIG_FILES=\${CONFIG_FILES-"Makefile tcl.hpj"}
EOF
cat >> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
- # Support "outfile[:infile]", defaulting infile="outfile.in".
+ # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
case "$ac_file" in
- *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
+ *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
*) ac_file_in="${ac_file}.in" ;;
esac
- # Adjust relative srcdir, etc. for subdirectories.
+ # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.
# Remove last slash and all that follows it. Not all systems have dirname.
ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
top_srcdir="$ac_dots$ac_given_srcdir" ;;
esac
+
echo creating "$ac_file"
rm -f "$ac_file"
configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
# $configure_input" ;;
*) ac_comsub= ;;
esac
+
+ ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
sed -e "$ac_comsub
s%@configure_input@%$configure_input%g
s%@srcdir@%$srcdir%g
s%@top_srcdir@%$top_srcdir%g
-" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file
+" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
fi; done
-rm -f conftest.subs
+rm -f conftest.s*
+EOF
+cat >> $CONFIG_STATUS <<EOF
+EOF
+cat >> $CONFIG_STATUS <<\EOF
exit 0
EOF
# not, assume that its top-level directory is a sibling of ours.
#--------------------------------------------------------------------
-AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.3 binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl8.3$TCL_PATCH_LEVEL/unix; pwd`)
+DEF_VER=8.4
+
+AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist)
fi
proc EOL::fix {filename {newfilename ""}} {
variable outMode
- if {![file exist $filename]} { return }
+ if {![file exists $filename]} { return }
puts "EOL Fixing: $filename"
file rename ${filename} ${filename}.o
#
# RCS: @(#) $Id$
+package require Tcl 8
+
namespace eval genStubs {
# libraryName --
#
# Arguments:
# index The index number of the interface.
# platform The platform the interface belongs to. Should be one
-# of generic, win, unix, or mac.
+# of generic, win, unix, or mac, or macosx or aqua or x11.
# decl The C function declaration, or {} for an undefined
# entry.
#
# None.
proc genStubs::rewriteFile {file text} {
- if {![file exist $file]} {
+ if {![file exists $file]} {
puts stderr "Cannot find file: $file"
return
}
set in [open ${file} r]
set out [open ${file}.new w]
- # Always write out the file with LF termination
- fconfigure $out -translation lf
-
while {![eof $in]} {
set line [gets $in]
if {[regexp {!BEGIN!} $line]} {
mac {
return "#ifdef MAC_TCL\n${text}#endif /* MAC_TCL */\n"
}
+ macosx {
+ return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n"
+ }
+ aqua {
+ return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n"
+ }
+ x11 {
+ return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n"
+ }
}
return "$text"
}
set emit 1
}
}
+ #
+ # "aqua" and "macosx" and "x11" are special cases,
+ # since "macosx" always implies "unix" and "aqua",
+ # "macosx", so we need to be careful not to
+ # emit duplicate stubs entries for the two.
+ #
+ if {[info exists stubs($name,aqua,$i)]
+ && ![info exists stubs($name,macosx,$i)]} {
+ append text [addPlatformGuard aqua \
+ [$slotProc $name $stubs($name,aqua,$i) $i]]
+ set emit 1
+ }
+ if {[info exists stubs($name,macosx,$i)]
+ && ![info exists stubs($name,unix,$i)]} {
+ append text [addPlatformGuard macosx \
+ [$slotProc $name $stubs($name,macosx,$i) $i]]
+ set emit 1
+ }
+ if {[info exists stubs($name,x11,$i)]
+ && ![info exists stubs($name,unix,$i)]} {
+ append text [addPlatformGuard x11 \
+ [$slotProc $name $stubs($name,x11,$i) $i]]
+ set emit 1
+ }
}
if {$emit == 0} {
eval {append text} $skipString
append text [addPlatformGuard $plat $temp]
}
}
+ # Again, make sure you don't duplicate entries for macosx & aqua.
+ if {[info exists stubs($name,aqua,lastNum)]
+ && ![info exists stubs($name,macosx,lastNum)]} {
+ set lastNum $stubs($name,aqua,lastNum)
+ set temp {}
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ if {![info exists stubs($name,aqua,$i)]} {
+ eval {append temp} $skipString
+ } else {
+ append temp [$slotProc $name $stubs($name,aqua,$i) $i]
+ }
+ }
+ append text [addPlatformGuard aqua $temp]
+ }
+ # Again, make sure you don't duplicate entries for macosx & unix.
+ if {[info exists stubs($name,macosx,lastNum)]
+ && ![info exists stubs($name,unix,lastNum)]} {
+ set lastNum $stubs($name,macosx,lastNum)
+ set temp {}
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ if {![info exists stubs($name,macosx,$i)]} {
+ eval {append temp} $skipString
+ } else {
+ append temp [$slotProc $name $stubs($name,macosx,$i) $i]
+ }
+ }
+ append text [addPlatformGuard macosx $temp]
+ }
+ # Again, make sure you don't duplicate entries for x11 & unix.
+ if {[info exists stubs($name,x11,lastNum)]
+ && ![info exists stubs($name,unix,lastNum)]} {
+ set lastNum $stubs($name,x11,lastNum)
+ set temp {}
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ if {![info exists stubs($name,x11,$i)]} {
+ eval {append temp} $skipString
+ } else {
+ append temp [$slotProc $name $stubs($name,x11,$i) $i]
+ }
+ }
+ append text [addPlatformGuard x11 $temp]
+ }
}
-
}
# genStubs::emitDeclarations --
# PASS 1
#
+set man2tclprog [file join [file dirname [info script]] man2tcl.exe]
+
proc generateContents {basename version files} {
global curID topics
set curID 0
flush stdout
doFile $f
}
- set fd [open "$basename$version.cnt" w]
+ set fd [open [file join [file dirname [info script]] $basename$version.cnt] w]
fconfigure $fd -translation crlf
puts $fd ":Base $basename$version.hlp"
foreach package [getPackages] {
}
}
- set file [open "$basename.rtf" w]
+ set file [open [file join [file dirname [info script]] $basename.rtf] w]
fconfigure $file -translation crlf
- puts $file "\{\\rtf1\\ansi \\deff0\\deflang1033\{\\fonttbl\{\\f0\\froman\\fcharset0\\fprq2 Times New Roman\;\}\}"
+ puts $file "\{\\rtf1\\ansi \\deff0\\deflang1033\{\\fonttbl\{\\f0\\froman\\fcharset0\\fprq2 Times New Roman\;\}\{\\f1\\fmodern\\fcharset0\\fprq1 Courier New\;\}\}"
foreach f $files {
puts "Pass 2 -- $f"
flush stdout
# file - Name of file to translate.
proc doFile {file} {
- if {[catch {eval [exec man2tcl [glob $file]]} msg] &&
- [catch {eval [exec ./man2tcl [glob $file]]} msg]} {
+ global man2tclprog
+ if {[catch {eval [exec $man2tclprog [glob $file]]} msg]} {
global errorInfo
puts stderr $msg
puts "in"
proc doDir dir {
puts "Generating man pages for $dir..."
- foreach f [lsort [glob [file join $dir *.\[13n\]]]] {
- do $f
+ foreach f [lsort [glob -directory $dir "*.\[13n\]"]] {
+ doFile $f
}
}
# process command line arguments
if {$argc < 3} {
- puts stderr "usage: $argv0 projectName version manFiles..."
+ puts stderr "usage: $argv0 \[options\] projectName version manFiles..."
exit 1
}
-set baseName [lindex $argv 0]
-set version [lindex $argv 1]
+set arg 0
+
+if {![string compare [lindex $argv $arg] "-bitmap"]} {
+ set bitmap [lindex $argv [incr arg]]
+ incr arg
+}
+set baseName [lindex $argv $arg]
+set version [lindex $argv [incr arg]]
set files {}
-foreach i [lrange $argv 2 end] {
+foreach i [lrange $argv [incr arg] end] {
set i [file join $i]
if {[file isdir $i]} {
- foreach f [lsort [glob [file join $i *.\[13n\]]]] {
+ foreach f [lsort [glob -directory $i "*.\[13n\]"]] {
lappend files $f
}
} elseif {[file exists $i]} {
lappend files $i
}
}
-
-source [file join [file dir $argv0] index.tcl]
+source [file join [file dirname [info script]] index.tcl]
generateContents $baseName $version $files
-source [file join [file dir $argv0] man2help2.tcl]
+source [file join [file dirname [info script]] man2help2.tcl]
generateHelp $baseName $files
}
tab
}
- AS {} ;# next page and previous page
+ AS {
+ # next page and previous page
+ }
br {
lineBreak
}
BS {}
BE {}
CE {
- decrNestingLevel
+ puts -nonewline $::file "\\f0\\fs20 "
set state(noFill) 0
set state(breakPending) 0
- newPara 0i
+ newPara ""
+ set state(leftIndent) [expr {$state(leftIndent) - $state(offset)}]
+ set state(sb) 80
}
- CS { ;# code section
- incrNestingLevel
+ CS {
+ # code section
set state(noFill) 1
- newPara 0i
+ newPara ""
+ set state(leftIndent) [expr {$state(leftIndent) + $state(offset)}]
+ set state(sb) 80
+ puts -nonewline $::file "\\f1\\fs18 "
}
DE {
set state(noFill) 0
}
o {
text "\\'"
- regexp "'([^']*)'(.*)" $text all ch text
+ regexp {'([^']*)'(.*)} $text all ch text
text $chars($ch)
}
default {
set args [join $argList " "]
if {[llength $argList] < 1} {
- puts stderr "Bad .SH macro: .$name $args"
+ puts stderr "Bad .SH macro: .SH $args"
}
# control what the text proc does with text
# argList - List of arguments to the .TH macro.
proc THmacro {argList} {
- global file curPkg curSect curID id_keywords state curVer
+ global file curPkg curSect curID id_keywords state curVer bitmap
if {[llength $argList] != 5} {
set args [join $argList " "]
- puts stderr "Bad .TH macro: .$name $args"
+ puts stderr "Bad .TH macro: .TH $args"
}
incr curID
set name [lindex $argList 0] ;# Tcl_UpVar
tab
text $curSect
font R
+ if {[info exists bitmap]} {
+ # a right justified bitmap
+ puts $file "\\\{bmrt $bitmap\\\}"
+ }
puts $file "\\fs20"
set state(breakPending) -1
}
if $state(paragraph) {
puts -nonewline $file "\\line\n"
}
- set state(leftIndent) [expr {$state(leftMargin) \
- + ($state(offset) * $state(nestingLevel)) +[getTwips $leftIndent]}]
+ if {$leftIndent != ""} {
+ set state(leftIndent) [expr {$state(leftMargin) \
+ + ($state(offset) * $state(nestingLevel)) \
+ + [getTwips $leftIndent]}]
+ }
set state(firstIndent) [getTwips $firstIndent]
set state(paragraphPending) 1
}
}
}
-
# dir - Name of the directory.
proc doDir dir {
- foreach f [lsort [glob $dir/*.\[13n\]]] {
+ foreach f [lsort [glob -directory $dir "*.\[13n\]"]] {
do $f ;# defined in man2html1.tcl & man2html2.tcl
}
}
char **argv; /* Values of command-line arguments. */
{
FILE *f;
-#define MAX_LINE_SIZE 500
+#define MAX_LINE_SIZE 1000
char line[MAX_LINE_SIZE];
char *p;
continue;
}
+ if (strlen(line) >= MAX_LINE_SIZE -1) {
+ fprintf(stderr, "Too long line. Max is %d chars.\n",
+ MAX_LINE_SIZE - 1);
+ exit(1);
+ }
+
if ((line[0] == '.') || (line[0] == '\'')) {
/*
* This line is a macro invocation.
LCID=0x409 0x0 0x0 ;English (United States)\r
REPORT=Yes\r
TITLE=Tcl/Tk Reference Manual\r
-CNT=tcl83.cnt\r
-COPYRIGHT=Copyright © 1999 Scriptics Corporation\r
-HLP=tcl83.hlp\r
+CNT=tcl84.cnt\r
+COPYRIGHT=Copyright © 2000 Ajuba Solutions\r
+HLP=tcl84.hlp\r
\r
[FILES]\r
tcl.rtf\r
\r
[CONFIG]\r
BrowseButtons()\r
+\r
-Document Type: WSE
-item: Global
- Version=6.01
- Title=Tcl 8.3 for Windows Installation
- Flags=00010100
- Languages=65 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
- Japanese Font Name=MS Gothic
- Japanese Font Size=10
- Start Gradient=0 0 255
- End Gradient=0 0 0
- Windows Flags=00000000000000010010110000001000
- Log Pathname=%MAINDIR%\INSTALL.LOG
- Message Font=MS Sans Serif
- Font Size=8
- Disk Label=tcl8.3.2
- Disk Filename=setup
- Patch Flags=0000000000000001
- Patch Threshold=85
- Patch Memory=4000
- Variable Name1=_SYS_
- Variable Default1=C:\WINDOWS\SYSTEM
- Variable Flags1=00001000
- Variable Name2=_ODBC16_
- Variable Default2=C:\WINDOWS\SYSTEM
- Variable Flags2=00001000
- Variable Name3=_WISE_
- Variable Default3=${__WISE__}
- Variable Flags3=00001000
-end
-item: Open/Close INSTALL.LOG
- Flags=00000001
-end
-item: Check if File/Dir Exists
- Pathname=%SYS%
- Flags=10000100
-end
-item: Set Variable
- Variable=SYS
- Value=%WIN%
-end
-item: End Block
-end
-item: Set Variable
- Variable=VER
- Value=8.3
-end
-item: Set Variable
- Variable=PATCHLEVEL
- Value=${__TCL_PATCH_LEVEL__}
-end
-item: Set Variable
- Variable=APPTITLE
- Value=Tcl/Tk %PATCHLEVEL% for Windows
-end
-item: Set Variable
- Variable=URL
- Value=http://dev.scriptics.com/registration/%PATCHLEVEL%.html
-end
-item: Set Variable
- Variable=GROUP
- Value=Tcl
-end
-item: Set Variable
- Variable=DISABLED
- Value=!
-end
-item: Set Variable
- Variable=MAINDIR
- Value=Tcl
-end
-item: Check Configuration
- Flags=10111011
-end
-item: Get Registry Key Value
- Variable=PROGRAM_FILES
- Key=SOFTWARE\Microsoft\Windows\CurrentVersion
- Default=C:\Program Files
- Value Name=ProgramFilesDir
- Flags=00000100
-end
-item: Set Variable
- Variable=MAINDIR
- Value=%PROGRAM_FILES%\%MAINDIR%
-end
-item: Set Variable
- Variable=EXPLORER
- Value=1
-end
-item: Else Statement
-end
-item: Set Variable
- Variable=MAINDIR
- Value=C:\%MAINDIR%
-end
-item: End Block
-end
-item: Set Variable
- Variable=BACKUP
- Value=%MAINDIR%\BACKUP
-end
-item: Set Variable
- Variable=DOBACKUP
- Value=B
-end
-item: Set Variable
- Variable=BRANDING
- Value=0
-end
-remarked item: If/While Statement
- Variable=BRANDING
- Value=1
-end
-remarked item: Read INI Value
- Variable=NAME
- Pathname=%INST%\CUSTDATA.INI
- Section=Registration
- Item=Name
-end
-remarked item: Read INI Value
- Variable=COMPANY
- Pathname=%INST%\CUSTDATA.INI
- Section=Registration
- Item=Company
-end
-remarked item: If/While Statement
- Variable=NAME
-end
-remarked item: Set Variable
- Variable=DOBRAND
- Value=1
-end
-remarked item: End Block
-end
-remarked item: End Block
-end
-item: Set Variable
- Variable=TYPE
- Value=C
-end
-item: Set Variable
- Variable=COMPONENTS
- Value=ABC
-end
-item: Wizard Block
- Direction Variable=DIRECTION
- Display Variable=DISPLAY
- X Position=0
- Y Position=0
- Filler Color=8421440
- Flags=00000001
-end
-item: Custom Dialog Set
- Name=Splash
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Bienvenue
- Title German=Willkommen
- Title Portuguese=Bem-vindo
- Title Spanish=Bienvenido
- Title Italian=Benvenuto
- Title Danish=Velkommen
- Title Dutch=Welkom
- Title Norwegian=Velkommen
- Title Swedish=Välkommen
- Width=273
- Height=250
- Font Name=Helv
- Font Size=8
- item: Push Button
- Rectangle=166 214 208 228
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Next >
- end
- item: Push Button
- Rectangle=212 214 254 228
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=Cancel
- end
- item: Static
- Rectangle=0 0 268 233
- Action=2
- Enabled Color=00000000000000001111111111111111
- Create Flags=01010000000000000000000000001011
- Pathname=${__TCLBASEDIR__}\tools\white.bmp
- end
- item: Static
- Rectangle=5 5 268 215
- Destination Dialog=1
- Action=2
- Enabled Color=00000000000000001111111111111111
- Create Flags=01010000000000000000000000001011
- Pathname=${__TCLBASEDIR__}\tools\tclSplash.bmp
- end
- end
-end
-item: End Block
-end
-item: Wizard Block
- Direction Variable=DIRECTION
- Display Variable=DISPLAY
- Bitmap Pathname=%_WISE_%\DIALOGS\TEMPLATE\WIZARD.BMP
- X Position=9
- Y Position=10
- Filler Color=8421440
- Dialog=Welcome
- Dialog=Select Destination Directory
- Dialog=Select Installation Type
- Dialog=Select Components
- Dialog=Select Program Manager Group
- Variable=
- Variable=
- Variable=
- Variable=TYPE
- Variable=EXPLORER
- Value=
- Value=
- Value=
- Value=C
- Value=1
- Compare=0
- Compare=0
- Compare=0
- Compare=1
- Compare=0
- Flags=00000011
-end
-item: Custom Dialog Set
- Name=Welcome
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Installation de %APPTITLE%
- Title German=Installation von %APPTITLE%
- Title Spanish=Instalación de %APPTITLE%
- Title Italian=Installazione di %APPTITLE%
- Width=271
- Height=224
- Font Name=Helv
- Font Size=8
- item: Static
- Rectangle=86 8 258 42
- Create Flags=01010000000000000000000000000000
- Flags=0000000000000001
- Name=Times New Roman
- Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
- Text=Welcome!
- Text French=Bienvenue !
- Text German=Willkommen!
- Text Spanish=¡Bienvenido!
- Text Italian=Benvenuti!
- end
- item: Push Button
- Rectangle=150 187 195 202
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Next >
- Text French=&Suite >
- Text German=&Weiter >
- Text Spanish=&Siguiente >
- Text Italian=&Avanti >
- end
- item: Push Button
- Rectangle=105 187 150 202
- Variable=DISABLED
- Value=!
- Create Flags=01010000000000010000000000000000
- Text=< &Back
- Text French=< &Retour
- Text German=< &Zurück
- Text Spanish=< &Atrás
- Text Italian=< &Indietro
- end
- item: Push Button
- Rectangle=211 187 256 202
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=&Cancel
- Text French=&Annuler
- Text German=&Abbrechen
- Text Spanish=&Cancelar
- Text Italian=&Annulla
- end
- item: Static
- Rectangle=85 41 255 130
- Create Flags=01010000000000000000000000000000
- Text=This installation program will install %APPTITLE%.
- Text=
- Text=Press the Next button to start the installation. You can press the Exit Setup button now if you do not want to install %APPTITLE% at this time.
- Text=
- Text=It is strongly recommended that you exit all Windows programs before running this installation program.
- Text French=Ce programme d'installation va installer %APPTITLE%.
- Text French=
- Text French=Cliquez sur le bouton Suite pour démarrer l'installation. Vous pouvez cliquer sur le bouton Quitter l'installation si vous ne voulez pas installer %APPTITLE% tout de suite.
- Text German=Mit diesem Installationsprogramm wird %APPTITLE% installiert.
- Text German=
- Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "Abbrechen", um die Installation von %APPTITLE% abzubrechen.
- Text Spanish=Este programa de instalación instalará %APPTITLE%.
- Text Spanish=
- Text Spanish=Presione el botón Siguiente para iniciar la instalación. Puede presionar el botón Salir de instalación si no desea instalar %APPTITLE% en este momento.
- Text Italian=Questo programma installerà %APPTITLE%.
- Text Italian=
- Text Italian=Per avvviare l'installazione premere il pulsante Avanti. Se non si desidera installare %APPTITLE% ora, premere il pulsante Esci dall'installazione.
- end
- item: Static
- Rectangle=8 180 256 181
- Action=3
- Create Flags=01010000000000000000000000000111
- end
- end
-end
-item: Custom Dialog Set
- Name=Select Destination Directory
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Installation de %APPTITLE%
- Title German=Installation von %APPTITLE%
- Title Spanish=Instalación de %APPTITLE%
- Title Italian=Installazione di %APPTITLE%
- Width=271
- Height=224
- Font Name=Helv
- Font Size=8
- item: Push Button
- Rectangle=150 187 195 202
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Next >
- Text French=&Suite >
- Text German=&Weiter >
- Text Spanish=&Siguiente >
- Text Italian=&Avanti >
- end
- item: Push Button
- Rectangle=105 187 150 202
- Variable=DIRECTION
- Value=B
- Create Flags=01010000000000010000000000000000
- Flags=0000000000000001
- Text=< &Back
- Text French=< &Retour
- Text German=< &Zurück
- Text Spanish=< &Atrás
- Text Italian=< &Indietro
- end
- item: Push Button
- Rectangle=211 187 256 202
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=&Cancel
- Text French=&Annuler
- Text German=&Abbrechen
- Text Spanish=&Cancelar
- Text Italian=&Annulla
- end
- item: Static
- Rectangle=8 180 256 181
- Action=3
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 8 258 42
- Create Flags=01010000000000000000000000000000
- Flags=0000000000000001
- Name=Times New Roman
- Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
- Text=Select Destination Directory
- Text French=Sélectionner le répertoire de destination
- Text German=Zielverzeichnis wählen
- Text Spanish=Seleccione el directorio de destino
- Text Italian=Selezionare Directory di destinazione
- end
- item: Static
- Rectangle=86 39 256 114
- Create Flags=01010000000000000000000000000000
- Text=Please select the directory where the %APPTITLE% files are to be installed.
- Text=
- Text=To install in the default directory below, click Next.
- Text=
- Text=To install in a different directory, click Browse and select another directory.
- Text French=Veuillez sélectionner le répertoire dans lequel les fichiers %APPTITLE% doivent être installés.
- Text German=Geben Sie an, in welchem Verzeichnis die %APPTITLE%-Dateien installiert werden sollen.
- Text Spanish=Por favor seleccione el directorio donde desee instalar los archivos de %APPTITLE%.
- Text Italian=Selezionare la directory dove verranno installati i file %APPTITLE%.
- end
- item: Static
- Rectangle=86 130 256 157
- Action=1
- Create Flags=01010000000000000000000000000111
- end
- item: Push Button
- Rectangle=205 138 250 153
- Variable=MAINDIR_SAVE
- Value=%MAINDIR%
- Destination Dialog=1
- Action=2
- Create Flags=01010000000000010000000000000000
- Text=Browse
- Text French=Parcourir
- Text German=Durchsuchen
- Text Spanish=Buscar
- Text Italian=Sfoglie
- end
- item: Static
- Rectangle=91 140 198 151
- Create Flags=01010000000000000000000000000000
- Text=%MAINDIR%
- Text French=%MAINDIR%
- Text German=%MAINDIR%
- Text Spanish=%MAINDIR%
- Text Italian=%MAINDIR%
- end
- end
- item: Dialog
- Title=Select Destination Directory
- Title French=Sélectionner le répertoire de destination
- Title German=Zielverzeichnis wählen
- Title Spanish=Seleccione el directorio de destino
- Title Italian=Selezionare Directory di destinazione
- Width=221
- Height=173
- Font Name=Helv
- Font Size=8
- item: Listbox
- Rectangle=5 5 163 149
- Variable=MAINDIR
- Create Flags=01010000100000010000000101000000
- Flags=0000110000100010
- Text=%MAINDIR%
- Text French=%MAINDIR%
- Text German=%MAINDIR%
- Text Spanish=%MAINDIR%
- Text Italian=%MAINDIR%
- end
- item: Push Button
- Rectangle=167 6 212 21
- Create Flags=01010000000000010000000000000001
- Text=OK
- Text French=OK
- Text German=OK
- Text Spanish=Aceptar
- Text Italian=OK
- end
- item: Push Button
- Rectangle=167 25 212 40
- Variable=MAINDIR
- Value=%MAINDIR_SAVE%
- Create Flags=01010000000000010000000000000000
- Flags=0000000000000001
- Text=Cancel
- Text French=Annuler
- Text German=Abbrechen
- Text Spanish=Cancelar
- Text Italian=Annulla
- end
- end
-end
-remarked item: Custom Dialog Set
- Name=Select Installation Type
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Installation de %APPTITLE%
- Title German=Installation von %APPTITLE%
- Title Spanish=Instalación de %APPTITLE%
- Title Italian=Installazione di %APPTITLE%
- Width=271
- Height=224
- Font Name=Helv
- Font Size=8
- item: Push Button
- Rectangle=150 187 195 202
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Next >
- Text French=&Suite >
- Text German=&Weiter >
- Text Spanish=&Siguiente >
- Text Italian=&Avanti >
- end
- item: Push Button
- Rectangle=105 187 150 202
- Variable=DIRECTION
- Value=B
- Create Flags=01010000000000010000000000000000
- Text=< &Back
- Text French=< &Retour
- Text German=< &Zurück
- Text Spanish=< &Atrás
- Text Italian=< &Indietro
- end
- item: Push Button
- Rectangle=211 187 256 202
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=&Cancel
- Text French=&Annuler
- Text German=&Abbrechen
- Text Spanish=&Cancelar
- Text Italian=&Annulla
- end
- item: Static
- Rectangle=8 180 256 181
- Action=3
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 8 258 42
- Create Flags=01010000000000000000000000000000
- Flags=0000000000000001
- Name=Times New Roman
- Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
- Text=Select Installation Type
- Text French=Sélectionner les composants
- Text German=Komponenten auswählen
- Text Spanish=Seleccione componentes
- Text Italian=Selezionare i componenti
- end
- item: Static
- Rectangle=194 162 242 172
- Variable=COMPONENTS
- Value=MAINDIR
- Create Flags=01010000000000000000000000000010
- end
- item: Static
- Rectangle=194 153 242 162
- Variable=COMPONENTS
- Create Flags=01010000000000000000000000000010
- end
- item: Static
- Rectangle=107 153 196 164
- Create Flags=01010000000000000000000000000000
- Text=Disk Space Required:
- Text French=Espace disque requis :
- Text German=Notwendiger Speicherplatz:
- Text Spanish=Espacio requerido en el disco:
- Text Italian=Spazio su disco necessario:
- end
- item: Static
- Rectangle=107 162 196 172
- Create Flags=01010000000000000000000000000000
- Text=Disk Space Remaining:
- Text French=Espace disque disponible :
- Text German=Verbleibender Speicherplatz:
- Text Spanish=Espacio en disco disponible:
- Text Italian=Spazio su disco disponibile:
- end
- item: Static
- Rectangle=86 145 256 175
- Action=1
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 42 256 61
- Create Flags=01010000000000000000000000000000
- Text=Choose which type of installation to perform by selecting one of the buttons below.
- Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.
- Text German=Wählen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden Kästchen klicken.
- Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.
- Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.
- end
- item: Radio Button
- Rectangle=86 74 256 128
- Variable=TYPE
- Create Flags=01010000000000010000000000001001
- Text=&Full Installation (Recommended)
- Text=&Minimal Installation
- Text=C&ustom Installation
- Text=
- end
- end
-end
-item: Custom Dialog Set
- Name=Select Components
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Installation de %APPTITLE%
- Title German=Installation von %APPTITLE%
- Title Spanish=Instalación de %APPTITLE%
- Title Italian=Installazione di %APPTITLE%
- Width=271
- Height=224
- Font Name=Helv
- Font Size=8
- item: Push Button
- Rectangle=150 187 195 202
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Next >
- Text French=&Suite >
- Text German=&Weiter >
- Text Spanish=&Siguiente >
- Text Italian=&Avanti >
- end
- item: Push Button
- Rectangle=105 187 150 202
- Variable=DIRECTION
- Value=B
- Create Flags=01010000000000010000000000000000
- Text=< &Back
- Text French=< &Retour
- Text German=< &Zurück
- Text Spanish=< &Atrás
- Text Italian=< &Indietro
- end
- item: Push Button
- Rectangle=211 187 256 202
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=&Cancel
- Text French=&Annuler
- Text German=&Abbrechen
- Text Spanish=&Cancelar
- Text Italian=&Annulla
- end
- item: Static
- Rectangle=8 180 256 181
- Action=3
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 8 258 42
- Create Flags=01010000000000000000000000000000
- Flags=0000000000000001
- Name=Times New Roman
- Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
- Text=Select Components
- Text French=Sélectionner les composants
- Text German=Komponenten auswählen
- Text Spanish=Seleccione componentes
- Text Italian=Selezionare i componenti
- end
- item: Checkbox
- Rectangle=86 75 256 129
- Variable=COMPONENTS
- Create Flags=01010000000000010000000000000011
- Flags=0000000000000110
- Text=Tcl Run-Time Files
- Text=Example Scripts
- Text=Help Files
- Text=Header and Library Files
- Text=
- Text French=Tcl Run-Time Files
- Text French=Example Scripts
- Text French=Help Files
- Text French=Header and Library Files
- Text French=
- Text German=Tcl Run-Time Files
- Text German=Example Scripts
- Text German=Help Files
- Text German=Header and Library Files
- Text German=
- Text Spanish=Tcl Run-Time Files
- Text Spanish=Example Scripts
- Text Spanish=Help Files
- Text Spanish=Header and Library Files
- Text Spanish=
- Text Italian=Tcl Run-Time Files
- Text Italian=Example Scripts
- Text Italian=Help Files
- Text Italian=Header and Library Files
- Text Italian=
- end
- item: Static
- Rectangle=194 162 242 172
- Variable=COMPONENTS
- Value=MAINDIR
- Create Flags=01010000000000000000000000000010
- end
- item: Static
- Rectangle=194 153 242 162
- Variable=COMPONENTS
- Create Flags=01010000000000000000000000000010
- end
- item: Static
- Rectangle=107 153 196 164
- Create Flags=01010000000000000000000000000000
- Text=Disk Space Required:
- Text French=Espace disque requis :
- Text German=Notwendiger Speicherplatz:
- Text Spanish=Espacio requerido en el disco:
- Text Italian=Spazio su disco necessario:
- end
- item: Static
- Rectangle=107 162 196 172
- Create Flags=01010000000000000000000000000000
- Text=Disk Space Remaining:
- Text French=Espace disque disponible :
- Text German=Verbleibender Speicherplatz:
- Text Spanish=Espacio en disco disponible:
- Text Italian=Spazio su disco disponibile:
- end
- item: Static
- Rectangle=86 145 256 175
- Action=1
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 42 256 61
- Create Flags=01010000000000000000000000000000
- Text=Choose which components to install by checking the boxes below.
- Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.
- Text German=Wählen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden Kästchen klicken.
- Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.
- Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.
- end
- end
-end
-item: Custom Dialog Set
- Name=Select Program Manager Group
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Installation de %APPTITLE%
- Title German=Installation von %APPTITLE%
- Title Spanish=Instalación de %APPTITLE%
- Title Italian=Installazione di %APPTITLE%
- Width=271
- Height=224
- Font Name=Helv
- Font Size=8
- item: Push Button
- Rectangle=150 187 195 202
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Next >
- Text French=&Suite >
- Text German=&Weiter >
- Text Spanish=&Siguiente >
- Text Italian=&Avanti >
- end
- item: Push Button
- Rectangle=105 187 150 202
- Variable=DIRECTION
- Value=B
- Create Flags=01010000000000010000000000000000
- Flags=0000000000000001
- Text=< &Back
- Text French=< &Retour
- Text German=< &Zurück
- Text Spanish=< &Atrás
- Text Italian=< &Indietro
- end
- item: Push Button
- Rectangle=211 187 256 202
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=&Cancel
- Text French=&Annuler
- Text German=&Abbrechen
- Text Spanish=&Cancelar
- Text Italian=&Annulla
- end
- item: Static
- Rectangle=8 180 256 181
- Action=3
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 8 258 42
- Create Flags=01010000000000000000000000000000
- Flags=0000000000000001
- Name=Times New Roman
- Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
- Text=Select ProgMan Group
- Text French=Sélectionner le groupe du Gestionnaire de programme
- Text German=Bestimmung der Programm-Managergruppe
- Text Spanish=Seleccione grupo del Administrador de programas
- Text Italian=Selezionare il gruppo ProgMan
- end
- item: Static
- Rectangle=86 44 256 68
- Create Flags=01010000000000000000000000000000
- Text=Enter the name of the Program Manager group to add the %APPTITLE% icons to:
- Text French=Entrez le nom du groupe du Gestionnaire de programme dans lequel vous souhaitez ajouter les icônes de %APPTITLE% :
- Text German=Geben Sie den Namen der Programmgruppe ein, der das Symbol %APPTITLE% hinzugefügt werden soll:
- Text Spanish=Escriba el nombre del grupo del Administrador de programas en el que desea agregar los iconos de %APPTITLE%:
- Text Italian=Inserire il nome del gruppo Program Manager per aggiungere le icone %APPTITLE% a:
- end
- item: Combobox
- Rectangle=86 69 256 175
- Variable=GROUP
- Create Flags=01010000000000010000001000000001
- Flags=0000000000000001
- Text=%GROUP%
- Text French=%GROUP%
- Text German=%GROUP%
- Text Spanish=%GROUP%
- Text Italian=%GROUP%
- end
- end
-end
-item: Custom Dialog Set
- Name=Start Installation
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Installation de %APPTITLE%
- Title German=Installation von %APPTITLE%
- Title Spanish=Instalación de %APPTITLE%
- Title Italian=Installazione di %APPTITLE%
- Width=271
- Height=224
- Font Name=Helv
- Font Size=8
- item: Push Button
- Rectangle=150 187 195 202
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Next >
- Text French=&Suite >
- Text German=&Weiter >
- Text Spanish=&Siguiente >
- Text Italian=&Avanti >
- end
- item: Push Button
- Rectangle=105 187 150 202
- Variable=DIRECTION
- Value=B
- Create Flags=01010000000000010000000000000000
- Text=< &Back
- Text French=< &Retour
- Text German=< &Zurück
- Text Spanish=< &Atrás
- Text Italian=< &Indietro
- end
- item: Push Button
- Rectangle=211 187 256 202
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=&Cancel
- Text French=&Annuler
- Text German=&Abbrechen
- Text Spanish=&Cancelar
- Text Italian=&Annulla
- end
- item: Static
- Rectangle=8 180 256 181
- Action=3
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 8 258 42
- Create Flags=01010000000000000000000000000000
- Flags=0000000000000001
- Name=Times New Roman
- Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
- Text=Ready to Install!
- Text French=Prêt à installer !
- Text German=Installationsbereit!
- Text Spanish=¡Preparado para la instalación!
- Text Italian=Pronto per l'installazione!
- end
- item: Static
- Rectangle=86 42 256 102
- Create Flags=01010000000000000000000000000000
- Text=You are now ready to install %APPTITLE%.
- Text=
- Text=Press the Next button to begin the installation or the Back button to reenter the installation information.
- Text French=Vous êtes maintenant prêt à installer les fichiers %APPTITLE%.
- Text French=
- Text French=Cliquez sur le bouton Suite pour commencer l'installation ou sur le bouton Retour pour entrer les informations d'installation à nouveau.
- Text German=Sie können %APPTITLE% nun installieren.
- Text German=
- Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "Zurück", um die Installationsinformationen neu einzugeben.
- Text Spanish=Ya está listo para instalar %APPTITLE%.
- Text Spanish=
- Text Spanish=Presione el botón Siguiente para comenzar la instalación o presione Atrás para volver a ingresar la información para la instalación.
- Text Italian=Ora è possibile installare %APPTITLE%.
- Text Italian=
- Text Italian=Premere il pulsante Avanti per avviare l'installazione o il pulsante Indietro per reinserire le informazioni di installazione.
- end
- end
-end
-item: If/While Statement
- Variable=DISPLAY
- Value=Select Destination Directory
-end
-item: Set Variable
- Variable=BACKUP
- Value=%MAINDIR%\BACKUP
-end
-item: End Block
-end
-item: End Block
-end
-item: If/While Statement
- Variable=TYPE
- Value=B
-end
-item: Set Variable
- Variable=COMPONENTS
- Value=A
-end
-item: End Block
-end
-item: If/While Statement
- Variable=DOBACKUP
- Value=A
-end
-item: Set Variable
- Variable=BACKUPDIR
- Value=%BACKUP%
-end
-item: End Block
-end
-remarked item: If/While Statement
- Variable=BRANDING
- Value=1
-end
-remarked item: If/While Statement
- Variable=DOBRAND
- Value=1
-end
-remarked item: Edit INI File
- Pathname=%INST%\CUSTDATA.INI
- Settings=[Registration]
- Settings=NAME=%NAME%
- Settings=COMPANY=%COMPANY%
- Settings=
-end
-remarked item: End Block
-end
-remarked item: End Block
-end
-item: Set Variable
- Variable=MAINDIRSHORT
- Value=%MAINDIR%
- Flags=00010100
-end
-item: Open/Close INSTALL.LOG
-end
-item: Check Disk Space
- Component=COMPONENTS
-end
-item: Install File
- Source=${__TCLBASEDIR__}\license.txt
- Destination=%MAINDIR%\license.txt
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\Readme.txt
- Destination=%MAINDIR%\Readme.txt
- Flags=0000000000000010
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=D
- Flags=00001010
-end
-item: Install File
- Source=${__TKBASEDIR__}\win\release\tk83.lib
- Destination=%MAINDIR%\lib\tk83.lib
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\win\release\tkstub83.lib
- Destination=%MAINDIR%\lib\tkstub83.lib
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\release\tcl83.lib
- Destination=%MAINDIR%\lib\tcl83.lib
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\release\tclstub83.lib
- Destination=%MAINDIR%\lib\tclstub83.lib
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\Xutil.h
- Destination=%MAINDIR%\include\X11\Xutil.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\Xlib.h
- Destination=%MAINDIR%\include\X11\Xlib.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\Xfuncproto.h
- Destination=%MAINDIR%\include\X11\Xfuncproto.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\Xatom.h
- Destination=%MAINDIR%\include\X11\Xatom.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\X.h
- Destination=%MAINDIR%\include\X11\X.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\keysymdef.h
- Destination=%MAINDIR%\include\X11\keysymdef.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\keysym.h
- Destination=%MAINDIR%\include\X11\keysym.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\xlib\X11\cursorfont.h
- Destination=%MAINDIR%\include\X11\cursorfont.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\generic\tk.h
- Destination=%MAINDIR%\include\tk.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\generic\tkDecls.h
- Destination=%MAINDIR%\include\tkDecls.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\generic\tkIntXlibDecls.h
- Destination=%MAINDIR%\include\tkIntXlibDecls.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\generic\tcl.h
- Destination=%MAINDIR%\include\tcl.h
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\generic\tclDecls.h
- Destination=%MAINDIR%\include\tclDecls.h
- Flags=0000000000000010
-end
-item: End Block
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=A
- Flags=00001010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\msgcat1.0\pkgIndex.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\msgcat1.0\pkgIndex.tcl
- Flags=0000000010000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\msgcat1.0\msgcat.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\msgcat1.0\msgcat.tcl
- Flags=0000000010000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\tcltest1.0\pkgIndex.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\tcltest1.0\pkgIndex.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\tcltest1.0\tcltest.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\tcltest1.0\tcltest.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\symbol.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\symbol.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\shiftjis.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\shiftjis.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macUkraine.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macUkraine.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macTurkish.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macTurkish.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macThai.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macThai.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macRomania.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macRomania.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macRoman.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macRoman.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macJapan.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macJapan.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macIceland.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macIceland.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macGreek.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macGreek.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macDingbats.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macDingbats.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macCyrillic.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCyrillic.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macCroatian.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCroatian.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\macCentEuro.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCentEuro.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\ksc5601.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\ksc5601.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\koi8-r.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\koi8-r.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\jis0212.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0212.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\jis0208.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0208.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\jis0201.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0201.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-9.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-9.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-8.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-8.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-7.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-7.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-6.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-6.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-5.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-5.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-4.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-4.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-3.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-3.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-2.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-2.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso8859-1.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-1.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso2022.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso2022-kr.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022-kr.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\iso2022-jp.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022-jp.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\gb2312.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb2312.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\gb1988.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb1988.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\gb12345.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb12345.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\euc-cn.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-cn.enc
- Flags=0000000010000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\euc-jp.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-jp.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\euc-kr.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-kr.enc
- Flags=0000000010000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\dingbats.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\dingbats.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp950.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp950.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp949.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp949.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp936.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp936.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp932.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp932.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp874.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp874.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp869.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp869.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp866.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp866.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp865.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp865.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp864.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp864.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp863.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp863.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp862.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp862.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp861.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp861.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp860.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp860.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp857.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp857.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp855.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp855.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp852.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp852.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp850.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp850.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp775.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp775.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp737.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp737.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp437.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp437.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1258.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1258.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1257.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1257.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1256.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1256.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1255.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1255.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1254.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1254.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1253.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1253.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1252.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1252.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1251.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1251.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\cp1250.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1250.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\ascii.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\ascii.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\encoding\big5.enc
- Destination=%MAINDIR%\lib\tcl%VER%\encoding\big5.enc
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\opt0.4\pkgIndex.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\pkgIndex.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\opt0.4\optparse.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\optparse.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\http2.3\pkgIndex.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\http2.3\pkgIndex.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\http2.3\http.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\http2.3\http.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\msgbox.tcl
- Destination=%MAINDIR%\lib\tk%VER%\msgbox.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\optMenu.tcl
- Destination=%MAINDIR%\lib\tk%VER%\optMenu.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\clrpick.tcl
- Destination=%MAINDIR%\lib\tk%VER%\clrpick.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\entry.tcl
- Destination=%MAINDIR%\lib\tk%VER%\entry.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\comdlg.tcl
- Destination=%MAINDIR%\lib\tk%VER%\comdlg.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\bgerror.tcl
- Destination=%MAINDIR%\lib\tk%VER%\bgerror.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\obsolete.tcl
- Destination=%MAINDIR%\lib\tk%VER%\obsolete.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\button.tcl
- Destination=%MAINDIR%\lib\tk%VER%\button.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\xmfbox.tcl
- Destination=%MAINDIR%\lib\tk%VER%\xmfbox.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\console.tcl
- Destination=%MAINDIR%\lib\tk%VER%\console.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\listbox.tcl
- Destination=%MAINDIR%\lib\tk%VER%\listbox.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\menu.tcl
- Destination=%MAINDIR%\lib\tk%VER%\menu.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\dialog.tcl
- Destination=%MAINDIR%\lib\tk%VER%\dialog.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\focus.tcl
- Destination=%MAINDIR%\lib\tk%VER%\focus.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\palette.tcl
- Destination=%MAINDIR%\lib\tk%VER%\palette.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\tkfbox.tcl
- Destination=%MAINDIR%\lib\tk%VER%\tkfbox.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\tk.tcl
- Destination=%MAINDIR%\lib\tk%VER%\tk.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\text.tcl
- Destination=%MAINDIR%\lib\tk%VER%\text.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\tearoff.tcl
- Destination=%MAINDIR%\lib\tk%VER%\tearoff.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\tclIndex
- Destination=%MAINDIR%\lib\tk%VER%\tclIndex
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\scrlbar.tcl
- Destination=%MAINDIR%\lib\tk%VER%\scrlbar.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\scale.tcl
- Destination=%MAINDIR%\lib\tk%VER%\scale.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\safetk.tcl
- Destination=%MAINDIR%\lib\tk%VER%\safetk.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\http1.0\pkgIndex.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\http1.0\pkgIndex.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\http1.0\http.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\http1.0\http.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\reg1.0\pkgIndex.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\pkgIndex.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\release\tclreg83.dll
- Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\tclreg83.dll
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\dde1.1\pkgIndex.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\dde1.1\pkgIndex.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\release\tcldde83.dll
- Destination=%MAINDIR%\lib\tcl%VER%\dde1.1\tcldde83.dll
- Flags=0000000000000010
-end
-item: Install File
- Source=C:\WINNT\SYSTEM32\Msvcrt.dll
- Destination=%MAINDIR%\bin\msvcrt.dll
- Flags=0010001000000011
-end
-item: Install File
- Source=${__TKBASEDIR__}\win\release\wish83.exe
- Destination=%MAINDIR%\bin\wish83.exe
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\release\tclsh83.exe
- Destination=%MAINDIR%\bin\tclsh83.exe
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\release\tclpip83.dll
- Destination=%MAINDIR%\bin\tclpip83.dll
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\win\release\tcl83.dll
- Destination=%MAINDIR%\bin\tcl83.dll
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\win\release\tk83.dll
- Destination=%MAINDIR%\bin\tk83.dll
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\auto.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\auto.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\history.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\history.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\init.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\init.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\package.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\package.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\parray.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\parray.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\safe.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\safe.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\tclIndex
- Destination=%MAINDIR%\lib\tcl%VER%\tclIndex
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\library\word.tcl
- Destination=%MAINDIR%\lib\tcl%VER%\word.tcl
- Flags=0000000000000010
-end
-item: End Block
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=B
- Flags=00001010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\tai-ku.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\tai-ku.gif
- Flags=0000000010000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\teapot.ppm
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\teapot.ppm
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\tcllogo.gif
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\tcllogo.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\pattern.bmp
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\pattern.bmp
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\noletter.bmp
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\noletter.bmp
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\letters.bmp
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\letters.bmp
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\gray25.bmp
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\gray25.bmp
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\flagup.bmp
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\flagup.bmp
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\flagdown.bmp
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\flagdown.bmp
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\face.bmp
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\face.bmp
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\earthris.gif
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\earthris.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\images\earth.gif
- Destination=%MAINDIR%\lib\tk%VER%\demos\images\earth.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\vscale.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\vscale.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\twind.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\twind.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\text.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\text.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\style.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\style.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\states.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\states.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\search.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\search.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\sayings.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\sayings.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\ruler.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\ruler.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\radio.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\radio.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\puzzle.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\puzzle.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\plot.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\plot.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\msgbox.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\msgbox.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\menubu.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\menubu.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\menu.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\menu.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\label.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\label.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\items.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\items.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\image2.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\image2.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\image1.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\image1.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\icon.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\icon.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\hscale.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\hscale.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\form.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\form.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\ixset
- Destination=%MAINDIR%\lib\tk%VER%\demos\ixset.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\rolodex
- Destination=%MAINDIR%\lib\tk%VER%\demos\rolodex.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\square
- Destination=%MAINDIR%\lib\tk%VER%\demos\square.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\Readme
- Destination=%MAINDIR%\lib\tk%VER%\demos\Readme
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\hello
- Destination=%MAINDIR%\lib\tk%VER%\demos\hello.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\tclIndex
- Destination=%MAINDIR%\lib\tk%VER%\demos\tclIndex
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\browse
- Destination=%MAINDIR%\lib\tk%VER%\demos\browse.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\timer
- Destination=%MAINDIR%\lib\tk%VER%\demos\timer.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\widget
- Destination=%MAINDIR%\lib\tk%VER%\demos\widget.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\tcolor
- Destination=%MAINDIR%\lib\tk%VER%\demos\tcolor.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\rmt
- Destination=%MAINDIR%\lib\tk%VER%\demos\rmt.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\floor.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\floor.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\filebox.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\filebox.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\pwrdLogo75.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo75.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\pwrdLogo200.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo200.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\pwrdLogo175.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo175.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\pwrdLogo150.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo150.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\pwrdLogo100.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo100.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\logoMed.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\logoMed.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\logoLarge.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\logoLarge.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\logo64.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\logo64.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\logo100.gif
- Destination=%MAINDIR%\lib\tk%VER%\images\logo100.gif
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\images\Readme
- Destination=%MAINDIR%\lib\tk%VER%\images\Readme
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\arrow.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\arrow.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\bind.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\bind.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\bitmap.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\bitmap.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\button.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\button.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\check.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\check.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\clrpick.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\clrpick.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\colors.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\colors.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\cscroll.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\cscroll.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\ctext.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\ctext.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\dialog1.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\dialog1.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\dialog2.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\dialog2.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\entry1.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\entry1.tcl
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TKBASEDIR__}\library\demos\entry2.tcl
- Destination=%MAINDIR%\lib\tk%VER%\demos\entry2.tcl
- Flags=0000000000000010
-end
-item: End Block
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=C
- Flags=00001010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\tools\tcl83.cnt
- Destination=%MAINDIR%\doc\tcl83.cnt
- Flags=0000000000000010
-end
-item: Install File
- Source=${__TCLBASEDIR__}\tools\tcl83.hlp
- Destination=%MAINDIR%\doc\tcl83.hlp
- Flags=0000000000000010
-end
-item: End Block
-end
-item: Set Variable
- Variable=MAINDIR
- Value=%MAINDIR%
- Flags=00010100
-end
-item: Include Script
- Pathname=\\pop\tools\1.2\win32-ix86\wise\INCLUDE\uninstal.wse
-end
-item: Check Configuration
- Flags=10111011
-end
-item: Get Registry Key Value
- Variable=GROUPDIR
- Key=Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders
- Default=%WIN%\Start Menu\Programs
- Value Name=Programs
- Flags=00000010
-end
-item: Set Variable
- Variable=GROUP
- Value=%GROUPDIR%\%GROUP%
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=A
- Flags=00001010
-end
-item: Create Shortcut
- Source=%MAINDIR%\bin\wish83.exe
- Destination=%GROUP%\Wish.lnk
- Working Directory=%MAINDIR%
-end
-item: End Block
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=A
- Flags=00001010
-end
-item: Create Shortcut
- Source=%MAINDIR%\bin\tclsh83.exe
- Destination=%GROUP%\Tclsh.lnk
- Working Directory=%MAINDIR%
- Key Type=1536
- Flags=00000001
-end
-item: End Block
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=C
- Flags=00001010
-end
-item: Create Shortcut
- Source=%MAINDIR%\doc\tcl83.hlp
- Destination=%GROUP%\Tcl Help.lnk
- Working Directory=%MAINDIR%
-end
-item: End Block
-end
-item: Create Shortcut
- Source=%MAINDIR%\Readme.txt
- Destination=%GROUP%\Readme.lnk
- Working Directory=%MAINDIR%
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=B
- Flags=00001010
-end
-item: Create Shortcut
- Source=%MAINDIR%\lib\tk%VER%\demos\widget.tcl
- Destination=%GROUP%\Widget Tour.lnk
- Working Directory=%MAINDIR%
- Key Type=1536
- Flags=00000001
-end
-item: End Block
-end
-item: Else Statement
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=B
- Flags=00001010
-end
-item: Add ProgMan Icon
- Group=%GROUP%
- Icon Name=Widget Tour
- Command Line=%MAINDIR%\lib\tk%VER%\demos\widget.tcl
- Icon Pathname=%MAINDIR%\bin\wish83.exe
- Default Directory=%MAINDIR%
-end
-item: End Block
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=C
- Flags=00001010
-end
-item: Add ProgMan Icon
- Group=%GROUP%
- Icon Name=Tcl Help
- Command Line=%MAINDIR%\doc\tcl83.hlp
- Default Directory=%MAINDIR%
-end
-item: End Block
-end
-item: Add ProgMan Icon
- Group=%GROUP%
- Icon Name=Readme
- Command Line=%MAINDIR%\Readme.txt
- Default Directory=%MAINDIR%
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=A
- Flags=00001010
-end
-item: Add ProgMan Icon
- Group=%GROUP%
- Icon Name=Wish
- Command Line=%MAINDIR%\bin\wish83.exe
- Default Directory=%MAINDIR%
-end
-item: End Block
-end
-item: If/While Statement
- Variable=COMPONENTS
- Value=A
- Flags=00001010
-end
-item: Add ProgMan Icon
- Group=%GROUP%
- Icon Name=Tclsh
- Command Line=%MAINDIR%\bin\tclsh83.exe
- Default Directory=%MAINDIR%
-end
-item: End Block
-end
-item: End Block
-end
-item: Self-Register OCXs/DLLs
- Description=Updating System Configuration, Please Wait...
-end
-item: Edit Registry
- Total Keys=1
- Key=SOFTWARE\Scriptics\Tcl\%VER%
- New Value=%MAINDIR%
- Value Name=Root
- Root=2
-end
-item: Edit Registry
- Total Keys=1
- Key=TclScript\DefaultIcon
- New Value=%MAINDIR%\bin\tk83.dll
-end
-item: Edit Registry
- Total Keys=1
- Key=.tcl
- New Value=TclScript
-end
-item: Edit Registry
- Total Keys=1
- Key=TclScript
- New Value=TclScript
-end
-item: Edit Registry
- Total Keys=1
- Key=TclScript\shell\open\command
- New Value=%MAINDIRSHORT%\bin\wish83.exe "%%1" %%*
-end
-item: Edit Registry
- Total Keys=1
- Key=TclScript\shell\edit
- New Value=&Edit
-end
-item: Edit Registry
- Total Keys=1
- Key=TclScript\shell\edit\command
- New Value=notepad "%%1"
-end
-item: Add Directory to Path
- Directory=%MAINDIR%\bin
-end
-item: Check Configuration
- Flags=10111011
-end
-item: Set Variable
- Variable=TO_SCRIPTICS
- Value=A
-end
-item: Else Statement
-end
-item: Set Variable
- Variable=TO_SCRIPTICS
-end
-item: End Block
-end
-item: Wizard Block
- Direction Variable=DIRECTION
- Display Variable=DISPLAY
- Bitmap Pathname=%_WISE_%\DIALOGS\TEMPLATE\WIZARD.BMP
- X Position=9
- Y Position=10
- Filler Color=8421440
- Flags=00000011
-end
-item: Custom Dialog Set
- Name=Finished
- Display Variable=DISPLAY
- item: Dialog
- Title=%APPTITLE% Installation
- Title French=Installation de %APPTITLE%
- Title German=Installation von %APPTITLE%
- Title Spanish=Instalación de %APPTITLE%
- Title Italian=Installazione di %APPTITLE%
- Width=271
- Height=224
- Font Name=Helv
- Font Size=8
- item: Push Button
- Rectangle=150 187 195 202
- Variable=DIRECTION
- Value=N
- Create Flags=01010000000000010000000000000001
- Text=&Finish
- Text French=&Fin
- Text German=&Weiter
- Text Spanish=&Terminar
- Text Italian=&Fine
- end
- item: Push Button
- Rectangle=105 187 150 202
- Variable=DISABLED
- Value=!
- Create Flags=01010000000000010000000000000000
- Text=< &Back
- Text French=< &Retour
- Text German=< &Zurück
- Text Spanish=< &Atrás
- Text Italian=< &Indietro
- end
- item: Push Button
- Rectangle=211 187 256 202
- Variable=DISABLED
- Value=!
- Action=3
- Create Flags=01010000000000010000000000000000
- Text=&Cancel
- Text French=&Annuler
- Text German=&Abbrechen
- Text Spanish=&Cancelar
- Text Italian=&Annulla
- end
- item: Static
- Rectangle=8 180 256 181
- Action=3
- Create Flags=01010000000000000000000000000111
- end
- item: Static
- Rectangle=86 8 258 42
- Create Flags=01010000000000000000000000000000
- Flags=0000000000000001
- Name=Times New Roman
- Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18
- Text=Installation Completed!
- Text French=Installation terminée !
- Text German=Die Installation ist abgeschlossen!
- Text Spanish=¡Instalación terminada!
- Text Italian=Installazione completata!
- end
- item: Static
- Rectangle=86 42 256 153
- Create Flags=01010000000000000000000000000000
- Text=%APPTITLE% has been successfully installed.
- Text=
- Text=Click the Finish button to exit this installation.
- Text=
- Text=You can learn more about Tcl/Tk %VER%, including release notes, updates, tutorials, and more at %URL%. Check the box below to start your web browser and go there now.
- Text=
- Text=The installer may ask you to reboot your computer, this is to update your PATH and is not necessary to do immediately.
- Text French=%APPTITLE% est maintenant installé.
- Text French=
- Text French=Cliquez sur le bouton Fin pour quitter l'installation.
- Text German=%APPTITLE% wurde erfolgreich installiert.
- Text German=
- Text German=Klicken Sie auf "Weiter", um die Installation zu beenden.
- Text Spanish=%APPTITLE% se ha instalado con éxito.
- Text Spanish=
- Text Spanish=Presione el botón Terminar para salir de esta instalación.
- Text Italian=L'installazione %APPTITLE% è stata portata a termine con successo.
- Text Italian=
- Text Italian=Premere il pulsante Fine per uscire dall'installazione.
- end
- item: Checkbox
- Rectangle=88 143 245 157
- Variable=TO_SCRIPTICS
- Enabled Color=00000000000000001111111111111111
- Create Flags=01010000000000010000000000000011
- Text=Show me important information about
- Text=
- end
- item: Static
- Rectangle=99 156 245 170
- Enabled Color=00000000000000001111111111111111
- Create Flags=01010000000000000000000000000000
- Text=Tcl/Tk %VER% and TclPro
- end
- end
-end
-item: End Block
-end
-item: Check Configuration
- Flags=10111011
-end
-item: If/While Statement
- Variable=TO_SCRIPTICS
- Value=A
- Flags=00000010
-end
-item: Execute Program
- Command Line=%URL%
-end
-item: End Block
-end
-item: Execute Program
- Pathname=explorer
- Command Line=%GROUP%
-end
-item: End Block
-end
+Document Type: WSE\r
+item: Global\r
+ Version=6.01\r
+ Title=Tcl 8.4 for Windows Installation\r
+ Flags=00010100\r
+ Languages=65 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0\r
+ Japanese Font Name=MS Gothic\r
+ Japanese Font Size=10\r
+ Start Gradient=0 0 255\r
+ End Gradient=0 0 0\r
+ Windows Flags=00000000000000010010110000001000\r
+ Log Pathname=%MAINDIR%\INSTALL.LOG\r
+ Message Font=MS Sans Serif\r
+ Font Size=8\r
+ Disk Label=tcl8.4.1\r
+ Disk Filename=setup\r
+ Patch Flags=0000000000000001\r
+ Patch Threshold=85\r
+ Patch Memory=4000\r
+ Variable Name1=_SYS_\r
+ Variable Default1=C:\WINDOWS\SYSTEM\r
+ Variable Flags1=00001000\r
+ Variable Name2=_ODBC16_\r
+ Variable Default2=C:\WINDOWS\SYSTEM\r
+ Variable Flags2=00001000\r
+ Variable Name3=_WISE_\r
+ Variable Default3=${__WISE__}\r
+ Variable Flags3=00001000\r
+end\r
+item: Open/Close INSTALL.LOG\r
+ Flags=00000001\r
+end\r
+item: Check if File/Dir Exists\r
+ Pathname=%SYS%\r
+ Flags=10000100\r
+end\r
+item: Set Variable\r
+ Variable=SYS\r
+ Value=%WIN%\r
+end\r
+item: End Block\r
+end\r
+item: Set Variable\r
+ Variable=VER\r
+ Value=8.4\r
+end\r
+item: Set Variable\r
+ Variable=PATCHLEVEL\r
+ Value=${__TCL_PATCH_LEVEL__}\r
+end\r
+item: Set Variable\r
+ Variable=APPTITLE\r
+ Value=Tcl/Tk %PATCHLEVEL% for Windows\r
+end\r
+item: Set Variable\r
+ Variable=URL\r
+ Value=http://www.tcl.tk/\r
+end\r
+item: Set Variable\r
+ Variable=GROUP\r
+ Value=Tcl\r
+end\r
+item: Set Variable\r
+ Variable=DISABLED\r
+ Value=!\r
+end\r
+item: Set Variable\r
+ Variable=MAINDIR\r
+ Value=Tcl\r
+end\r
+item: Check Configuration\r
+ Flags=10111011\r
+end\r
+item: Get Registry Key Value\r
+ Variable=PROGRAM_FILES\r
+ Key=SOFTWARE\Microsoft\Windows\CurrentVersion\r
+ Default=C:\Program Files\r
+ Value Name=ProgramFilesDir\r
+ Flags=00000100\r
+end\r
+item: Set Variable\r
+ Variable=MAINDIR\r
+ Value=%PROGRAM_FILES%\%MAINDIR%\r
+end\r
+item: Set Variable\r
+ Variable=EXPLORER\r
+ Value=1\r
+end\r
+item: Else Statement\r
+end\r
+item: Set Variable\r
+ Variable=MAINDIR\r
+ Value=C:\%MAINDIR%\r
+end\r
+item: End Block\r
+end\r
+item: Set Variable\r
+ Variable=BACKUP\r
+ Value=%MAINDIR%\BACKUP\r
+end\r
+item: Set Variable\r
+ Variable=DOBACKUP\r
+ Value=B\r
+end\r
+item: Set Variable\r
+ Variable=BRANDING\r
+ Value=0\r
+end\r
+remarked item: If/While Statement\r
+ Variable=BRANDING\r
+ Value=1\r
+end\r
+remarked item: Read INI Value\r
+ Variable=NAME\r
+ Pathname=%INST%\CUSTDATA.INI\r
+ Section=Registration\r
+ Item=Name\r
+end\r
+remarked item: Read INI Value\r
+ Variable=COMPANY\r
+ Pathname=%INST%\CUSTDATA.INI\r
+ Section=Registration\r
+ Item=Company\r
+end\r
+remarked item: If/While Statement\r
+ Variable=NAME\r
+end\r
+remarked item: Set Variable\r
+ Variable=DOBRAND\r
+ Value=1\r
+end\r
+remarked item: End Block\r
+end\r
+remarked item: End Block\r
+end\r
+item: Set Variable\r
+ Variable=TYPE\r
+ Value=C\r
+end\r
+item: Set Variable\r
+ Variable=COMPONENTS\r
+ Value=ABC\r
+end\r
+item: Wizard Block\r
+ Direction Variable=DIRECTION\r
+ Display Variable=DISPLAY\r
+ X Position=0\r
+ Y Position=0\r
+ Filler Color=8421440\r
+ Flags=00000001\r
+end\r
+item: Custom Dialog Set\r
+ Name=Splash\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Bienvenue\r
+ Title German=Willkommen\r
+ Title Portuguese=Bem-vindo \r
+ Title Spanish=Bienvenido\r
+ Title Italian=Benvenuto\r
+ Title Danish=Velkommen\r
+ Title Dutch=Welkom\r
+ Title Norwegian=Velkommen\r
+ Title Swedish=Välkommen\r
+ Width=273\r
+ Height=250\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Push Button\r
+ Rectangle=166 214 208 228\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Next >\r
+ end\r
+ item: Push Button\r
+ Rectangle=212 214 254 228\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=Cancel\r
+ end\r
+ item: Static\r
+ Rectangle=0 0 268 233\r
+ Action=2\r
+ Enabled Color=00000000000000001111111111111111\r
+ Create Flags=01010000000000000000000000001011\r
+ Pathname=${__TCLBASEDIR__}\tools\white.bmp\r
+ end\r
+ item: Static\r
+ Rectangle=5 5 268 215\r
+ Destination Dialog=1\r
+ Action=2\r
+ Enabled Color=00000000000000001111111111111111\r
+ Create Flags=01010000000000000000000000001011\r
+ Pathname=${__TCLBASEDIR__}\tools\tclSplash.bmp\r
+ end\r
+ end\r
+end\r
+item: End Block\r
+end\r
+item: Wizard Block\r
+ Direction Variable=DIRECTION\r
+ Display Variable=DISPLAY\r
+ Bitmap Pathname=%_WISE_%\DIALOGS\TEMPLATE\WIZARD.BMP\r
+ X Position=9\r
+ Y Position=10\r
+ Filler Color=8421440\r
+ Dialog=Welcome\r
+ Dialog=Select Destination Directory\r
+ Dialog=Select Installation Type\r
+ Dialog=Select Components\r
+ Dialog=Select Program Manager Group\r
+ Variable=\r
+ Variable=\r
+ Variable=\r
+ Variable=TYPE\r
+ Variable=EXPLORER\r
+ Value=\r
+ Value=\r
+ Value=\r
+ Value=C\r
+ Value=1\r
+ Compare=0\r
+ Compare=0\r
+ Compare=0\r
+ Compare=1\r
+ Compare=0\r
+ Flags=00000011\r
+end\r
+item: Custom Dialog Set\r
+ Name=Welcome\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Installation de %APPTITLE%\r
+ Title German=Installation von %APPTITLE%\r
+ Title Spanish=Instalación de %APPTITLE%\r
+ Title Italian=Installazione di %APPTITLE%\r
+ Width=271\r
+ Height=224\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Static\r
+ Rectangle=86 8 258 42\r
+ Create Flags=01010000000000000000000000000000\r
+ Flags=0000000000000001\r
+ Name=Times New Roman\r
+ Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18\r
+ Text=Welcome!\r
+ Text French=Bienvenue !\r
+ Text German=Willkommen!\r
+ Text Spanish=¡Bienvenido!\r
+ Text Italian=Benvenuti!\r
+ end\r
+ item: Push Button\r
+ Rectangle=150 187 195 202\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Next >\r
+ Text French=&Suite >\r
+ Text German=&Weiter >\r
+ Text Spanish=&Siguiente >\r
+ Text Italian=&Avanti >\r
+ end\r
+ item: Push Button\r
+ Rectangle=105 187 150 202\r
+ Variable=DISABLED\r
+ Value=!\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=< &Back\r
+ Text French=< &Retour\r
+ Text German=< &Zurück\r
+ Text Spanish=< &Atrás\r
+ Text Italian=< &Indietro\r
+ end\r
+ item: Push Button\r
+ Rectangle=211 187 256 202\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=&Cancel\r
+ Text French=&Annuler\r
+ Text German=&Abbrechen\r
+ Text Spanish=&Cancelar\r
+ Text Italian=&Annulla\r
+ end\r
+ item: Static\r
+ Rectangle=85 41 255 130\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=This installation program will install %APPTITLE%.\r
+ Text=\r
+ Text=Press the Next button to start the installation. You can press the Exit Setup button now if you do not want to install %APPTITLE% at this time. \r
+ Text=\r
+ Text=It is strongly recommended that you exit all Windows programs before running this installation program.\r
+ Text French=Ce programme d'installation va installer %APPTITLE%.\r
+ Text French=\r
+ Text French=Cliquez sur le bouton Suite pour démarrer l'installation. Vous pouvez cliquer sur le bouton Quitter l'installation si vous ne voulez pas installer %APPTITLE% tout de suite.\r
+ Text German=Mit diesem Installationsprogramm wird %APPTITLE% installiert.\r
+ Text German=\r
+ Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "Abbrechen", um die Installation von %APPTITLE% abzubrechen.\r
+ Text Spanish=Este programa de instalación instalará %APPTITLE%.\r
+ Text Spanish=\r
+ Text Spanish=Presione el botón Siguiente para iniciar la instalación. Puede presionar el botón Salir de instalación si no desea instalar %APPTITLE% en este momento.\r
+ Text Italian=Questo programma installerà %APPTITLE%.\r
+ Text Italian=\r
+ Text Italian=Per avvviare l'installazione premere il pulsante Avanti. Se non si desidera installare %APPTITLE% ora, premere il pulsante Esci dall'installazione.\r
+ end\r
+ item: Static\r
+ Rectangle=8 180 256 181\r
+ Action=3\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ end\r
+end\r
+item: Custom Dialog Set\r
+ Name=Select Destination Directory\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Installation de %APPTITLE%\r
+ Title German=Installation von %APPTITLE%\r
+ Title Spanish=Instalación de %APPTITLE%\r
+ Title Italian=Installazione di %APPTITLE%\r
+ Width=271\r
+ Height=224\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Push Button\r
+ Rectangle=150 187 195 202\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Next >\r
+ Text French=&Suite >\r
+ Text German=&Weiter >\r
+ Text Spanish=&Siguiente >\r
+ Text Italian=&Avanti >\r
+ end\r
+ item: Push Button\r
+ Rectangle=105 187 150 202\r
+ Variable=DIRECTION\r
+ Value=B\r
+ Create Flags=01010000000000010000000000000000\r
+ Flags=0000000000000001\r
+ Text=< &Back\r
+ Text French=< &Retour\r
+ Text German=< &Zurück\r
+ Text Spanish=< &Atrás\r
+ Text Italian=< &Indietro\r
+ end\r
+ item: Push Button\r
+ Rectangle=211 187 256 202\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=&Cancel\r
+ Text French=&Annuler\r
+ Text German=&Abbrechen\r
+ Text Spanish=&Cancelar\r
+ Text Italian=&Annulla\r
+ end\r
+ item: Static\r
+ Rectangle=8 180 256 181\r
+ Action=3\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 8 258 42\r
+ Create Flags=01010000000000000000000000000000\r
+ Flags=0000000000000001\r
+ Name=Times New Roman\r
+ Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18\r
+ Text=Select Destination Directory\r
+ Text French=Sélectionner le répertoire de destination\r
+ Text German=Zielverzeichnis wählen\r
+ Text Spanish=Seleccione el directorio de destino\r
+ Text Italian=Selezionare Directory di destinazione\r
+ end\r
+ item: Static\r
+ Rectangle=86 39 256 114\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Please select the directory where the %APPTITLE% files are to be installed.\r
+ Text=\r
+ Text=To install in the default directory below, click Next.\r
+ Text=\r
+ Text=To install in a different directory, click Browse and select another directory.\r
+ Text French=Veuillez sélectionner le répertoire dans lequel les fichiers %APPTITLE% doivent être installés.\r
+ Text German=Geben Sie an, in welchem Verzeichnis die %APPTITLE%-Dateien installiert werden sollen.\r
+ Text Spanish=Por favor seleccione el directorio donde desee instalar los archivos de %APPTITLE%.\r
+ Text Italian=Selezionare la directory dove verranno installati i file %APPTITLE%.\r
+ end\r
+ item: Static\r
+ Rectangle=86 130 256 157\r
+ Action=1\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Push Button\r
+ Rectangle=205 138 250 153\r
+ Variable=MAINDIR_SAVE\r
+ Value=%MAINDIR%\r
+ Destination Dialog=1\r
+ Action=2\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=Browse\r
+ Text French=Parcourir\r
+ Text German=Durchsuchen\r
+ Text Spanish=Buscar\r
+ Text Italian=Sfoglie\r
+ end\r
+ item: Static\r
+ Rectangle=91 140 198 151\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=%MAINDIR%\r
+ Text French=%MAINDIR%\r
+ Text German=%MAINDIR%\r
+ Text Spanish=%MAINDIR%\r
+ Text Italian=%MAINDIR%\r
+ end\r
+ end\r
+ item: Dialog\r
+ Title=Select Destination Directory\r
+ Title French=Sélectionner le répertoire de destination\r
+ Title German=Zielverzeichnis wählen\r
+ Title Spanish=Seleccione el directorio de destino\r
+ Title Italian=Selezionare Directory di destinazione\r
+ Width=221\r
+ Height=173\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Listbox\r
+ Rectangle=5 5 163 149\r
+ Variable=MAINDIR\r
+ Create Flags=01010000100000010000000101000000\r
+ Flags=0000110000100010\r
+ Text=%MAINDIR%\r
+ Text French=%MAINDIR%\r
+ Text German=%MAINDIR%\r
+ Text Spanish=%MAINDIR%\r
+ Text Italian=%MAINDIR%\r
+ end\r
+ item: Push Button\r
+ Rectangle=167 6 212 21\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=OK\r
+ Text French=OK\r
+ Text German=OK\r
+ Text Spanish=Aceptar\r
+ Text Italian=OK\r
+ end\r
+ item: Push Button\r
+ Rectangle=167 25 212 40\r
+ Variable=MAINDIR\r
+ Value=%MAINDIR_SAVE%\r
+ Create Flags=01010000000000010000000000000000\r
+ Flags=0000000000000001\r
+ Text=Cancel\r
+ Text French=Annuler\r
+ Text German=Abbrechen\r
+ Text Spanish=Cancelar\r
+ Text Italian=Annulla\r
+ end\r
+ end\r
+end\r
+remarked item: Custom Dialog Set\r
+ Name=Select Installation Type\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Installation de %APPTITLE%\r
+ Title German=Installation von %APPTITLE%\r
+ Title Spanish=Instalación de %APPTITLE%\r
+ Title Italian=Installazione di %APPTITLE%\r
+ Width=271\r
+ Height=224\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Push Button\r
+ Rectangle=150 187 195 202\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Next >\r
+ Text French=&Suite >\r
+ Text German=&Weiter >\r
+ Text Spanish=&Siguiente >\r
+ Text Italian=&Avanti >\r
+ end\r
+ item: Push Button\r
+ Rectangle=105 187 150 202\r
+ Variable=DIRECTION\r
+ Value=B\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=< &Back\r
+ Text French=< &Retour\r
+ Text German=< &Zurück\r
+ Text Spanish=< &Atrás\r
+ Text Italian=< &Indietro\r
+ end\r
+ item: Push Button\r
+ Rectangle=211 187 256 202\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=&Cancel\r
+ Text French=&Annuler\r
+ Text German=&Abbrechen\r
+ Text Spanish=&Cancelar\r
+ Text Italian=&Annulla\r
+ end\r
+ item: Static\r
+ Rectangle=8 180 256 181\r
+ Action=3\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 8 258 42\r
+ Create Flags=01010000000000000000000000000000\r
+ Flags=0000000000000001\r
+ Name=Times New Roman\r
+ Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18\r
+ Text=Select Installation Type\r
+ Text French=Sélectionner les composants\r
+ Text German=Komponenten auswählen\r
+ Text Spanish=Seleccione componentes\r
+ Text Italian=Selezionare i componenti\r
+ end\r
+ item: Static\r
+ Rectangle=194 162 242 172\r
+ Variable=COMPONENTS\r
+ Value=MAINDIR\r
+ Create Flags=01010000000000000000000000000010\r
+ end\r
+ item: Static\r
+ Rectangle=194 153 242 162\r
+ Variable=COMPONENTS\r
+ Create Flags=01010000000000000000000000000010\r
+ end\r
+ item: Static\r
+ Rectangle=107 153 196 164\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Disk Space Required:\r
+ Text French=Espace disque requis :\r
+ Text German=Notwendiger Speicherplatz:\r
+ Text Spanish=Espacio requerido en el disco:\r
+ Text Italian=Spazio su disco necessario:\r
+ end\r
+ item: Static\r
+ Rectangle=107 162 196 172\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Disk Space Remaining:\r
+ Text French=Espace disque disponible :\r
+ Text German=Verbleibender Speicherplatz:\r
+ Text Spanish=Espacio en disco disponible:\r
+ Text Italian=Spazio su disco disponibile:\r
+ end\r
+ item: Static\r
+ Rectangle=86 145 256 175\r
+ Action=1\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 42 256 61\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Choose which type of installation to perform by selecting one of the buttons below.\r
+ Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.\r
+ Text German=Wählen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden Kästchen klicken.\r
+ Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.\r
+ Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.\r
+ end\r
+ item: Radio Button\r
+ Rectangle=86 74 256 128\r
+ Variable=TYPE\r
+ Create Flags=01010000000000010000000000001001\r
+ Text=&Full Installation (Recommended)\r
+ Text=&Minimal Installation\r
+ Text=C&ustom Installation\r
+ Text=\r
+ end\r
+ end\r
+end\r
+item: Custom Dialog Set\r
+ Name=Select Components\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Installation de %APPTITLE%\r
+ Title German=Installation von %APPTITLE%\r
+ Title Spanish=Instalación de %APPTITLE%\r
+ Title Italian=Installazione di %APPTITLE%\r
+ Width=271\r
+ Height=224\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Push Button\r
+ Rectangle=150 187 195 202\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Next >\r
+ Text French=&Suite >\r
+ Text German=&Weiter >\r
+ Text Spanish=&Siguiente >\r
+ Text Italian=&Avanti >\r
+ end\r
+ item: Push Button\r
+ Rectangle=105 187 150 202\r
+ Variable=DIRECTION\r
+ Value=B\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=< &Back\r
+ Text French=< &Retour\r
+ Text German=< &Zurück\r
+ Text Spanish=< &Atrás\r
+ Text Italian=< &Indietro\r
+ end\r
+ item: Push Button\r
+ Rectangle=211 187 256 202\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=&Cancel\r
+ Text French=&Annuler\r
+ Text German=&Abbrechen\r
+ Text Spanish=&Cancelar\r
+ Text Italian=&Annulla\r
+ end\r
+ item: Static\r
+ Rectangle=8 180 256 181\r
+ Action=3\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 8 258 42\r
+ Create Flags=01010000000000000000000000000000\r
+ Flags=0000000000000001\r
+ Name=Times New Roman\r
+ Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18\r
+ Text=Select Components\r
+ Text French=Sélectionner les composants\r
+ Text German=Komponenten auswählen\r
+ Text Spanish=Seleccione componentes\r
+ Text Italian=Selezionare i componenti\r
+ end\r
+ item: Checkbox\r
+ Rectangle=86 75 256 129\r
+ Variable=COMPONENTS\r
+ Create Flags=01010000000000010000000000000011\r
+ Flags=0000000000000110\r
+ Text=Tcl Run-Time Files\r
+ Text=Example Scripts\r
+ Text=Help Files\r
+ Text=Header and Library Files\r
+ Text=\r
+ Text French=Tcl Run-Time Files\r
+ Text French=Example Scripts\r
+ Text French=Help Files\r
+ Text French=Header and Library Files\r
+ Text French=\r
+ Text German=Tcl Run-Time Files\r
+ Text German=Example Scripts\r
+ Text German=Help Files\r
+ Text German=Header and Library Files\r
+ Text German=\r
+ Text Spanish=Tcl Run-Time Files\r
+ Text Spanish=Example Scripts\r
+ Text Spanish=Help Files\r
+ Text Spanish=Header and Library Files\r
+ Text Spanish=\r
+ Text Italian=Tcl Run-Time Files\r
+ Text Italian=Example Scripts\r
+ Text Italian=Help Files\r
+ Text Italian=Header and Library Files\r
+ Text Italian=\r
+ end\r
+ item: Static\r
+ Rectangle=194 162 242 172\r
+ Variable=COMPONENTS\r
+ Value=MAINDIR\r
+ Create Flags=01010000000000000000000000000010\r
+ end\r
+ item: Static\r
+ Rectangle=194 153 242 162\r
+ Variable=COMPONENTS\r
+ Create Flags=01010000000000000000000000000010\r
+ end\r
+ item: Static\r
+ Rectangle=107 153 196 164\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Disk Space Required:\r
+ Text French=Espace disque requis :\r
+ Text German=Notwendiger Speicherplatz:\r
+ Text Spanish=Espacio requerido en el disco:\r
+ Text Italian=Spazio su disco necessario:\r
+ end\r
+ item: Static\r
+ Rectangle=107 162 196 172\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Disk Space Remaining:\r
+ Text French=Espace disque disponible :\r
+ Text German=Verbleibender Speicherplatz:\r
+ Text Spanish=Espacio en disco disponible:\r
+ Text Italian=Spazio su disco disponibile:\r
+ end\r
+ item: Static\r
+ Rectangle=86 145 256 175\r
+ Action=1\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 42 256 61\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Choose which components to install by checking the boxes below.\r
+ Text French=Choisissez les composants que vous voulez installer en cochant les cases ci-dessous.\r
+ Text German=Wählen Sie die zu installierenden Komponenten, indem Sie in die entsprechenden Kästchen klicken.\r
+ Text Spanish=Elija los componentes que desee instalar marcando los cuadros de abajo.\r
+ Text Italian=Scegliere quali componenti installare selezionando le caselle sottostanti.\r
+ end\r
+ end\r
+end\r
+item: Custom Dialog Set\r
+ Name=Select Program Manager Group\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Installation de %APPTITLE%\r
+ Title German=Installation von %APPTITLE%\r
+ Title Spanish=Instalación de %APPTITLE%\r
+ Title Italian=Installazione di %APPTITLE%\r
+ Width=271\r
+ Height=224\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Push Button\r
+ Rectangle=150 187 195 202\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Next >\r
+ Text French=&Suite >\r
+ Text German=&Weiter >\r
+ Text Spanish=&Siguiente >\r
+ Text Italian=&Avanti >\r
+ end\r
+ item: Push Button\r
+ Rectangle=105 187 150 202\r
+ Variable=DIRECTION\r
+ Value=B\r
+ Create Flags=01010000000000010000000000000000\r
+ Flags=0000000000000001\r
+ Text=< &Back\r
+ Text French=< &Retour\r
+ Text German=< &Zurück\r
+ Text Spanish=< &Atrás\r
+ Text Italian=< &Indietro\r
+ end\r
+ item: Push Button\r
+ Rectangle=211 187 256 202\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=&Cancel\r
+ Text French=&Annuler\r
+ Text German=&Abbrechen\r
+ Text Spanish=&Cancelar\r
+ Text Italian=&Annulla\r
+ end\r
+ item: Static\r
+ Rectangle=8 180 256 181\r
+ Action=3\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 8 258 42\r
+ Create Flags=01010000000000000000000000000000\r
+ Flags=0000000000000001\r
+ Name=Times New Roman\r
+ Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18\r
+ Text=Select ProgMan Group\r
+ Text French=Sélectionner le groupe du Gestionnaire de programme \r
+ Text German=Bestimmung der Programm-Managergruppe\r
+ Text Spanish=Seleccione grupo del Administrador de programas\r
+ Text Italian=Selezionare il gruppo ProgMan \r
+ end\r
+ item: Static\r
+ Rectangle=86 44 256 68\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Enter the name of the Program Manager group to add the %APPTITLE% icons to:\r
+ Text French=Entrez le nom du groupe du Gestionnaire de programme dans lequel vous souhaitez ajouter les icônes de %APPTITLE% :\r
+ Text German=Geben Sie den Namen der Programmgruppe ein, der das Symbol %APPTITLE% hinzugefügt werden soll:\r
+ Text Spanish=Escriba el nombre del grupo del Administrador de programas en el que desea agregar los iconos de %APPTITLE%:\r
+ Text Italian=Inserire il nome del gruppo Program Manager per aggiungere le icone %APPTITLE% a:\r
+ end\r
+ item: Combobox\r
+ Rectangle=86 69 256 175\r
+ Variable=GROUP\r
+ Create Flags=01010000000000010000001000000001\r
+ Flags=0000000000000001\r
+ Text=%GROUP%\r
+ Text French=%GROUP%\r
+ Text German=%GROUP%\r
+ Text Spanish=%GROUP%\r
+ Text Italian=%GROUP%\r
+ end\r
+ end\r
+end\r
+item: Custom Dialog Set\r
+ Name=Start Installation\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Installation de %APPTITLE%\r
+ Title German=Installation von %APPTITLE%\r
+ Title Spanish=Instalación de %APPTITLE%\r
+ Title Italian=Installazione di %APPTITLE%\r
+ Width=271\r
+ Height=224\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Push Button\r
+ Rectangle=150 187 195 202\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Next >\r
+ Text French=&Suite >\r
+ Text German=&Weiter >\r
+ Text Spanish=&Siguiente >\r
+ Text Italian=&Avanti >\r
+ end\r
+ item: Push Button\r
+ Rectangle=105 187 150 202\r
+ Variable=DIRECTION\r
+ Value=B\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=< &Back\r
+ Text French=< &Retour\r
+ Text German=< &Zurück\r
+ Text Spanish=< &Atrás\r
+ Text Italian=< &Indietro\r
+ end\r
+ item: Push Button\r
+ Rectangle=211 187 256 202\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=&Cancel\r
+ Text French=&Annuler\r
+ Text German=&Abbrechen\r
+ Text Spanish=&Cancelar\r
+ Text Italian=&Annulla\r
+ end\r
+ item: Static\r
+ Rectangle=8 180 256 181\r
+ Action=3\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 8 258 42\r
+ Create Flags=01010000000000000000000000000000\r
+ Flags=0000000000000001\r
+ Name=Times New Roman\r
+ Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18\r
+ Text=Ready to Install!\r
+ Text French=Prêt à installer !\r
+ Text German=Installationsbereit!\r
+ Text Spanish=¡Preparado para la instalación!\r
+ Text Italian=Pronto per l'installazione!\r
+ end\r
+ item: Static\r
+ Rectangle=86 42 256 102\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=You are now ready to install %APPTITLE%.\r
+ Text=\r
+ Text=Press the Next button to begin the installation or the Back button to reenter the installation information.\r
+ Text French=Vous êtes maintenant prêt à installer les fichiers %APPTITLE%.\r
+ Text French=\r
+ Text French=Cliquez sur le bouton Suite pour commencer l'installation ou sur le bouton Retour pour entrer les informations d'installation à nouveau.\r
+ Text German=Sie können %APPTITLE% nun installieren.\r
+ Text German=\r
+ Text German=Klicken Sie auf "Weiter", um mit der Installation zu beginnen. Klicken Sie auf "Zurück", um die Installationsinformationen neu einzugeben.\r
+ Text Spanish=Ya está listo para instalar %APPTITLE%.\r
+ Text Spanish=\r
+ Text Spanish=Presione el botón Siguiente para comenzar la instalación o presione Atrás para volver a ingresar la información para la instalación.\r
+ Text Italian=Ora è possibile installare %APPTITLE%.\r
+ Text Italian=\r
+ Text Italian=Premere il pulsante Avanti per avviare l'installazione o il pulsante Indietro per reinserire le informazioni di installazione.\r
+ end\r
+ end\r
+end\r
+item: If/While Statement\r
+ Variable=DISPLAY\r
+ Value=Select Destination Directory\r
+end\r
+item: Set Variable\r
+ Variable=BACKUP\r
+ Value=%MAINDIR%\BACKUP\r
+end\r
+item: End Block\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=TYPE\r
+ Value=B\r
+end\r
+item: Set Variable\r
+ Variable=COMPONENTS\r
+ Value=A\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=DOBACKUP\r
+ Value=A\r
+end\r
+item: Set Variable\r
+ Variable=BACKUPDIR\r
+ Value=%BACKUP%\r
+end\r
+item: End Block\r
+end\r
+remarked item: If/While Statement\r
+ Variable=BRANDING\r
+ Value=1\r
+end\r
+remarked item: If/While Statement\r
+ Variable=DOBRAND\r
+ Value=1\r
+end\r
+remarked item: Edit INI File\r
+ Pathname=%INST%\CUSTDATA.INI\r
+ Settings=[Registration]\r
+ Settings=NAME=%NAME%\r
+ Settings=COMPANY=%COMPANY%\r
+ Settings=\r
+end\r
+remarked item: End Block\r
+end\r
+remarked item: End Block\r
+end\r
+item: Set Variable\r
+ Variable=MAINDIRSHORT\r
+ Value=%MAINDIR%\r
+ Flags=00010100\r
+end\r
+item: Open/Close INSTALL.LOG\r
+end\r
+item: Check Disk Space\r
+ Component=COMPONENTS\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\license.txt\r
+ Destination=%MAINDIR%\license.txt\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\Readme.txt\r
+ Destination=%MAINDIR%\Readme.txt\r
+ Flags=0000000000000010\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=D\r
+ Flags=00001010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\win\release\tk84.lib\r
+ Destination=%MAINDIR%\lib\tk84.lib\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\win\release\tkstub84.lib\r
+ Destination=%MAINDIR%\lib\tkstub84.lib\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\release\tcl84.lib\r
+ Destination=%MAINDIR%\lib\tcl84.lib\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\release\tclstub84.lib\r
+ Destination=%MAINDIR%\lib\tclstub84.lib\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\Xutil.h\r
+ Destination=%MAINDIR%\include\X11\Xutil.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\Xlib.h\r
+ Destination=%MAINDIR%\include\X11\Xlib.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\Xfuncproto.h\r
+ Destination=%MAINDIR%\include\X11\Xfuncproto.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\Xatom.h\r
+ Destination=%MAINDIR%\include\X11\Xatom.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\X.h\r
+ Destination=%MAINDIR%\include\X11\X.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\keysymdef.h\r
+ Destination=%MAINDIR%\include\X11\keysymdef.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\keysym.h\r
+ Destination=%MAINDIR%\include\X11\keysym.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\xlib\X11\cursorfont.h\r
+ Destination=%MAINDIR%\include\X11\cursorfont.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\generic\tk.h\r
+ Destination=%MAINDIR%\include\tk.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\generic\tkDecls.h\r
+ Destination=%MAINDIR%\include\tkDecls.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\generic\tkPlatDecls.h\r
+ Destination=%MAINDIR%\include\tkPlatDecls.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\generic\tkIntXlibDecls.h\r
+ Destination=%MAINDIR%\include\tkIntXlibDecls.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\generic\tcl.h\r
+ Destination=%MAINDIR%\include\tcl.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\generic\tclDecls.h\r
+ Destination=%MAINDIR%\include\tclDecls.h\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\generic\tclPlatDecls.h\r
+ Destination=%MAINDIR%\include\tclPlatDecls.h\r
+ Flags=0000000000000010\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=A\r
+ Flags=00001010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\msgcat\pkgIndex.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\msgcat1.2\pkgIndex.tcl\r
+ Flags=0000000010000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\msgcat\msgcat.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\msgcat1.2\msgcat.tcl\r
+ Flags=0000000010000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\tcltest\pkgIndex.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\tcltest2.0\pkgIndex.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\tcltest\tcltest.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\tcltest2.0\tcltest.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\symbol.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\symbol.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\shiftjis.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\shiftjis.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macUkraine.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macUkraine.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macTurkish.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macTurkish.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macThai.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macThai.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macRomania.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macRomania.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macRoman.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macRoman.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macJapan.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macJapan.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macIceland.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macIceland.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macGreek.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macGreek.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macDingbats.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macDingbats.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macCyrillic.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCyrillic.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macCroatian.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCroatian.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\macCentEuro.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\macCentEuro.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\ksc5601.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\ksc5601.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\koi8-r.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\koi8-r.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\jis0212.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0212.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\jis0208.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0208.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\jis0201.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\jis0201.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-15.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-15.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-9.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-9.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-8.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-8.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-7.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-7.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-6.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-6.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-5.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-5.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-4.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-4.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-3.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-3.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-2.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-2.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso8859-1.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso8859-1.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso2022.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso2022-kr.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022-kr.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\iso2022-jp.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\iso2022-jp.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\gb2312.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb2312.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\gb1988.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb1988.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\gb12345.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\gb12345.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\euc-cn.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-cn.enc\r
+ Flags=0000000010000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\euc-jp.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-jp.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\euc-kr.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\euc-kr.enc\r
+ Flags=0000000010000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\dingbats.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\dingbats.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp950.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp950.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp949.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp949.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp936.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp936.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp932.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp932.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp874.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp874.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp869.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp869.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp866.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp866.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp865.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp865.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp864.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp864.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp863.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp863.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp862.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp862.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp861.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp861.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp860.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp860.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp857.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp857.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp855.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp855.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp852.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp852.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp850.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp850.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp775.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp775.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp737.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp737.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp437.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp437.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1258.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1258.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1257.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1257.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1256.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1256.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1255.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1255.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1254.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1254.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1253.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1253.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1252.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1252.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1251.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1251.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\cp1250.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\cp1250.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\ascii.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\ascii.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\encoding\big5.enc\r
+ Destination=%MAINDIR%\lib\tcl%VER%\encoding\big5.enc\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\opt\pkgIndex.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\pkgIndex.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\opt\optparse.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\optparse.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\http\pkgIndex.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\http2.4\pkgIndex.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\http\http.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\http2.4\http.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\msgbox.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\msgbox.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\optMenu.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\optMenu.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\clrpick.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\clrpick.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\entry.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\entry.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\spinbox.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\spinbox.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\comdlg.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\comdlg.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\bgerror.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\bgerror.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\obsolete.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\obsolete.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\button.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\button.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\xmfbox.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\xmfbox.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\console.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\console.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\listbox.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\listbox.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\menu.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\menu.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\dialog.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\dialog.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\focus.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\focus.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\palette.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\palette.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\tkfbox.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\tkfbox.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\tk.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\tk.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\text.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\text.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\tearoff.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\tearoff.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\tclIndex\r
+ Destination=%MAINDIR%\lib\tk%VER%\tclIndex\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\scrlbar.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\scrlbar.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\scale.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\scale.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\safetk.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\safetk.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\http1.0\pkgIndex.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\http1.0\pkgIndex.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\http1.0\http.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\http1.0\http.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\pkgIndex.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\release\tclreg10.dll\r
+ Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\tclreg10.dll\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\dde\pkgIndex.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\pkgIndex.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\release\tcldde12.dll\r
+ Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde12.dll\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=C:\WINNT\SYSTEM32\Msvcrt.dll\r
+ Destination=%MAINDIR%\bin\msvcrt.dll\r
+ Flags=0010001000000011\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\win\release\wish84.exe\r
+ Destination=%MAINDIR%\bin\wish84.exe\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\release\tclsh84.exe\r
+ Destination=%MAINDIR%\bin\tclsh84.exe\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\release\tclpip84.dll\r
+ Destination=%MAINDIR%\bin\tclpip84.dll\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\win\release\tcl84.dll\r
+ Destination=%MAINDIR%\bin\tcl84.dll\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\win\release\tk84.dll\r
+ Destination=%MAINDIR%\bin\tk84.dll\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\auto.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\auto.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\history.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\history.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\init.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\init.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\package.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\package.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\parray.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\parray.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\safe.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\safe.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\tclIndex\r
+ Destination=%MAINDIR%\lib\tcl%VER%\tclIndex\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\library\word.tcl\r
+ Destination=%MAINDIR%\lib\tcl%VER%\word.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=B\r
+ Flags=00001010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\tai-ku.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\tai-ku.gif\r
+ Flags=0000000010000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\teapot.ppm\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\teapot.ppm\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\tcllogo.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\tcllogo.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\pattern.bmp\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\pattern.bmp\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\noletter.bmp\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\noletter.bmp\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\letters.bmp\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\letters.bmp\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\gray25.bmp\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\gray25.bmp\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\flagup.bmp\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\flagup.bmp\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\flagdown.bmp\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\flagdown.bmp\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\face.bmp\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\face.bmp\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\earthris.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\earthris.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\images\earth.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\images\earth.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\vscale.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\vscale.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\twind.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\twind.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\text.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\text.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\style.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\style.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\states.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\states.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\search.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\search.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\sayings.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\sayings.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\ruler.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\ruler.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\radio.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\radio.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\puzzle.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\puzzle.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\plot.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\plot.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\msgbox.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\msgbox.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\menubu.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\menubu.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\menu.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\menu.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\label.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\label.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\items.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\items.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\image2.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\image2.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\image1.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\image1.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\icon.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\icon.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\hscale.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\hscale.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\form.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\form.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\ixset\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\ixset.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\rolodex\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\rolodex.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\square\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\square.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\Readme\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\Readme\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\hello\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\hello.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\tclIndex\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\tclIndex\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\browse\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\browse.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\timer\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\timer.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\widget\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\widget.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\tcolor\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\tcolor.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\rmt\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\rmt.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\floor.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\floor.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\filebox.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\filebox.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\pwrdLogo75.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo75.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\pwrdLogo200.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo200.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\pwrdLogo175.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo175.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\pwrdLogo150.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo150.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\pwrdLogo100.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\pwrdLogo100.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\logoMed.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\logoMed.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\logoLarge.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\logoLarge.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\logo64.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\logo64.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\logo100.gif\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\logo100.gif\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\images\Readme\r
+ Destination=%MAINDIR%\lib\tk%VER%\images\Readme\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\arrow.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\arrow.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\bind.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\bind.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\bitmap.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\bitmap.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\button.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\button.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\check.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\check.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\clrpick.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\clrpick.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\colors.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\colors.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\cscroll.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\cscroll.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\ctext.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\ctext.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\dialog1.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\dialog1.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\dialog2.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\dialog2.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\entry1.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\entry1.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TKBASEDIR__}\library\demos\entry2.tcl\r
+ Destination=%MAINDIR%\lib\tk%VER%\demos\entry2.tcl\r
+ Flags=0000000000000010\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=C\r
+ Flags=00001010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\tools\tcl84.cnt\r
+ Destination=%MAINDIR%\doc\tcl84.cnt\r
+ Flags=0000000000000010\r
+end\r
+item: Install File\r
+ Source=${__TCLBASEDIR__}\tools\tcl84.hlp\r
+ Destination=%MAINDIR%\doc\tcl84.hlp\r
+ Flags=0000000000000010\r
+end\r
+item: End Block\r
+end\r
+item: Set Variable\r
+ Variable=MAINDIR\r
+ Value=%MAINDIR%\r
+ Flags=00010100\r
+end\r
+item: Include Script\r
+ Pathname=\\pop\tools\1.2\win32-ix86\wise\INCLUDE\uninstal.wse\r
+end\r
+item: Check Configuration\r
+ Flags=10111011\r
+end\r
+item: Get Registry Key Value\r
+ Variable=GROUPDIR\r
+ Key=Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\r
+ Default=%WIN%\Start Menu\Programs\r
+ Value Name=Programs\r
+ Flags=00000010\r
+end\r
+item: Set Variable\r
+ Variable=GROUP\r
+ Value=%GROUPDIR%\%GROUP%\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=A\r
+ Flags=00001010\r
+end\r
+item: Create Shortcut\r
+ Source=%MAINDIR%\bin\wish84.exe\r
+ Destination=%GROUP%\Wish.lnk\r
+ Working Directory=%MAINDIR%\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=A\r
+ Flags=00001010\r
+end\r
+item: Create Shortcut\r
+ Source=%MAINDIR%\bin\tclsh84.exe\r
+ Destination=%GROUP%\Tclsh.lnk\r
+ Working Directory=%MAINDIR%\r
+ Key Type=1536\r
+ Flags=00000001\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=C\r
+ Flags=00001010\r
+end\r
+item: Create Shortcut\r
+ Source=%MAINDIR%\doc\tcl84.hlp\r
+ Destination=%GROUP%\Tcl Help.lnk\r
+ Working Directory=%MAINDIR%\r
+end\r
+item: End Block\r
+end\r
+item: Create Shortcut\r
+ Source=%MAINDIR%\Readme.txt\r
+ Destination=%GROUP%\Readme.lnk\r
+ Working Directory=%MAINDIR%\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=B\r
+ Flags=00001010\r
+end\r
+item: Create Shortcut\r
+ Source=%MAINDIR%\lib\tk%VER%\demos\widget.tcl\r
+ Destination=%GROUP%\Widget Tour.lnk\r
+ Working Directory=%MAINDIR%\r
+ Key Type=1536\r
+ Flags=00000001\r
+end\r
+item: End Block\r
+end\r
+item: Else Statement\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=B\r
+ Flags=00001010\r
+end\r
+item: Add ProgMan Icon\r
+ Group=%GROUP%\r
+ Icon Name=Widget Tour\r
+ Command Line=%MAINDIR%\lib\tk%VER%\demos\widget.tcl\r
+ Icon Pathname=%MAINDIR%\bin\wish84.exe\r
+ Default Directory=%MAINDIR%\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=C\r
+ Flags=00001010\r
+end\r
+item: Add ProgMan Icon\r
+ Group=%GROUP%\r
+ Icon Name=Tcl Help\r
+ Command Line=%MAINDIR%\doc\tcl84.hlp\r
+ Default Directory=%MAINDIR%\r
+end\r
+item: End Block\r
+end\r
+item: Add ProgMan Icon\r
+ Group=%GROUP%\r
+ Icon Name=Readme\r
+ Command Line=%MAINDIR%\Readme.txt\r
+ Default Directory=%MAINDIR%\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=A\r
+ Flags=00001010\r
+end\r
+item: Add ProgMan Icon\r
+ Group=%GROUP%\r
+ Icon Name=Wish\r
+ Command Line=%MAINDIR%\bin\wish84.exe\r
+ Default Directory=%MAINDIR%\r
+end\r
+item: End Block\r
+end\r
+item: If/While Statement\r
+ Variable=COMPONENTS\r
+ Value=A\r
+ Flags=00001010\r
+end\r
+item: Add ProgMan Icon\r
+ Group=%GROUP%\r
+ Icon Name=Tclsh\r
+ Command Line=%MAINDIR%\bin\tclsh84.exe\r
+ Default Directory=%MAINDIR%\r
+end\r
+item: End Block\r
+end\r
+item: End Block\r
+end\r
+item: Self-Register OCXs/DLLs\r
+ Description=Updating System Configuration, Please Wait...\r
+end\r
+item: Edit Registry\r
+ Total Keys=1\r
+ Key=SOFTWARE\Scriptics\Tcl\%VER%\r
+ New Value=%MAINDIR%\r
+ Value Name=Root\r
+ Root=2\r
+end\r
+item: Edit Registry\r
+ Total Keys=1\r
+ Key=TclScript\DefaultIcon\r
+ New Value=%MAINDIR%\bin\tk84.dll\r
+end\r
+item: Edit Registry\r
+ Total Keys=1\r
+ Key=.tcl\r
+ New Value=TclScript\r
+end\r
+item: Edit Registry\r
+ Total Keys=1\r
+ Key=TclScript\r
+ New Value=TclScript\r
+end\r
+item: Edit Registry\r
+ Total Keys=1\r
+ Key=TclScript\shell\open\command\r
+ New Value=%MAINDIRSHORT%\bin\wish84.exe "%%1" %%*\r
+end\r
+item: Edit Registry\r
+ Total Keys=1\r
+ Key=TclScript\shell\edit\r
+ New Value=&Edit\r
+end\r
+item: Edit Registry\r
+ Total Keys=1\r
+ Key=TclScript\shell\edit\command\r
+ New Value=notepad "%%1"\r
+end\r
+item: Add Directory to Path\r
+ Directory=%MAINDIR%\bin\r
+end\r
+item: Check Configuration\r
+ Flags=10111011\r
+end\r
+item: Set Variable\r
+ Variable=TO_SCRIPTICS\r
+ Value=A\r
+end\r
+item: Else Statement\r
+end\r
+item: Set Variable\r
+ Variable=TO_SCRIPTICS\r
+end\r
+item: End Block\r
+end\r
+item: Wizard Block\r
+ Direction Variable=DIRECTION\r
+ Display Variable=DISPLAY\r
+ Bitmap Pathname=%_WISE_%\DIALOGS\TEMPLATE\WIZARD.BMP\r
+ X Position=9\r
+ Y Position=10\r
+ Filler Color=8421440\r
+ Flags=00000011\r
+end\r
+item: Custom Dialog Set\r
+ Name=Finished\r
+ Display Variable=DISPLAY\r
+ item: Dialog\r
+ Title=%APPTITLE% Installation\r
+ Title French=Installation de %APPTITLE%\r
+ Title German=Installation von %APPTITLE%\r
+ Title Spanish=Instalación de %APPTITLE%\r
+ Title Italian=Installazione di %APPTITLE%\r
+ Width=271\r
+ Height=224\r
+ Font Name=Helv\r
+ Font Size=8\r
+ item: Push Button\r
+ Rectangle=150 187 195 202\r
+ Variable=DIRECTION\r
+ Value=N\r
+ Create Flags=01010000000000010000000000000001\r
+ Text=&Finish\r
+ Text French=&Fin\r
+ Text German=&Weiter\r
+ Text Spanish=&Terminar\r
+ Text Italian=&Fine\r
+ end\r
+ item: Push Button\r
+ Rectangle=105 187 150 202\r
+ Variable=DISABLED\r
+ Value=!\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=< &Back\r
+ Text French=< &Retour\r
+ Text German=< &Zurück\r
+ Text Spanish=< &Atrás\r
+ Text Italian=< &Indietro\r
+ end\r
+ item: Push Button\r
+ Rectangle=211 187 256 202\r
+ Variable=DISABLED\r
+ Value=!\r
+ Action=3\r
+ Create Flags=01010000000000010000000000000000\r
+ Text=&Cancel\r
+ Text French=&Annuler\r
+ Text German=&Abbrechen\r
+ Text Spanish=&Cancelar\r
+ Text Italian=&Annulla\r
+ end\r
+ item: Static\r
+ Rectangle=8 180 256 181\r
+ Action=3\r
+ Create Flags=01010000000000000000000000000111\r
+ end\r
+ item: Static\r
+ Rectangle=86 8 258 42\r
+ Create Flags=01010000000000000000000000000000\r
+ Flags=0000000000000001\r
+ Name=Times New Roman\r
+ Font Style=-24 0 0 0 700 255 0 0 0 3 2 1 18\r
+ Text=Installation Completed!\r
+ Text French=Installation terminée !\r
+ Text German=Die Installation ist abgeschlossen!\r
+ Text Spanish=¡Instalación terminada!\r
+ Text Italian=Installazione completata!\r
+ end\r
+ item: Static\r
+ Rectangle=86 42 256 153\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=%APPTITLE% has been successfully installed.\r
+ Text=\r
+ Text=Click the Finish button to exit this installation.\r
+ Text=\r
+ Text=You can learn more about Tcl/Tk %VER%, including release notes, updates, tutorials, and more at %URL%. Check the box below to start your web browser and go there now.\r
+ Text=\r
+ Text=The installer may ask you to reboot your computer, this is to update your PATH and is not necessary to do immediately.\r
+ Text French=%APPTITLE% est maintenant installé.\r
+ Text French=\r
+ Text French=Cliquez sur le bouton Fin pour quitter l'installation.\r
+ Text German=%APPTITLE% wurde erfolgreich installiert.\r
+ Text German=\r
+ Text German=Klicken Sie auf "Weiter", um die Installation zu beenden.\r
+ Text Spanish=%APPTITLE% se ha instalado con éxito.\r
+ Text Spanish=\r
+ Text Spanish=Presione el botón Terminar para salir de esta instalación.\r
+ Text Italian=L'installazione %APPTITLE% è stata portata a termine con successo.\r
+ Text Italian=\r
+ Text Italian=Premere il pulsante Fine per uscire dall'installazione.\r
+ end\r
+ item: Checkbox\r
+ Rectangle=88 143 245 157\r
+ Variable=TO_SCRIPTICS\r
+ Enabled Color=00000000000000001111111111111111\r
+ Create Flags=01010000000000010000000000000011\r
+ Text=Show me important information about\r
+ Text=\r
+ end\r
+ item: Static\r
+ Rectangle=99 156 245 170\r
+ Enabled Color=00000000000000001111111111111111\r
+ Create Flags=01010000000000000000000000000000\r
+ Text=Tcl/Tk %VER% and TclPro\r
+ end\r
+ end\r
+end\r
+item: End Block\r
+end\r
+item: Check Configuration\r
+ Flags=10111011\r
+end\r
+item: If/While Statement\r
+ Variable=TO_SCRIPTICS\r
+ Value=A\r
+ Flags=00000010\r
+end\r
+item: Execute Program\r
+ Command Line=%URL%\r
+end\r
+item: End Block\r
+end\r
+item: Execute Program\r
+ Pathname=explorer\r
+ Command Line=%GROUP%\r
+end\r
+item: End Block\r
+end\r
+\r
# Oct 24, 1997 - moved from 8.0b1 to 8.0 release
#
-set Version "0.20"
+set Version "0.30"
proc parse_command_line {} {
global argv Version
set webdir ../html
# Directory names for Tcl and Tk, in priority order.
- set tclDirList {tcl8.3 tcl8.2 tcl8.1 tcl8.0 tcl}
- set tkDirList {tk8.3 tk8.2 tk8.1 tk8.0 tk}
+ set tclDirList {tcl8.4 tcl8.3 tcl8.2 tcl8.1 tcl8.0 tcl}
+ set tkDirList {tk8.4 tk8.3 tk8.2 tk8.1 tk8.0 tk}
# Handle arguments a la GNU:
# --version
regsub -all {\\-\\\|\\-} $text -- text; # two hyphens
regsub -all -- {\\-\\\^\\-} $text -- text; # two hyphens
regsub -all {\\-} $text - text; # a hyphen
- regsub -all "\\\\\n" $text "\\&\#92;\n" text; # backslashed newline
- while {[regexp {\\} $text]} {
+ regsub -all "\\\\\n" $text "\\\\n" text; # backslashed newline
+ while {[string first "\\" $text] >= 0} {
# C R
- if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text {\1<TT>\2</TT>\3} text]} continue
+ if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
+ {\1<TT>\2</TT>\3} text]} continue
# B R
- if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text {\1<B>\2</B>\3} text]} continue
+ if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
+ {\1<B>\2</B>\3} text]} continue
# B I
- if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text {\1<B>\2</B>\\fI\3} text]} continue
+ if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
+ {\1<B>\2</B>\\fI\3} text]} continue
# I R
- if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text {\1<I>\2</I>\3} text]} continue
+ if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
+ {\1<I>\2</I>\3} text]} continue
# I B
- if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text {\1<I>\2</I>\\fB\3} text]} continue
+ if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
+ {\1<I>\2</I>\\fB\3} text]} continue
# B B, I I, R R
- if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text {\1\\fB\2\3} ntext]
- || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text {\1\\fI\2\3} ntext]
- || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text {\1\\fR\2\3} ntext]} {
+ if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \
+ {\1\\fB\2\3} ntext]
+ || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text \
+ {\1\\fI\2\3} ntext]
+ || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text \
+ {\1\\fR\2\3} ntext]} {
manerror "process-text: impotent font change: $text"
set text $ntext
continue
}
- # unrecognized
+ # unrecognized
manerror "process-text: uncaught backslash: $text"
set text [string map [list "\\" "#92;"] $text]
}
error "fatal"
}
proc is-a-directive {line} {
- return [expr {[string first . $line] == 0}]
+ return [string match .* $line]
}
proc split-directive {line opname restname} {
upvar $opname op $restname rest
incr manual(text-pointer)
continue
}
- if {[regexp {^@([_a-zA-Z0-9]+)$} $arg all name]} {
+ if {[regexp {^@(\w+)$} $arg all name]} {
upvar $name var
set var $targ
incr nback
incr manual(text-pointer)
continue
}
- if {[regexp {^(\.[a-zA-Z][a-zA-Z])@([_a-zA-Z0-9]+)$} $arg all op name]\
+ if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\
&& [string equal $op [lindex $targ 0]]} {
upvar $name var
set var [lrange $targ 1 end]
global manual
set here M[incr manual(section-toc-n)]
set there L[incr manual(long-toc-n)]
- lappend manual(section-toc) "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
+ lappend manual(section-toc) \
+ "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
return "<A NAME=\"$here\">$text</A>"
}
proc option-toc {name class switch} {
set para {}
while {[next-op-is .OP rest]} {
switch -exact [llength $rest] {
- 3 {
- set switch [lindex $rest 0]
- set name [lindex $rest 1]
- set class [lindex $rest 2]
- }
+ 3 { foreach {switch name class} $rest { break } }
5 {
set switch [lrange $rest 0 2]
set name [lindex $rest 3]
fatal "bad .OP $rest"
}
}
- if {![regexp {^(<.>)([-a-zA-Z0-9 ]+)(</.>)$} $switch all oswitch switch cswitch]} {
- if {![regexp {^(<.>)([-a-zA-Z0-9 ]+) or ([-a-zA-Z0-9 ]+)(</.>)$} $switch all oswitch switch1 switch2 cswitch]} {
+ if {![regexp {^(<.>)([-\w ]+)(</.>)$} $switch all oswitch switch cswitch]} {
+ if {![regexp {^(<.>)([-\w ]+) or ([-\w ]+)(</.>)$} $switch all oswitch switch1 switch2 cswitch]} {
error "not Switch: $switch"
} else {
set switch "$switch1$cswitch or $oswitch$switch2"
}
}
- if {![regexp {^(<.>)([a-zA-Z0-9]*)(</.>)$} $name all oname name cname]} {
+ if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} {
error "not Name: $name"
}
- if {![regexp {^(<.>)([a-zA-Z0-9]*)(</.>)$} $class all oclass class cclass]} {
+ if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} {
error "not Class: $class"
}
man-puts "$para<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
##
proc output-IP-list {context code rest} {
global manual
- if {[string equal $rest {}]} {
+ if {![string length $rest]} {
# blank label, plain indent, no contents entry
man-puts <DL><P><DD>
while {[more-text]} {
continue
}
if {[string equal $manual(section) "ARGUMENTS"] || \
- [regexp {^\[[0-9]+\]$} $rest]} {
+ [regexp {^\[\d+\]$} $rest]} {
man-puts "<P><DT>$rest<DD>"
} else {
man-puts "<P><DT>[long-toc $rest]<DD>"
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
# gad, this is getting ridiculous
- if { ! $accept_RE} {
+ if {!$accept_RE} {
man-puts "</DL><P>$rest<DL>"
backup-text 1
break
}
}
.RE {
- if { ! $accept_RE} {
+ if {!$accept_RE} {
backup-text 1
break
}
##
## nothing to reference
##
- if { ! [info exists manual(name-$lref)]} {
+ if {![info exists manual(name-$lref)]} {
foreach name {array file history info interp string trace
after clipboard grab image option pack place selection tk tkwait update winfo wm} {
if {[regexp "^$name \[a-z0-9]*\$" $lref] && \
set tcl_ref [lindex $manual(name-$lref) $tcl_i]
set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*]
set tk_ref [lindex $manual(name-$lref) $tk_i]
- if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} || "$manual(wing-file)" == {TclLib}} {
+ if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} \
+ || "$manual(wing-file)" == {TclLib}} {
return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
}
- if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} || "$manual(wing-file)" == {TkLib}} {
+ if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} \
+ || "$manual(wing-file)" == {TkLib}} {
return "<A HREF=\"../$tk_ref.htm\">$ref</A>"
}
if {"$lref" == {exit} && "$manual(tail)" == {tclsh.1} && $tcl_i >= 0} {
##
## if nothing, then we're done.
##
- if { ! [info exists offsets]} {
+ if {![info exists offsets]} {
return $text
}
##
##
switch -exact $invert([lindex $offsets 0]) {
anchor {
- if {$offset(end-anchor) < 0} { return [reference-error {Missing end anchor} $text]; }
+ if {$offset(end-anchor) < 0} {
+ return [reference-error {Missing end anchor} $text]
+ }
set head [string range $text 0 $offset(end-anchor)]
- set tail [string range $text [expr $offset(end-anchor)+1] end]
+ set tail [string range $text [expr {$offset(end-anchor)+1}] end]
return $head[insert-cross-references $tail]
}
quote {
- if {$offset(end-quote) < 0} { return [reference-error {Missing end quote} $text]; }
- if {"$invert([lindex $offsets 1])" == {tk}} { set offsets [lreplace $offsets 1 1]; }
- if {"$invert([lindex $offsets 1])" == {tcl}} { set offsets [lreplace $offsets 1 1]; }
+ if {$offset(end-quote) < 0} {
+ return [reference-error "Missing end quote" $text]
+ }
+ if {$invert([lindex $offsets 1]) == "tk"} {
+ set offsets [lreplace $offsets 1 1]
+ }
+ if {$invert([lindex $offsets 1]) == "tcl"} {
+ set offsets [lreplace $offsets 1 1]
+ }
switch -exact $invert([lindex $offsets 1]) {
end-quote {
- set head [string range $text 0 [expr $offset(quote)-1]]
- set body [string range $text [expr $offset(quote)+2] [expr $offset(end-quote)-1]]
- set tail [string range $text [expr $offset(end-quote)+2] end]
- return $head``[cross-reference $body]''[insert-cross-references $tail]
+ set head [string range $text 0 [expr {$offset(quote)-1}]]
+ set body [string range $text [expr {$offset(quote)+2}] \
+ [expr {$offset(end-quote)-1}]]
+ set tail [string range $text \
+ [expr {$offset(end-quote)+2}] end]
+ return "$head``[cross-reference $body]''[insert-cross-references $tail]"
}
bold -
anchor {
- set head [string range $text 0 [expr $offset(end-quote)+1]]
- set tail [string range $text [expr $offset(end-quote)+2] end]
- return $head[insert-cross-references $tail]
+ set head [string range $text \
+ 0 [expr {$offset(end-quote)+1}]]
+ set tail [string range $text \
+ [expr {$offset(end-quote)+2}] end]
+ return "$head[insert-cross-references $tail]"
}
}
- return [reference-error {Uncaught quote case} $text]
+ return [reference-error "Uncaught quote case" $text]
}
bold {
- if {$offset(end-bold) < 0} { return $text; }
- if {"$invert([lindex $offsets 1])" == {tk}} { set offsets [lreplace $offsets 1 1]; }
- if {"$invert([lindex $offsets 1])" == {tcl}} { set offsets [lreplace $offsets 1 1]; }
+ if {$offset(end-bold) < 0} { return $text }
+ if {$invert([lindex $offsets 1]) == "tk"} {
+ set offsets [lreplace $offsets 1 1]
+ }
+ if {$invert([lindex $offsets 1]) == "tcl"} {
+ set offsets [lreplace $offsets 1 1]
+ }
switch -exact $invert([lindex $offsets 1]) {
end-bold {
- set head [string range $text 0 [expr $offset(bold)-1]]
- set body [string range $text [expr $offset(bold)+3] [expr $offset(end-bold)-1]]
- set tail [string range $text [expr $offset(end-bold)+4] end]
- return $head<B>[cross-reference $body]</B>[insert-cross-references $tail]
+ set head [string range $text 0 [expr {$offset(bold)-1}]]
+ set body [string range $text [expr {$offset(bold)+3}] \
+ [expr {$offset(end-bold)-1}]]
+ set tail [string range $text \
+ [expr {$offset(end-bold)+4}] end]
+ return "$head<B>[cross-reference $body]</B>[insert-cross-references $tail]"
}
anchor {
- set head [string range $text 0 [expr $offset(end-bold)+3]]
- set tail [string range $text [expr $offset(end-bold)+4] end]
- return $head[insert-cross-references $tail]
+ set head [string range $text \
+ 0 [expr {$offset(end-bold)+3}]]
+ set tail [string range $text \
+ [expr {$offset(end-bold)+4}] end]
+ return "$head[insert-cross-references $tail]"
}
}
- return [reference-error {Uncaught bold case} $text]
+ return [reference-error "Uncaught bold case" $text]
}
tk {
- set head [string range $text 0 [expr $offset(tk)-1]]
+ set head [string range $text 0 [expr {$offset(tk)-1}]]
set tail [string range $text $offset(tk) end]
- if { ! [regexp {^(Tk_[a-zA-Z0-9_]+)(.*)$} $tail all body tail]} { return [reference-error {Tk regexp failed} $text]; }
+ if {![regexp {^(Tk_\w+)(.*)$} $tail all body tail]} {
+ return [reference-error "Tk regexp failed" $text]
+ }
return $head[cross-reference $body][insert-cross-references $tail]
}
tcl {
- set head [string range $text 0 [expr $offset(tcl)-1]]
+ set head [string range $text 0 [expr {$offset(tcl)-1}]]
set tail [string range $text $offset(tcl) end]
- if { ! [regexp {^(Tcl_[a-zA-Z0-9_]+)(.*)$} $tail all body tail]} { return [reference-error {Tcl regexp failed} $text]; }
+ if {![regexp {^(Tcl_\w+)(.*)$} $tail all body tail]} {
+ return [reference-error {Tcl regexp failed} $text]
+ }
return $head[cross-reference $body][insert-cross-references $tail]
}
Tcl1 -
Tcl2 {
set off [lindex $offsets 0]
- set head [string range $text 0 [expr $off-1]]
+ set head [string range $text 0 [expr {$off-1}]]
set body Tcl
- set tail [string range $text [expr $off+3] end]
+ set tail [string range $text [expr {$off+3}] end]
return $head[cross-reference $body][insert-cross-references $tail]
}
end-anchor -
set nmore {}
foreach cr [split $more ,] {
set cr [string trim $cr]
- if { ! [regexp {^<B>.*</B>$} $cr]} {
+ if {![regexp {^<B>.*</B>$} $cr]} {
set cr <B>$cr</B>
}
if {[regexp {^<B>(.*)\([13n]\)</B>$} $cr all name]} {
##
proc merge-copyrights {l1 l2} {
foreach copyright [concat $l1 $l2] {
- if {[regexp {^Copyright +\(c\) +([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all date by who]} {
+ if {[regexp {^Copyright +\(c\) +(\d+) +(by +)?(\w.*)$} $copyright all date by who]} {
lappend dates($who) $date
continue
}
- if {[regexp {^Copyright +\(c\) +([0-9]+)-([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all from to by who]} {
+ if {[regexp {^Copyright +\(c\) +(\d+)-(\d+) +(by +)?(\w.*)$} $copyright all from to by who]} {
for {set date $from} {$date <= $to} {incr date} {
lappend dates($who) $date
}
continue
}
- if {[regexp {^Copyright +\(c\) +([0-9]+), *([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all date1 date2 by who]} {
+ if {[regexp {^Copyright +\(c\) +(\d+), *(\d+) +(by +)?(\w.*)$} $copyright all date1 date2 by who]} {
lappend dates($who) $date1 $date2
continue
}
}
return [lsort $merge]
}
-
+
proc makedirhier {dir} {
- if { ! [file isdirectory $dir]} {
- makedirhier [file dirname $dir]
- if { ! [file isdirectory $dir]} {
- if {[catch {exec mkdir $dir} error]} {
- error "cannot create directory $dir: $error"
- }
- }
+ if {![file isdirectory $dir] && \
+ [catch {file mkdir $dir} error]} {
+ return -code error "cannot create directory $dir: $error"
}
}
-
+
##
## foreach of the man directories specified by args
## convert manpages into hypertext in the directory
proc make-man-pages {html args} {
global env manual overall_title
makedirhier $html
- if { ! [file isdirectory $html]} {
- exec mkdir $html
- }
set manual(short-toc-n) 1
set manual(short-toc-fp) [open $html/contents.htm w]
puts $manual(short-toc-fp) "<HTML><HEAD><TITLE>$overall_title</TITLE></HEAD>"
manerror "discarding $manual(name)"
continue
}
- set manual(infp) [open "$manual(page)"]
+ set manual(infp) [open $manual(page)]
set manual(text) {}
set manual(partial-text) {}
foreach p {.RS .DS .CS .SO} {
set manual(section-toc-n) 1
set manual(copyrights) {}
lappend manual(all-pages) $manual(wing-file)/$manual(tail)
- manreport 100 "$manual(name)"
+ manreport 100 $manual(name)
while {[gets $manual(infp) line] >= 0} {
manreport 100 $line
if {[regexp {^[`'][/\\]} $line]} {
}
if {[parse-directive $line code rest]} {
switch -exact $code {
- .ad -
- .na -
- .so -
- .ne -
- .AS -
- .VE -
- .VS -
+ .ad - .na - .so - .ne - .AS - .VE - .VS -
. {
# ignore
continue
.TH {
lappend manual(text) "$code [unquote $rest]"
}
- .HS -
- .UL -
+ .HS - .UL -
.ta {
lappend manual(text) "$code [unquote $rest]"
}
- .BS -
- .BE -
- .br -
- .fi -
- .sp -
+ .BS - .BE - .br - .fi - .sp -
.nf {
if {"$rest" != {}} {
manerror "unexpected argument: $line"
lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
}
.IP {
- regexp {^(.*) +[0-9]+$} $rest all rest
+ regexp {^(.*) +\d+$} $rest all rest
lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"
}
.TP {
}
.OP {
lappend manual(text) [concat .OP [process-text \
- "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]
+ "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]
}
.PP -
.LP {
}
.de {
while {[gets $manual(infp) line] >= 0} {
- if {[regexp {^\.\.} $line]} {
+ if {[string match "..*" $line]} {
break
}
}
}
}
} else {
- if {"$manual(partial-text)" == {}} {
+ if {$manual(partial-text) == ""} {
set manual(partial-text) $line
} else {
append manual(partial-text) \n$line
}
}
}
- if {"$manual(partial-text)" != {}} {
+ if {$manual(partial-text) != ""} {
lappend manual(text) [process-text $manual(partial-text)]
}
close $manual(infp)
# fixups
if {$manual(.RS) != 0} {
- if {"$manual(name)" != {selection}} {
+ if {$manual(name) != "selection"} {
puts "unbalanced .RS .RE"
}
}
# output conversion
open-text
if {[next-op-is .HS rest]} {
- set manual($manual(name)-title) "[lrange $rest 1 end] [lindex $rest 0] manual page"
+ set manual($manual(name)-title) \
+ "[lrange $rest 1 end] [lindex $rest 0] manual page"
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
set width [string length $name]
}
}
- set perline [expr 120 / $width]
- set nrows [expr ([llength $manual(wing-toc)]+$perline)/$perline]
+ set perline [expr {120 / $width}]
+ set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}]
set n 0
catch {unset rows}
foreach name [lsort $manual(wing-toc)] {
set tail $manual(name-$name)
if {[llength $tail] > 1} {
manerror "$name is defined in more than one file: $tail"
- set tail [lindex $tail [expr [llength $tail]-1]]
+ set tail [lindex $tail [expr {[llength $tail]-1}]]
}
set tail [file tail $tail]
- append rows([expr $n%$nrows]) "<td> <a href=\"$tail.htm\">$name</a>"
+ append rows([expr {$n%$nrows}]) \
+ "<td> <a href=\"$tail.htm\">$name</a>"
incr n
}
puts $manual(wing-toc-fp) <table>
proc strcasecmp {a b} { return [string compare -nocase $a $b] }
set keys [lsort -command strcasecmp [array names manual keyword-*]]
makedirhier $html/Keywords
- catch {eval exec rm -f [glob $html/Keywords/*]}
+ catch {eval file delete -- [glob $html/Keywords/*]}
puts $manual(short-toc-fp) {<DT><A HREF="Keywords/contents.htm">Keywords</A><DD>The keywords from the Tcl/Tk man pages.}
set keyfp [open $html/Keywords/contents.htm w]
puts $keyfp "<HTML><HEAD><TITLE>Tcl/Tk Keywords</TITLE></HEAD>"
puts $error\n$errorInfo
}
}
-
+#!/bin/sh
+# The next line is executed by /bin/sh, but not tcl \
+exec tclsh "$0" ${1+"$@"}
+
+#
+# uniClass.tcl --
+#
+# Generates the character ranges and singletons that are used in
+# generic/regc_locale.c for translation of character classes.
+# This file must be generated using a tclsh that contains the
+# correct corresponding tclUniData.c file (generated by uniParse.tcl)
+# in order for the class ranges to match.
+#
+
proc emitRange {first last} {
global ranges numranges chars numchars
set chars " "
set numchars 0
- for {set i 0} {$i < 0x10000} {incr i} {
+ for {set i 0} {$i <= 0xFFFF} {incr i} {
if {[string is $type [format %c $i]]} {
if {$i == ($last + 1)} {
set last $i
}
}
emitRange $first $last
-
- puts "static crange ${type}RangeTable\[\] = {\n$ranges\n};\n"
- puts "#define NUM_[string toupper $type]_RANGE (sizeof(${type}RangeTable)/sizeof(crange))\n"
- puts "static chr ${type}CharTable\[\] = {\n$chars\n};\n"
- puts "#define NUM_[string toupper $type]_CHAR (sizeof(${type}CharTable)/sizeof(chr))\n"
+
+ set ranges [string trimright $ranges "\t\n ,"]
+ set chars [string trimright $chars "\t\n ,"]
+ if {$ranges != ""} {
+ puts "static crange ${type}RangeTable\[\] = {\n$ranges\n};\n"
+ puts "#define NUM_[string toupper $type]_RANGE (sizeof(${type}RangeTable)/sizeof(crange))\n"
+ } else {
+ puts "/* no contiguous ranges of $type characters */\n"
+ }
+ if {$chars != ""} {
+ puts "static chr ${type}CharTable\[\] = {\n$chars\n};\n"
+ puts "#define NUM_[string toupper $type]_CHAR (sizeof(${type}CharTable)/sizeof(chr))\n"
+ } else {
+ puts "/* no singletons of $type characters */\n"
+ }
}
+puts "/*
+ * Declarations of Unicode character ranges. This code
+ * is automatically generated by the tools/uniClass.tcl script
+ * and used in generic/regc_locale.c. Do not modify by hand.
+ */
+"
-foreach type {alpha digit punct space lower upper graph } {
+foreach {type desc} {
+ alpha "alphabetic characters"
+ digit "decimal digit characters"
+ punct "punctuation characters"
+ space "white space characters"
+ lower "lowercase characters"
+ upper "uppercase characters"
+ graph "unicode print characters excluding space"
+} {
+ puts "/* Unicode: $desc */\n"
genTable $type
}
+puts "/*
+ * End of auto-generated Unicode character ranges declarations.
+ */"
set f [open [file join [lindex $argv 1] tclUniData.c] w]
fconfigure $f -translation lf
puts $f "/*
- * tclUtfData.c --
+ * tclUniData.c --
*
* Declarations of Unicode character information tables. This file is
* automatically generated by the tools/uniParse.tcl script. Do not
#define GetCaseType(info) (((info) & 0xE0) >> 5)
#define GetCategory(info) ((info) & 0x1F)
-#define GetDelta(infO) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22)))
+#define GetDelta(info) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22)))
/*
* This macro extracts the information about a character from the
+++ /dev/null
-2002-07-30 Keith Seitz <keiths@redhat.com>
-
- From Mo DeJong <supermo@bayarea.net>
- * unix/configure: Regenerate.
- * unix/configure.in: Don't subst TCL_BIN_DIR into tclConfig.sh.
- * unix/tclConfig.sh.in: Remove TCL_BIN_DIR variable since it
- should not exist in the tclConfig.sh file. This variable
- should be set by the SC_PATH_TCLCONFIG macro when the
- extension's configure script is run.
-
-2002-01-10 Keith Seitz <keiths@redhat.com>
-
- * unix/Makefile.in (TCL_RANLIB): Renamed from just "RANLIB".
- Changed all references to "RANLIB" to "TCL_RANLIB" so that
- toplevel Makefile doesn't override our own settings.
-
-2001-09-18 Ian Roxborough <irox@redhat.com>
-
- * Makefile.in: Added TCL_CFLAGS for flags that
- shouldn't be supressed by the top level Makefile's
- CFLAGS settings.
-
-Fri Mar 19 09:29:42 1999 Michael Tiemann <tiemann@holodeck.cygnus.com>
-
- * configure.in, configure (IRIX64-6.*): Use -n32 instead of -32
- for SHLIB_LD.
-
-1998-10-28 Ben Elliston <bje@cygnus.com>
-
- * tclConfig.sh.in (TCL_BUILD_INCLUDES): Remove.
- * configure.in (TCL_BUILD_INCLUDES): Remove. Do not subst.
- * configure: Regenerate.
-
-Fri Apr 10 16:52:30 1998 Ian Lance Taylor <ian@cygnus.com>
-
- * configure.in: Remove test for DOS_PATHNAMES.
- * configure: Rebuild.
-
- * configure.in: Remove call to CY_AC_C_WORKS.
- * aclocal.m4: Remove CY_AC_C_WORKS.
- * configure: Rebuild.
-
-Tue Mar 24 17:28:53 1998 Stu Grossman <grossman@bhuna.cygnus.co.uk>
-
- * dltest/configure: Regenerate with autoconf 2.12.1 to fix shell
- issues for NT native builds.
-
-Mon Nov 17 09:02:23 1997 Tom Tromey <tromey@cygnus.com>
-
- * configure: Rebuilt.
- * configure.in (TCL_SHARED_LIB_FILE, TCL_UNSHARED_LIB_FILE):
- Define with dummy values to avoid Makefile syntax errors.
-
-Tue Oct 28 16:31:58 1997 Ian Lance Taylor <ian@cygnus.com>
-
- * Makefile.in (install-minimal): New target.
-
-Tue Aug 5 13:25:58 1997 Tom Tromey <tromey@cygnus.com>
-
- * configure: Rebuilt.
- * configure.in: Preserved local changes.
- * mkLinks: Preserved local changes.
-
-Mon Aug 4 16:24:25 1997 Tom Tromey <tromey@cygnus.com>
-
- * tclAppInit.c (main): Don't handle -h or -v arguments.
-
-Tue Jul 1 22:09:28 1997 Ian Lance Taylor <ian@cygnus.com>
-
- * configure.in: Fix -lnsl test.
- * configure: Rebuild.
-
-Mon Jun 30 13:31:28 1997 Ian Lance Taylor <ian@cygnus.com>
-
- * configure.in: Rework check for socket libraries to use a cache
- variable and to not set ac_cv_func cache variables
- inappropriately.
- * configure: Rebuild.
-
-Mon Mar 17 11:36:55 1997 Tom Tromey <tromey@cygnus.com>
-
- * configure: Regenerated.
- * configure.in (have_timezone): HPUX sys/time.h has whitespace
- before timezone decl.
-
-Thu Mar 13 14:38:31 1997 Tom Tromey <tromey@cygnus.com>
-
- * tclUnixTime.c (TclpGetTimeZone): Declare timezone if not
- declared in header.
-
- * configure.in (have_timezone): Check for timezone decl in
- time.h.
-
-Fri Nov 22 11:02:08 1996 Tom Tromey <tromey@cygnus.com>
-
- * configure.in: Use AC_STRUCT_ST_BLKSIZE, not hand-written code.
-
- * tclUnixFCmd.c (CopyFile): Use BUFSIZ, not mythical BLKSIZE.
-
-Thu Nov 21 10:53:19 1996 Tom Tromey <tromey@cygnus.com>
-
- * tclUnixFCmd.c (CopyFile): Check HAVE_ST_BLKSIZE.
-
- * configure.in: Remove check for realpath; don't define
- HAVE_GETCWD.
- Check for st_blksize in struct stat.
-
-Wed Nov 20 14:07:31 1996 Tom Tromey <tromey@cygnus.com>
-
- * Makefile.in (GENERIC_OBJS): Removed tclAlloc.o.
- (GENERIC_SRCS): Removed tclAlloc.c.
- (tclAlloc.o): Removed.
-
-Thu Oct 3 17:18:42 1996 Ian Lance Taylor <ian@cygnus.com>
-
- * Makefile.in (mostlyclean): New target.
-
-Thu Oct 3 11:38:41 1996 Tom Tromey <tromey@cygnus.com>
-
- * dltest/Makefile.in (distclean): Remove configure-generated files
- here.
-
-Mon Aug 26 09:38:22 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in: Use TCL_SHARED_LIB_FILE, TCL_UNSHARED_LIB_FILE.
- * configure: Regenerated.
- * configure.in: Introduce TCL_SHARED_LIB_FILE and
- TCL_UNSHARED_LIB_FILE.
-
- * configure: Regenerated.
- * configure.in (HP-UX): Make sure test for GNU ld fails with HPUX
- linker.
-
-Wed Aug 14 09:20:54 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (install-man): Man page permissions are 644, not
- 444.
-
-Tue Aug 13 11:49:08 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure.in: On IRIX 6.2 timezone is a time_t, not a long.
-
-Mon Aug 5 10:35:17 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (configure): Don't depend on configure.in. Work
- when not in srcdir.
-
- * configure: Regenerated.
- * configure.in: Don't hard-code `gcc'; use $CC instead.
- [ULTRIX-4*] Don't pass -D 08000000 to GNU ld.
-
- * Makefile.in (Makefile): Depend on config.status.
- (config.status): New target.
-
- * configure: Regenerated.
- * configure.in: Use -fPIC, not -fpic, when using gcc.
-
-Fri Aug 2 10:33:52 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure.in: Don't put body of HP-UX case in AC_CHECK_LIB;
- instead do check separately.
-
- * tclUnixInit.c: Don't include <sys/utsname.h>; that is done by
- tclUnixPort.h.
-
- * configure: Regenerated.
- * configure.in: Check for -ldld before using it.
-
-Mon Jul 22 17:19:10 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * tclUnixInit.c (initScript): Handle location independence.
-
-Sun Jul 14 14:46:51 1996 Michael Meissner <meissner@tiktok.cygnus.com>
-
- * tclUnixStr.c (Tcl_Errno{Id,Msg}): Handle new versions of Linux
- that define EDEADLK and EDEADLOCK as the same.
-
-Wed Jun 26 12:37:05 1996 Jason Molenda (crash@godzilla.cygnus.co.jp)
-
- * Makefile.in (TCL_LIBRARY, LIB_INSTALL_DIR, BIN_INSTALL_DIR,
- INCLUDE_INSTALL_DIR, MAN_INSTALL_DIR, INSTALL_PROGRAM,
- INSTALL_DATA): Use autoconf-set values.
- (install-libraries): Use @datadir@ instead of hard-coding dirname.
- * configure.in (AC_PREREQ): autoconf 2.5 or higher.
- (AC_PROG_INSTALL): Add.
- * configure: Rebuilt.
- * dltest/configure.in (AC_PREREQ): autoconf 2.5 or higher.
- * dltest/configure: Rebuilt.
-
-Mon Jun 10 16:21:21 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (install-binaries): Don't add version info to
- installed tclsh.
-
-Tue Jun 4 17:57:10 1996 Gordon Irlam <gordoni@snuffle.cygnus.com>
-
- * install-sh: Add MIT copyright.
-
-Tue May 21 10:13:37 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure: Regenerated.
- * aclocal.m4: Typo fix.
-
-Thu May 16 09:50:12 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure: Regenerated.
- * configure.in: Removed AC_CANONICAL_SYSTEM, AC_CONFIG_AUX_DIR.
- Use CY_AC_C_WORKS instead of CY_AC_C_CROSS.
- * aclocal.m4: Replaced CY_AC_C_CROSS with CY_AC_C_WORKS.
-
-Thu May 9 10:01:31 1996 Tom Tromey <tromey@snuffle.cygnus.com>
-
- * Makefile.in (CFLAGS): Set to @CFLAGS@.
-
-Mon May 6 20:54:10 1996 Fred Fish <fnf@cygnus.com>
-
- * findself.c (find_self): Test argv0 for NULL before
- dereferencing it.
-
-Mon May 6 11:27:52 1996 Tom Tromey <tromey@lisa.cygnus.com>
-
- * Makefile.in (install-man): Install man pages in section 3, not
- section n.
-
- * mkLinks: Use cp, not ln.
-
-Mon May 6 11:27:52 1996 Tom Tromey <tromey@lisa.cygnus.com>
-
- * findself.c (find_self_base): Changed expected location of
- arch-specific info.
-
-Fri May 3 08:36:01 1996 Tom Tromey <tromey@lisa.cygnus.com>
-
- * Makefile.in: Moved html generation into devo/inet.
-
-Thu May 2 23:47:32 1996 Michael Meissner <meissner@tiktok.cygnus.com>
-
- * Makefile.in (install-html): Create html directory if it isn't
- already created.
-
-Thu May 2 10:09:25 1996 Tom Tromey <tromey@lisa.cygnus.com>
-
- * findself.c (cache_valid): New global.
- (find_self_base): Allow caching of NULL. Ensure that stripped
- components have correct names for scheme.
-
- * findself.c: Don't include <stdlib.h> in Tcl case.
-
-Wed May 1 12:51:50 1996 Tom Tromey <tromey@lisa.cygnus.com>
-
- * Makefile.in (html): New target.
- (install-html): New target.
- (install): Depend on install-html.
- (stamp-html): new target.
- (all): Depend on html.
- (TCL_HTML_DIR): New macro.
- (install-html): Use it.
-
-Wed May 1 09:09:13 1996 Tom Tromey <tromey@snuffle.cygnus.com>
-
- * findself.c: Include <stdlib.h> whenever possible.
- (find_self): Cast result of realpath.
-
-Tue Apr 30 13:39:48 1996 Tom Tromey <tromey@snuffle.cygnus.com>
-
- * findself.c (find_self_base): Strip new "arch" directory from
- prefix.
-
- * tclAppInit.c (main): Removed "-inet-1.0".
-
-Mon Apr 29 16:57:10 1996 Tom Tromey <tromey@snuffle.cygnus.com>
-
- * Makefile.in (install): Install man pages again.
-
- * tclAppInit.c (main): Print version number.
-
- * findself.c (find_self): Now static.
- (find_self): Removed defines.
- (cached_name): Removed.
- (resolved): New static global.
- (find_self_base): Look for INETHOME environment variable.
-
-Tue Apr 23 10:13:32 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (UNIX_SRCS): Added findself.c.
- (UNIX_OBJS): Added findself.o.
-
- * configure: Regenerated.
- * configure.in: Look for realpath(). Always define HAVE_GETCWD.
-
- * Makefile.in (TCL_LIB_TRAILER): New macro.
- (CC_SWITCHES): Define TCL_LIB_TRAILER.
-
- * tclUnixInit.c (TclPlatformInit): Handle location independence.
-
- * Makefile.in: Add explicit .c.o dependencies for Sun's VPATH.
- From Doug Evans <dje@cygnus.com>.
-
-Mon Apr 1 23:05:49 1996 Fred Fish <fnf@cygnus.com>
-
- * configure.in (case $system): For HP-UX test $have_dl before
- setting SHLIB_CFLAGS, SHLIB_LD, SHLIB_SUFFIX, DL_OBJS, and DL_LIBS
- * configure: Regenerate.
-
-Fri Mar 29 08:23:00 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * mkLinks: Exit with status 0.
-
-Mon Mar 25 17:01:01 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure.in: Changed most "ac_cv" variables to "tcl_cv";
- otherwise Tcl-specific tests could clobber values in a global
- cache file.
-
-Fri Mar 15 09:03:31 1996 Fred Fish <fnf@cygnus.com>
-
- * configure.in: Some UNIX_SV* systems have linkers that
- don't grok the -Bexport option. Test that it does before
- adding to LD_FLAGS.
- * configure: Regenerated.
-
-Thu Mar 14 14:25:17 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure.in: Check for GNU ld in HP-UX case.
-
-Fri Mar 1 11:45:23 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure: Regenerated.
- * configure.in: Use AC_CANONICAL_SYSTEM. Look in Cygnus build
- tree for config.sub and config.guess.
-
-Thu Feb 29 09:06:59 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (test): Define srcdir in test environment.
-
-Tue Feb 13 13:22:23 1996 Ian Lance Taylor <ian@cygnus.com>
-
- * configure.in: On Solaris, put -export-dynamic in LD_FLAGS if the
- linker supports it.
- * configure: Regenerated.
-
-Thu Feb 1 09:57:19 1996 Tom Tromey (tromey@gerbil.cygnus.com)
-
- * configure.in: Test $CC against *gcc*, not just gcc.
- For now, can't handle dynamic linking on HPUX.
- * configure: Regenerated.
-
-Wed Jan 24 09:41:19 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * dltest/Makefile.in (distclean): Remove config.log, config.cache,
- and config.status here, not in distclean.
- (mostlyclean, maintainer-clean): New targets.
-
- * Makefile.in: Replaced realclean with maintainer-clean.
- (clean): Make clean in dltest directory.
-
-Mon Jan 22 10:08:38 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure.in: Use $?, not $status, to see if uname failed.
- File is named "tclLoadAout.o", not "tclLoadAOut.o".
-
-Fri Jan 19 10:34:22 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (loadTests): Use $(MAKE), not make.
- (distclean): Ditto.
-
- * dltest/Makefile.in (.c.o): New target.
- (VPATH): New macro.
-
- * Makefile.in (check installcheck): Removed.
- (tclTestInit.o): Bug fix.
-
-Wed Jan 17 11:36:40 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (check): Tests are in ../testsuite.
-
-Sat Jan 13 18:41:26 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * tclUnixUtil.c (Tcl_DeleteFileTable): Undid change of Jan 11.
- Added comment explaining why.
-
-Thu Jan 11 14:18:34 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * Makefile.in (tclTestInit.o): Find tclAppInit.c in $(srcdir).
-
- * tclUnixUtil.c (Tcl_DeleteFileTable): Use Tcl_NextHashEntry to
- fetch next element from hash.
-
-Wed Jan 10 10:39:15 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure.in: Instead of giving warning, default to most
- conservative option when cross-compiling.
-
- * Makefile.in (loadTests): Don't depend on dltest/Makefile. Use
- "&&", not ";".
- (dltest/Makefile): Removed.
-
- * configure.in: Always allow use of gcc.
- Create dltest/Makefile.in.
- Cache check for DOS pathnames.
-
-Tue Jan 9 14:29:53 1996 Tom Tromey <tromey@creche.cygnus.com>
-
- * configure.in: Handle Linux machine with no dld.h and no -ldl.
-
- * See ../ChangeLog for entries before this date.
# RCS: @(#) $Id$
VERSION = @TCL_VERSION@
+MAJOR_VERSION = @TCL_MAJOR_VERSION@
+MINOR_VERSION = @TCL_MINOR_VERSION@
+PATCH_LEVEL = @TCL_PATCH_LEVEL@
#----------------------------------------------------------------
# Things you can change to personalize the Makefile for your own
# when installing files.
INSTALL_ROOT =
+# Path for the platform independent Tcl scripting libraries:
+# REDHAT LOCAL
+#TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION)
TCL_LIBRARY = @datadir@/tcl$(VERSION)
+# END REDHAT LOCAL
# Path to use at runtime to refer to LIB_INSTALL_DIR:
LIB_RUNTIME_DIR = $(libdir)
BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir)
# Directory in which to install libtcl.so or libtcl.a:
-LIB_INSTALL_DIR = $(INSTALL_ROOT)@libdir@
+LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir)
# Path name to use when installing library scripts.
SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY)
-# Directory in which to install the program tclsh:
-BIN_INSTALL_DIR = $(INSTALL_ROOT)@bindir@
-
# Directory in which to install the include file tcl.h:
-INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)@includedir@
+INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir)
# Top-level directory in which to install manual entries:
-MAN_INSTALL_DIR = $(INSTALL_ROOT)@mandir@
+MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir)
# Directory in which to install manual entry for tclsh:
MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1
# To change the compiler switches, for example to change from optimization to
# debugging symbols, change the following line:
-#TCL_CFLAGS = $(CFLAGS_DEBUG)
-#TCL_CFLAGS = $(CFLAGS_OPTIMIZE)
-#TCL_CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
-TCL_CFLAGS = @CFLAGS_DEFAULT@
-
-CFLAGS = @CFLAGS@
+#CFLAGS = $(CFLAGS_DEBUG)
+#CFLAGS = $(CFLAGS_OPTIMIZE)
+#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
+CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@
# Flags to pass to the linker
-LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
-LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
-LDFLAGS = @LDFLAGS@ @LDFLAGS_DEFAULT@
+LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
+LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
+LDFLAGS = @LDFLAGS@ @LDFLAGS_DEFAULT@
# To disable ANSI-C procedure prototypes reverse the comment characters
# on the following lines:
# the current one does).
GENERIC_FLAGS =
#GENERIC_FLAGS = -DTCL_GENERIC_ONLY
-UNIX_OBJS = tclMtherr.o tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \
+UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \
tclUnixFile.o tclUnixPipe.o tclUnixSock.o \
tclUnixTime.o tclUnixInit.o tclUnixThrd.o
#UNIX_OBJS =
#NOTIFY_OBJS =
# To enable memory debugging reverse the comment characters on the following
-# lines. Warning: if you enable memory debugging, you must do it
-# *everywhere*, including all the code that calls Tcl, and you must use
-# ckalloc and ckfree everywhere instead of malloc and free.
+# lines or call configure with --enable-symbols=mem
+# Warning: if you enable memory debugging, you must do it *everywhere*,
+# including all the code that calls Tcl, and you must use ckalloc and
+# ckfree everywhere instead of malloc and free.
MEM_DEBUG_FLAGS =
#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG
-# To enable support for stubs in Tcl.
-STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
-
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
#TCL_STUB_LIB_FILE = libtclstub.a
+# Generic stub lib name used in rules that apply to tcl and tk
+STUB_LIB_FILE = ${TCL_STUB_LIB_FILE}
+
TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG = -ltclstub
-# To enable compilation debugging reverse the comment characters on
-# one of the following lines.
+# To enable compilation debugging reverse the comment characters on one
+# of the following lines or call configure with --enable-symbols=compile
COMPILE_DEBUG_FLAGS =
-#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_STATS
#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
# To compile without backward compatibility and deprecated code
# Some versions of make, like SGI's, use the following variable to
# determine which shell to use for executing commands:
-SHELL = @SHELL@
+SHELL = /bin/sh
# Tcl used to let the configure script choose which program to use
# for installing, but there are just too many different versions of
# "install" around; better to use the install-sh script that comes
# with the distribution, which is slower but guaranteed to work.
-INSTALL = @srcdir@/install-sh -c
-INSTALL_PROGRAM = @INSTALL_PROGRAM@
-INSTALL_DATA = @INSTALL_DATA@
-
-# The following symbol defines additional compiler flags to enable
-# Tcl itself to be a shared library. If Tcl isn't going to be a
-# shared library then the symbol has an empty definition.
-
-TCL_SHLIB_CFLAGS = @TCL_SHLIB_CFLAGS@
-#TCL_SHLIB_CFLAGS =
-
-# The following symbol defines additional compiler flags to enable
-# writable strings, since Tcl_Eval2 writes into its arguments. Only
-# applicable for GCC
+INSTALL_STRIP_PROGRAM = -s
+INSTALL_STRIP_LIBRARY = -S -S
INSTALL = @srcdir@/install-sh -c
INSTALL_PROGRAM = ${INSTALL}
+INSTALL_LIBRARY = ${INSTALL}
INSTALL_DATA = ${INSTALL} -m 644
-# The following specifies which Tcl executable to use for make targets
-# below. This can generally be 'tclsh', meaning all targets will work
-# once we have created the initial executable, but in some cases you
-# may want to use a target without having made tclsh on these sources
-# (like for make genstubs)
+# TCL_EXE is the name of a tclsh executable that is available *BEFORE*
+# running make for the first time. Certain build targets (make genstubs)
+# need it to be available on the PATH. This executable should *NOT* be
+# required just to do a normal build although it can be required to run
+# make dist.
TCL_EXE = tclsh
# The symbols below provide support for dynamic loading and shared
# configure script. You shouldn't normally need to modify any of
# these definitions by hand.
-STLIB_LD = @STLIB_LD@
-SHLIB_LD = @SHLIB_LD@
-SHLIB_CFLAGS = @SHLIB_CFLAGS@
+STLIB_LD = @STLIB_LD@
+SHLIB_LD = @SHLIB_LD@
+SHLIB_CFLAGS = @SHLIB_CFLAGS@
+SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@
+SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
+TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@
-SHLIB_SUFFIX = @SHLIB_SUFFIX@
-#SHLIB_SUFFIX =
+SHLIB_SUFFIX = @SHLIB_SUFFIX@
+#SHLIB_SUFFIX =
-TCL_SHARED_LIB_SUFFIX = @TCL_SHARED_LIB_SUFFIX@
-TCL_UNSHARED_LIB_SUFFIX = @TCL_UNSHARED_LIB_SUFFIX@
-TCL_SHARED_LIB_FILE = @TCL_SHARED_LIB_FILE@
-TCL_UNSHARED_LIB_FILE = @TCL_UNSHARED_LIB_FILE@
+DLTEST_TARGETS = dltest.marker
-DLTEST_TARGETS = dltest/pkg5${SHLIB_SUFFIX} dltest/Makefile
+# Additional search flags needed to find the various shared libraries
+# at run-time. The first symbol is for use when creating a binary
+# with cc, and the second is for use when running ld directly.
+CC_SEARCH_FLAGS = @CC_SEARCH_FLAGS@
+LD_SEARCH_FLAGS = @LD_SEARCH_FLAGS@
# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic
# loading is available; this causes everything in the "dltest"
TCL_LIB_FILE = @TCL_LIB_FILE@
#TCL_LIB_FILE = libtcl.a
+# Generic lib name used in rules that apply to tcl and tk
+LIB_FILE = ${TCL_LIB_FILE}
+
TCL_LIB_FLAG = @TCL_LIB_FLAG@
#TCL_LIB_FLAG = -ltcl
TCL_EXP_FILE = @TCL_EXP_FILE@
TCL_BUILD_EXP_FILE = @TCL_BUILD_EXP_FILE@
+# support for embedded libraries on Darwin / Mac OS X
+DYLIB_INSTALL_DIR = ${LIB_RUNTIME_DIR}
+
#----------------------------------------------------------------
# The information below is modified by the configure script when
# Makefile is generated from Makefile.in. You shouldn't normally
AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@
AR = @AR@
-TCL_RANLIB = @RANLIB@
+RANLIB = @RANLIB@
SRC_DIR = @srcdir@
TOP_DIR = @srcdir@/..
GENERIC_DIR = $(TOP_DIR)/generic
COMPAT_DIR = $(TOP_DIR)/compat
TOOL_DIR = $(TOP_DIR)/tools
UNIX_DIR = $(TOP_DIR)/unix
+MAC_OSX_DIR = $(TOP_DIR)/macosx
# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below.
DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library
-#CC = purify -best-effort @CC@
CC = @CC@
+#CC = purify -best-effort @CC@ -DPURIFY
+
+# Flags to be passed to mkLinks to control whether the manpages
+# should be compressed and linked with softlinks
+MKLINKS_FLAGS = @MKLINKS_FLAGS@
+
+#----------------------------------------------------------------
+# The information below is usually usable as is. The configure
+# script won't modify it and it only exists to make working
+# around selected rare system configurations easier.
+#----------------------------------------------------------------
+
+GDB = gdb
+DDD = ddd
#----------------------------------------------------------------
# The information below should be usable as is. The configure
#----------------------------------------------------------------
-CC_SWITCHES = ${CFLAGS} ${TCL_CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
+CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${GENERIC_DIR} -I${SRC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \
${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} \
-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\"
-STUB_CC_SWITCHES = ${CFLAGS} ${TCL_CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
+STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${GENERIC_DIR} -I${SRC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \
${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\"
-LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS) -lc
+LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS)
DEPEND_SWITCHES = ${CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} \
tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPipe.o \
tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStringObj.o tclThread.o \
- tclStubInit.o tclStubLib.o tclTimer.o tclUtf.o tclUtil.o tclVar.o
+ tclThreadAlloc.o tclThreadJoin.o tclStubInit.o tclStubLib.o \
+ tclTimer.o tclUtf.o tclUtil.o tclVar.o
STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS}
-OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} @DL_OBJS@
+OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
+ @DL_OBJS@ @PLAT_OBJS@
TCL_DECLS = \
$(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclTestObj.c \
$(GENERIC_DIR)/tclTestProcBodyObj.c \
$(GENERIC_DIR)/tclThread.c \
+ $(GENERIC_DIR)/tclThreadAlloc.c \
+ $(GENERIC_DIR)/tclThreadJoin.c \
$(GENERIC_DIR)/tclTimer.c \
$(GENERIC_DIR)/tclUtil.c \
$(GENERIC_DIR)/tclVar.c
UNIX_SRCS = \
$(UNIX_DIR)/tclAppInit.c \
- $(UNIX_DIR)/tclMtherr.c \
$(UNIX_DIR)/tclUnixChan.c \
$(UNIX_DIR)/tclUnixEvent.c \
$(UNIX_DIR)/tclUnixFCmd.c \
$(UNIX_DIR)/tclLoadOSF.c \
$(UNIX_DIR)/tclLoadShl.c
-# Note: don't include DL_SRCS in SRCS: most of those files won't
-# compile on the current machine, and they will cause problems for
-# things like "make depend".
+MAC_OSX_SRCS = \
+ $(MAC_OSX_DIR)/tclMacOSXBundle.c
+
+# Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those
+# files won't compile on the current machine, and they will cause
+# problems for things like "make depend".
SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(STUB_SRCS)
all: binaries libraries doc
-binaries: ${TCL_LIB_FILE} $(TCL_STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh
+binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh
libraries:
# The following target is configured by autoconf to generate either
# a shared library or non-shared library for Tcl.
-${TCL_LIB_FILE}: ${OBJS} ${STUB_LIB_FILE}
- rm -f ${TCL_LIB_FILE}
+${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE}
+ rm -f $@
@MAKE_LIB@
- $(TCL_RANLIB) ${TCL_LIB_FILE}
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
- rm -f ${STUB_LIB_FILE}
+ rm -f $@
@MAKE_STUB_LIB@
- $(TCL_RANLIB) ${STUB_LIB_FILE}
# Make target which outputs the list of the .o contained in the Tcl lib
# usefull to build a single big shared library containing Tcl and other
tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
${CC} ${LDFLAGS} ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
- @TCL_LD_SEARCH_FLAGS@ -o tclsh
+ ${CC_SEARCH_FLAGS} -o tclsh
+
+# Resetting the LIB_RUNTIME_DIR below is required so that
+# the generated tcltest executable gets the build directory
+# burned into its ld search path. This keeps tcltest from
+# picking up an already installed version of the Tcl library.
tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST}
- ${CC} ${LDFLAGS} ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
- @TCL_LD_SEARCH_FLAGS@ -o tcltest
+ $(MAKE) tcltest-real LIB_RUNTIME_DIR=`pwd`
+tcltest-real:
+ ${CC} ${LDFLAGS} ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} \
+ ${CC_SEARCH_FLAGS} -o tcltest
# Note, in the target below TCL_LIBRARY needs to be set or else
# "make test" won't work in the case where the compilation directory
# isn't the same as the source directory.
+# Specifying TESTFLAGS on the command line is the standard way to pass
+# args to tcltest, ie:
+# % make test TESTFLAGS="-verbose bps -file fileName.test"
test: tcltest
- LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \
- LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
- SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
+ @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
- ./tcltest $(TOP_DIR)/tests/all.tcl $(TCLTESTARGS)
+ ./tcltest $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) $(TCLTESTARGS)
# Useful target to launch a built tcltest with the proper path,...
runtest: tcltest
- LD_LIBRARY_PATH=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \
- LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
- SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
+ @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
./tcltest
+# Useful target for running the test suite with an unwritable current
+# directory...
+ro-test: tcltest
+ @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
+ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
+ echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | ./tcltest
+
+# This target can be used to run tclsh from the build directory
+# via `make shell SCRIPT=/tmp/foo.tcl`
+shell: tclsh
+ @@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
+ TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
+ ./tclsh $(SCRIPT)
+
+# This target can be used to run tclsh inside either gdb or insight
+gdb: tclsh
+ @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run
+ @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
+ $(GDB) ./tclsh --command=gdb.run
+ rm gdb.run
+
+# This target can be used to run tclsh inside ddd
+ddd: tclsh
+ @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}" > gdb.run
+ @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
+ $(DDD) -command=gdb.run ./tclsh
+ rm gdb.run
+
# The following target outputs the name of the top-level source directory
# for Tcl (it is used by Tk's configure script, for example). The
# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake".
gendate:
yacc -l $(GENERIC_DIR)/tclGetDate.y
sed -e 's/yy/TclDate/g' -e '/^#include <values.h>/d' \
- -e 's?SCCSID?RCS: @(#) $$Id$$?' \
+ -e 's?SCCSID?RCS: @(#) ?' \
-e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
-e '/TclDatenewstate:/d' -e '/#pragma/d' \
-e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \
<y.tab.c >$(GENERIC_DIR)/tclDate.c
rm y.tab.c
-# The following targets generate the shared libraries in dltest that
+# The following target generates the shared libraries in dltest/ that
# are used for testing; they are included as part of the "tcltest"
# target (via the BUILD_DLTEST variable) if dynamic loading is supported
-# on this platform. The ".." environment variable stuff is needed
-# because on some platforms tclsh scripts will be executed as part of
-# building the shared libraries, and they need to be able to use the
-# uninstalled tclsh that is present in this directory. The "make tclsh"
-# command is needed for the same reason (must make sure that it exists).
-
-dltest/pkg5${SHLIB_SUFFIX}: dltest/Makefile
- if test ! -f tclsh; then $(MAKE) tclsh; else true; fi
- libdir=`cd $(TOP_DIR)/library && pwd`; cd dltest; \
- PATH=..:${PATH} TCL_LIBRARY=$$libdir $(MAKE)
-
-dltest/Makefile: $(DLTEST_DIR)/configure $(DLTEST_DIR)/Makefile.in tclConfig.sh
- if test ! -d dltest; then mkdir dltest; else true; fi
- dldir=`cd $(DLTEST_DIR) && pwd`; cd dltest; \
- if test -f configure; then ./configure; else $$dldir/configure; fi
+# on this platform. The Makefile in the dltest subdirectory creates
+# the dltest.marker file in this directory after a successful build.
+
+dltest.marker:
+ cd dltest ; $(MAKE)
install: install-binaries install-libraries install-doc
install-strip:
- $(MAKE) install INSTALL_PROGRAM="$(INSTALL_PROGRAM) -s"
+ $(MAKE) install \
+ INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
+ INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}"
# Note: before running ranlib below, must cd to target directory because
# some ranlibs write to current directory, and this might not always be
@if test ! -x $(SRC_DIR)/install-sh; then \
chmod +x $(SRC_DIR)/install-sh; \
fi
- @echo "Installing $(TCL_LIB_FILE) to $(LIB_INSTALL_DIR)/"
- @$(INSTALL_DATA) $(TCL_LIB_FILE) $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE)
- @(cd $(LIB_INSTALL_DIR); $(TCL_RANLIB) $(TCL_LIB_FILE))
- @chmod 555 $(LIB_INSTALL_DIR)/$(TCL_LIB_FILE)
+ @echo "Installing $(LIB_FILE) to $(LIB_INSTALL_DIR)/"
+ @@INSTALL_LIB@
+ @chmod 555 $(LIB_INSTALL_DIR)/$(LIB_FILE)
@if test "$(TCL_BUILD_EXP_FILE)" != ""; then \
echo "Installing $(TCL_EXP_FILE) to $(LIB_INSTALL_DIR)/"; \
$(INSTALL_DATA) $(TCL_BUILD_EXP_FILE) \
@$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION)
@echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/"
@$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
- @if test "$(TCL_STUB_LIB_FILE)" != "" ; then \
- echo "Installing $(TCL_STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
- $(INSTALL_DATA) $(STUB_LIB_FILE) \
- $(LIB_INSTALL_DIR)/$(TCL_STUB_LIB_FILE); \
- fi
+ @if test "$(STUB_LIB_FILE)" != "" ; then \
+ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
+ @INSTALL_STUB_LIB@ ; \
+ fi
-install-libraries:
- @for i in $(INSTALL_ROOT)@datadir@ $(INCLUDE_INSTALL_DIR) \
- $(SCRIPT_INSTALL_DIR) ; \
+install-libraries: libraries
+ @for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \
do \
if [ ! -d $$i ] ; then \
echo "Making directory $$i"; \
else true; \
fi; \
done;
- @for i in http2.3 http1.0 opt0.4 encoding msgcat1.0 tcltest1.0; \
+ @for i in http2.4 http1.0 opt0.4 encoding msgcat1.3 tcltest2.2; \
do \
if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
chmod +x $(SRC_DIR)/install-sh; \
fi
@echo "Installing header files";
- @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h ; \
+ @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \
+ $(GENERIC_DIR)/tclPlatDecls.h ; \
do \
$(INSTALL_DATA) $$i $(INCLUDE_INSTALL_DIR); \
done;
do \
$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \
done;
- @for i in http2.3 http1.0 opt0.4 msgcat1.0 tcltest1.0; \
+ @echo "Installing library http1.0 directory";
+ @for j in $(TOP_DIR)/library/http1.0/*.tcl ; \
do \
- echo "Installing library $$i directory"; \
- for j in $(TOP_DIR)/library/$$i/*.tcl ; \
- do \
- $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/$$i; \
- done; \
+ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \
+ done;
+ @echo "Installing library http2.4 directory";
+ @for j in $(TOP_DIR)/library/http/*.tcl ; \
+ do \
+ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.4; \
+ done;
+ @echo "Installing library opt0.4 directory";
+ @for j in $(TOP_DIR)/library/opt/*.tcl ; \
+ do \
+ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/opt0.4; \
+ done;
+ @echo "Installing library msgcat1.3 directory";
+ @for j in $(TOP_DIR)/library/msgcat/*.tcl ; \
+ do \
+ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/msgcat1.3; \
+ done;
+ @echo "Installing library tcltest2.2 directory";
+ @for j in $(TOP_DIR)/library/tcltest/*.tcl ; \
+ do \
+ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/tcltest2.2; \
done;
@echo "Installing library encoding directory";
@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
rm -f $(MAN1_INSTALL_DIR)/$$i; \
sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
$$i > $(MAN1_INSTALL_DIR)/$$i; \
- chmod 644 $(MAN1_INSTALL_DIR)/$$i; \
+ chmod 444 $(MAN1_INSTALL_DIR)/$$i; \
done;
@echo "Cross-linking top-level (.1) docs";
- @$(UNIX_DIR)/mkLinks $(MAN1_INSTALL_DIR)
+ @$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MAN1_INSTALL_DIR)
@echo "Installing C API (.3) docs";
@cd $(TOP_DIR)/doc; for i in *.3; \
do \
rm -f $(MAN3_INSTALL_DIR)/$$i; \
sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
$$i > $(MAN3_INSTALL_DIR)/$$i; \
- chmod 644 $(MAN3_INSTALL_DIR)/$$i; \
+ chmod 444 $(MAN3_INSTALL_DIR)/$$i; \
done;
@echo "Cross-linking C API (.3) docs";
- @$(UNIX_DIR)/mkLinks $(MAN3_INSTALL_DIR)
+ @$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MAN3_INSTALL_DIR)
@echo "Installing command (.n) docs";
@cd $(TOP_DIR)/doc; for i in *.n; \
do \
rm -f $(MANN_INSTALL_DIR)/$$i; \
sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
- $$i > $(MAN3_INSTALL_DIR)/$$i; \
- chmod 644 $(MAN3_INSTALL_DIR)/$$i; \
+ $$i > $(MANN_INSTALL_DIR)/$$i; \
+ chmod 444 $(MANN_INSTALL_DIR)/$$i; \
done;
@echo "Cross-linking command (.n) docs";
- @$(UNIX_DIR)/mkLinks $(MANN_INSTALL_DIR)
+ @$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MANN_INSTALL_DIR)
-Makefile: $(UNIX_DIR)/Makefile.in config.status
+Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
$(SHELL) config.status
-config.status: $(UNIX_DIR)/configure
- ./config.status --recheck
-
-mostlyclean: clean
clean:
rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
errors tclsh tcltest lib.exp
- if test -f dltest/Makefile; then cd dltest; $(MAKE) clean; fi
+ cd dltest ; $(MAKE) clean
distclean: clean
rm -rf Makefile config.status config.cache config.log tclConfig.sh \
$(PACKAGE).* prototype
- if test -f dltest/Makefile; then cd dltest; $(MAKE) distclean; fi
+ cd dltest ; $(MAKE) distclean
depend:
makedepend -- $(DEPEND_SWITCHES) -- $(SRCS)
-bp: $(UNIX_DIR)/bp.c
- $(CC) $(CC_SWITCHES) $(UNIX_DIR)/bp.c -o bp
-
# Test binaries. The rules for tclTestInit.o and xtTestInit.o are
# complicated because they are compiled from tclAppInit.c. Can't use
# the "-o" option because this doesn't work on some strange compilers
tclMain.o: $(GENERIC_DIR)/tclMain.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclMain.c
-tclMtherr.o: $(UNIX_DIR)/tclMtherr.c
- $(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclMtherr.c
-
tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c
tclUtil.o: $(GENERIC_DIR)/tclUtil.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c
-tclUtf.o: $(GENERIC_DIR)/tclUtf.c
+tclUtf.o: $(GENERIC_DIR)/tclUtf.c $(GENERIC_DIR)/tclUniData.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtf.c
tclVar.o: $(GENERIC_DIR)/tclVar.c
tclThread.o: $(GENERIC_DIR)/tclThread.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThread.c
+tclThreadAlloc.o: $(GENERIC_DIR)/tclThreadAlloc.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadAlloc.c
+
+tclThreadJoin.o: $(GENERIC_DIR)/tclThreadJoin.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadJoin.c
+
tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c
tclUnixTime.o: $(UNIX_DIR)/tclUnixTime.c
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c
-# CYGNUS LOCAL
+# REDHAT LOCAL
# Don't burn a TCL_LIBRARY path into tclUnixInit.o.
# We need Tcl to be location independent and a compiled
# dir name appears on the auto_path after the tree
# has been moved.
-# END CYGNUS LOCAL
+# END REDHAT LOCAL
tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c $(GENERIC_DIR)/tclInitScript.h tclConfig.sh
$(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"\" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \
$(UNIX_DIR)/tclUnixInit.c
+# This is the CFBundle interface. It is only used on Mac OS X.
+tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c
+ $(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c
+
# The following targets are not completely general. They are provide
# purely for documentation purposes so people who are interested in
# the Xt based notifier can modify them to suit their own installation.
@DL_OBJS@ ${BUILD_DLTEST}
${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
@DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \
- @TCL_LD_SEARCH_FLAGS@ -L/usr/openwin/lib -lXt -o xttest
+ ${CC_SEARCH_FLAGS} -L/usr/openwin/lib -lXt -o xttest
tclXtNotify.o: $(UNIX_DIR)/tclXtNotify.c
$(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \
fixstrtod.o: $(COMPAT_DIR)/fixstrtod.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/fixstrtod.c
-getcwd.o: $(COMPAT_DIR)/getcwd.c
- $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/getcwd.c
-
opendir.o: $(COMPAT_DIR)/opendir.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/opendir.c
strtol.o: $(COMPAT_DIR)/strtol.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtol.c
+strtoll.o: $(COMPAT_DIR)/strtoll.c
+ $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtoll.c
+
strtoul.o: $(COMPAT_DIR)/strtoul.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtoul.c
+strtoull.o: $(COMPAT_DIR)/strtoull.c
+ $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/strtoull.c
+
tmpnam.o: $(COMPAT_DIR)/tmpnam.c
$(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/tmpnam.c
$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls
- $(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
- $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls
+ @echo "Warning: tclStubInit.c may be out of date."
+ @echo "Developers may want to run \"make genstubs\" to regenerate."
+ @echo "This warning can be safely ignored, do not report as a bug!"
genstubs:
$(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
done
#
+# Target to check that all public APIs which are not command
+# implementations have an entry in section three of the distributed
+# manpages.
+#
+
+checkdoc:
+ -@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
+ | grep -v 'Cmd$$' | sort -n`; do \
+ match=0; \
+ for j in $(TOP_DIR)/doc/*.3; do \
+ if [ `grep '\-' $$j | grep -c $$i` -gt 0 ]; then \
+ match=1; \
+ fi; \
+ done; \
+ if [ $$match -eq 0 ]; then echo $$i; fi \
+ done
+
+#
# Target to check for proper usage of UCHAR macro.
#
mv RPMS/i386/*.rpm .
rm -rf RPMS THIS.TCL.SPEC
+mklinks:
+ $(TCL_EXE) $(UNIX_DIR)/mkLinks.tcl \
+ $(UNIX_DIR)/../doc/*.[13n] > $(UNIX_DIR)/mkLinks
+ chmod +x $(UNIX_DIR)/mkLinks
+
#
# Target to create a proper Tcl distribution from information in the
# master source directory. DISTDIR must be defined to indicate where
# to put the distribution.
#
-DISTROOT = /tmp/dist
-DISTNAME = tcl@TCL_VERSION@@TCL_PATCH_LEVEL@
-ZIPNAME = tcl@TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@@TCL_PATCH_LEVEL@.zip
-DISTDIR = $(DISTROOT)/$(DISTNAME)
+DISTROOT = /tmp/dist
+DISTNAME = tcl${VERSION}${PATCH_LEVEL}
+ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
+DISTDIR = $(DISTROOT)/$(DISTNAME)
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in
autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure
-dist: $(UNIX_DIR)/configure
+
+dist: $(UNIX_DIR)/configure mklinks
rm -rf $(DISTDIR)
- mkdir $(DISTDIR)
- mkdir $(DISTDIR)/unix
+ mkdir -p $(DISTDIR)/unix
cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix
- rm -f $(DISTDIR)/unix/bp.c
cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
chmod 664 $(DISTDIR)/unix/Makefile.in
cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \
$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
$(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/install-sh \
$(UNIX_DIR)/README $(UNIX_DIR)/ldAix $(UNIX_DIR)/tcl.spec \
+ $(UNIX_DIR)/mkLinks \
$(DISTDIR)/unix
chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in
chmod 775 $(DISTDIR)/unix/ldAix
chmod +x $(DISTDIR)/unix/install-sh
-
- $(TCL_EXE) $(UNIX_DIR)/mkLinks.tcl \
- $(UNIX_DIR)/../doc/*.[13n] > $(DISTDIR)/unix/mkLinks
- chmod +x $(DISTDIR)/unix/mkLinks
mkdir $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README* \
- $(TOP_DIR)/license.terms $(DISTDIR)
+ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \
+ $(DISTDIR)
mkdir $(DISTDIR)/library
cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
- for i in http2.3 http1.0 opt0.4 msgcat1.0 reg1.0 dde1.1 tcltest1.0; \
+ for i in http1.0 http opt msgcat reg dde tcltest; \
do \
mkdir $(DISTDIR)/library/$$i ;\
cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
$(DISTDIR)/tests
- mkdir $(DISTDIR)/tests/pkg
- cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests/pkg
- cp -p $(TOP_DIR)/tests/pkg/*.tcl $(DISTDIR)/tests/pkg
mkdir $(DISTDIR)/win
cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
- cp $(TOP_DIR)/win/configure.in \
- $(TOP_DIR)/win/configure \
+ cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \
$(TOP_DIR)/win/tclConfig.sh.in \
$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \
$(DISTDIR)/win
- cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h $(TOP_DIR)/win/*.rc \
- $(TOP_DIR)/win/*.ico $(DISTDIR)/win
+ cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h \
+ $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \
+ $(DISTDIR)/win
cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win
+ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/*.bat
cp -p $(TOP_DIR)/win/makefile.* $(DISTDIR)/win
+ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/makefile.*
+ cp -p $(TOP_DIR)/win/rules.vc $(DISTDIR)/win
+ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/rules.vc
+ cp -p $(TOP_DIR)/win/coffbase.txt $(DISTDIR)/win
+ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/coffbase.txt
+ cp -p $(TOP_DIR)/win/tcl.hpj.in $(DISTDIR)/win
+ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.hpj.in
+ cp -p $(TOP_DIR)/win/tcl.ds* $(DISTDIR)/win
+ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/win/tcl.ds*
cp -p $(TOP_DIR)/win/README $(DISTDIR)/win
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/win
mkdir $(DISTDIR)/mac
- cp -p $(TOP_DIR)/mac/tclMacProjects.sea.hqx $(DISTDIR)/mac
- cp -p $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \
+ cp -p $(TOP_DIR)/mac/tcl*.sea.hqx \
+ $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \
$(DISTDIR)/mac
cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac
- cp -p $(TOP_DIR)/mac/*.exp $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac
- cp -p $(TOP_DIR)/mac/*.doc $(DISTDIR)/mac
- cp -p $(TOP_DIR)/mac/*.html $(DISTDIR)/mac
+ cp -p $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac
+ cp -p $(TOP_DIR)/mac/*.doc $(TOP_DIR)/mac/*.html $(DISTDIR)/mac
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac
+ mkdir $(DISTDIR)/macosx
+ cp -p $(TOP_DIR)/macosx/Makefile \
+ $(TOP_DIR)/macosx/*.c \
+ $(DISTDIR)/macosx
+ mkdir $(DISTDIR)/macosx/Tcl.pbproj
+ cp -p $(TOP_DIR)/macosx/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj
mkdir $(DISTDIR)/unix/dltest
cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \
+ $(UNIX_DIR)/dltest/README \
$(DISTDIR)/unix/dltest
- cp -p $(UNIX_DIR)/dltest/configure.in $(UNIX_DIR)/dltest/configure \
- $(UNIX_DIR)/dltest/README $(DISTDIR)/unix/dltest
mkdir $(DISTDIR)/tools
- cp -p $(TOP_DIR)/tools/Makefile.in \
- $(TOP_DIR)/tools/README \
- $(TOP_DIR)/tools/configure.in \
- $(TOP_DIR)/tools/*.tcl \
- $(TOP_DIR)/tools/man2tcl.c \
- $(TOP_DIR)/tools/tcl.wse.in \
- $(TOP_DIR)/tools/*.bmp \
- $(TOP_DIR)/tools/tcl.hpj.in \
+ cp -p $(TOP_DIR)/tools/Makefile.in $(TOP_DIR)/tools/README \
+ $(TOP_DIR)/tools/configure $(TOP_DIR)/tools/configure.in \
+ $(TOP_DIR)/tools/*.tcl $(TOP_DIR)/tools/man2tcl.c \
+ $(TOP_DIR)/tools/tcl.wse.in $(TOP_DIR)/tools/*.bmp \
+ $(TOP_DIR)/tools/tcl.hpj.in \
$(DISTDIR)/tools
+ $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \
+ $(DISTDIR)/tools/tcl.wse.in
#
# The following target can only be used for non-patch releases. Use
#
alldist: dist
- rm -f $(DISTROOT)/$(DISTNAME).tar.Z \
- $(DISTROOT)/$(DISTNAME).tar.gz \
- $(DISTROOT)/$(ZIPNAME)
- cd $(DISTROOT); tar cf $(DISTNAME).tar $(DISTNAME); \
- gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \
- compress $(DISTNAME).tar; zip -qr8 $(ZIPNAME) $(DISTNAME)
+ rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME)
+ cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \
+ gzip -9 $(DISTNAME)-src.tar; zip -qr8 $(ZIPNAME) $(DISTNAME)
#
# The target below is similar to "alldist" except it works for patch
#
allpatch: dist
- rm -f $(DISTROOT)/$(DISTNAME).tar.Z \
- $(DISTROOT)/$(DISTNAME).tar.gz \
- $(DISTROOT)/$(ZIPNAME)
+ rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME)
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/old
mv $(DISTROOT)/$(DISTNAME) $(DISTROOT)/tcl${VERSION}
- cd $(DISTROOT); tar cf $(DISTNAME).tar tcl${VERSION}; \
- gzip -9 -c $(DISTNAME).tar > $(DISTNAME).tar.gz; \
- compress $(DISTNAME).tar; zip -r8 $(ZIPNAME) tcl${VERSION}
+ cd $(DISTROOT); tar cf $(DISTNAME)-src.tar tcl${VERSION}; \
+ gzip -9 $(DISTNAME)-src.tar; zip -r8 $(ZIPNAME) tcl${VERSION}
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME)
mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION}
Tcl UNIX README
---------------
+RCS: @(#) $Id$
+
This is the directory where you configure, compile, test, and install
UNIX versions of Tcl. This directory also contains source files for Tcl
that are specific to UNIX. Some of the files in this directory are
(POSIX/ANSI C) interfaces and some of them only make sense under UNIX.
Updated forms of the information found in this file is available at:
- http://dev.scriptics.com/doc/howto/compile.html#unix
+ http://www.tcl.tk/doc/howto/compile.html#unix
For information on platforms where Tcl is known to compile, along
with any porting notes for getting it to work on those platforms, see:
- http://dev.scriptics.com/software/tcltk/platforms.html
+ http://www.tcl.tk/software/tcltk/platforms.html
The rest of this file contains instructions on how to do this. The
release should compile and run either "out of the box" or with trivial
a PC running Windows, see the README file in the directory ../win. To
compile for a Macintosh, see the README file in the directory ../mac.
-RCS: @(#) $Id$
-
How To Compile And Install Tcl:
-------------------------------
-(a) Check for patches as described in ../README.
-
-(b) If you have already compiled Tcl once in this directory and are now
+(a) If you have already compiled Tcl once in this directory and are now
preparing to compile again in the same directory but for a different
platform, or if you have applied patches, type "make distclean" to
discard all the configuration information computed previously.
-(c) If there is no "configure" script in this directory it is because you
- are working out of the source repository (i.e., CVS) instead of working
- from a source distribution. In this case you need to use "autoconf"
- to generate the configure script. It runs with no arguments.
- Remember to run it here and down in the dltest directory.
+(b) If you need to reconfigure because you changed any of the .in or
+ .m4 files, you will need to run autoconf to create a new
+ ./configure script. Most users will NOT need to do this since
+ a configure script is already provided.
(in the tcl/unix directory)
autoconf
- cd dltest ; autoconf ; cd ..
-(d) Type "./configure". This runs a configuration script created by GNU
+(c) Type "./configure". This runs a configuration script created by GNU
autoconf, which configures Tcl for your system and creates a
Makefile. The configure script allows you to customize the Tcl
configuration for your site; for details on how you can do this,
type "./configure -help" or refer to the autoconf documentation (not
included here). Tcl's "configure" supports the following special
switches in addition to the standard ones:
- --enable-gcc If this switch is set, Tcl will configure
- itself to use gcc if it is available on your
- system. Note: it is not safe to modify the
- Makefile to use gcc after configure is run;
- if you do this, then information related to
- dynamic linking will be incorrect.
--enable-threads If this switch is set, Tcl will compile
itself with multithreading support.
--disable-load If this switch is specified then Tcl will
how to build shared libraries.
--disable-shared If this switch is specified, Tcl will compile
itself as a static library.
+ --enable-symbols build with debugging symbols. By default
+ standard debugging symbols are used. You
+ can specify the value "mem" to include
+ TCL_MEM_DEBUG memory debugging, "compile"
+ to include TCL_COMPILE_DEBUG debugging, or
+ "all" to enable all internal debugging.
+ --disable-symbols build without debugging symbols
+ --enable-64bit enable 64bit support (where applicable)
+ --disable-64bit disable 64bit support (where applicable)
+ --enable-64bit-vis enable 64bit Sparc VIS support
+ --disable-64bit-vis disable 64bit Sparc VIS support
+ --enable-langinfo Allows use of modern nl_langinfo check for
+ better localization support. This is on by
+ default on platforms where nl_langinfo is
+ found.
+ --disable-langinfo Specifically disables use of nl_langinfo.
+ --enable-man-symlinks Use symlinks for linking the manpages that
+ should be reachable under several names.
+ --enable-man-compression=PROG
+ Compress the manpages using PROG.
+
+ Note: by default gcc will be used if it can be located on the PATH.
+ if you want to use cc instead of gcc, set the CC environment variable
+ to "cc" before running configure. It is not safe to edit the
+ Makefile to use gcc after configure is run. Also note that
+ you should use the same compiler when building extensions.
+
Note: be sure to use only absolute path names (those starting with "/")
- in the --prefix and --exec_prefix options.
+ in the --prefix and --exec-prefix options.
-(e) Type "make". This will create a library archive called
+(d) Type "make". This will create a library archive called
"libtcl<version>.a" or "libtcl<version>.so" and an interpreter
application called "tclsh" that allows you to type Tcl commands
interactively or execute script files.
-(f) If the make fails then you'll have to personalize the Makefile
+(e) If the make fails then you'll have to personalize the Makefile
for your site or possibly modify the distribution in other ways.
First check the porting Web page above to see if there are hints
for compiling on your system. If you need to modify Makefile,
are comments at the beginning of it that describe the things you
might want to change and how to change them.
-(g) Type "make install" to install Tcl binaries and script files in
+(f) Type "make install" to install Tcl binaries and script files in
standard places. You'll need write permission on the installation
directories to do this. The installation directories are
determined by the "configure" script and may be specified with
- the --prefix and --exec_prefix options to "configure". See the
+ the --prefix and --exec-prefix options to "configure". See the
Makefile for information on what directories were chosen; you
can override these choices by modifying the "prefix" and
"exec_prefix" variables in the Makefile.
-(h) At this point you can play with Tcl by invoking the "tclsh"
- program and typing Tcl commands. However, if you haven't installed
- Tcl then you'll first need to set your TCL_LIBRARY variable to
- hold the full path name of the "library" subdirectory. Note that
- the installed versions of tclsh, libtcl.a, and libtcl.so have a
- version number in their names, such as "tclsh8.3" or "libtcl8.3.so";
- to use the installed versions, either specify the version number
- or create a symbolic link (e.g. from "tclsh" to "tclsh8.3").
+(g) At this point you can play with Tcl by running "make shell"
+ and typing Tcl commands at the prompt.
If you have trouble compiling Tcl, see the URL noted above about working
platforms. It contains information that people have provided about changes
this will cause several of them to fail. If a test is failing
consistently, please send us a bug report with as much detail as you
can manage. Please use the online database at
- http://dev.scriptics.com/ticket/
+ http://tcl.sourceforge.net/
The Tcl test suite is very sensitive to proper implementation of
ANSI C library procedures such as sprintf and sscanf. If the test
suite generates errors, most likely they are due to non-conformance
of your system's ANSI C library; such problems are unlikely to
affect any real applications so it's probably safe to ignore them.
-
builtin(include,tcl.m4)
-builtin(include,../cygtcl.m4)
+++ /dev/null
-/*
- * bp.c --
- *
- * This file contains the "bp" ("binary patch") program. It is used
- * to replace configuration strings in Tcl/Tk binaries as part of
- * installation.
- *
- * Usage: bp file search replace
- *
- * This program searches file bp for the first occurrence of the
- * character string given by "search". If it is found, then the
- * first characters of that string get replaced by the string
- * given by "replace". The replacement string is NULL-terminated.
- *
- * Copyright (c) 1996 Sun Microsystems, Inc.
- * All rights reserved.
- * This file is NOT subject to the terms described in "license.terms".
- *
- * SCCS: @(#) bp.c 1.2 96/03/12 09:08:26
- */
-
-#include <stdio.h>
-#include <string.h>
-
-extern int errno;
-
-/*
- * The array below saves the last few bytes read from the file, so that
- * they can be compared against a particular string that we're looking
- * for.
- */
-
-#define BUFFER_SIZE 200
-char buffer[BUFFER_SIZE];
-
-int
-main(argc, argv)
- int argc; /* Number of command-line arguments. */
- char **argv; /* Values of command-line arguments. */
-{
- int length, matchChar, fileChar, cur, fileIndex, stringIndex;
- char *s;
- FILE *f;
-
- if (argc != 4) {
- fprintf(stderr,
- "Wrong # args: should be \"%s fileName string replace\"\n",
- argv[0]);
- exit(1);
- }
- f = fopen(argv[1], "r+");
- if (f == NULL) {
- fprintf(stderr,
- "Couldn't open \"%s\" for writing: %s\n",
- argv[1], strerror(errno));
- exit(1);
- }
-
- for (cur = 0; cur < BUFFER_SIZE; cur++) {
- buffer[cur] = 0;
- }
- s = argv[2];
- length = strlen(s);
- if (length > BUFFER_SIZE) {
- fprintf(stderr,
- "String \"%s\" too long; must be %d or fewer chars.\n",
- s, BUFFER_SIZE);
- exit(1);
- }
- matchChar = s[length-1];
-
- while (1) {
- fileChar = getc(f);
- if (fileChar == EOF) {
- if (ferror(f)) {
- goto ioError;
- }
- fprintf(stderr, "Couldn't find string \"%s\"\n", argv[2]);
- exit(1);
- }
- buffer[cur] = fileChar;
- if (fileChar == matchChar) {
- /*
- * Last character of the string matches the current character
- * from the file. Search backwards through the buffer to
- * see if the preceding characters from the file match the
- * characters from the string.
- */
- for (fileIndex = cur-1, stringIndex = length-2;
- stringIndex >= 0; fileIndex--, stringIndex--) {
- if (fileIndex < 0) {
- fileIndex = BUFFER_SIZE-1;
- }
- if (buffer[fileIndex] != s[stringIndex]) {
- goto noMatch;
- }
- }
-
- /*
- * Matched! Backup to the start of the string, then
- * overwrite it with the replacement value.
- */
-
- if (fseek(f, -length, SEEK_CUR) == -1) {
- goto ioError;
- }
- if (fwrite(argv[3], strlen(argv[3])+1, 1, f) == 0) {
- goto ioError;
- }
- exit(0);
- }
-
- /*
- * No match; go on to next character of file.
- */
-
- noMatch:
- cur++;
- if (cur >= BUFFER_SIZE) {
- cur = 0;
- }
- }
-
- ioError:
- fprintf(stderr, "I/O error: %s\n", strerror(errno));
- exit(1);
-}
ac_default_prefix=/usr/local
# Any additions from configure.in:
ac_help="$ac_help
+ --enable-man-symlinks use symlinks for the manpages"
+ac_help="$ac_help
+ --enable-man-compression=PROG
+ compress the manpages with PROG"
+ac_help="$ac_help
--enable-threads build with threads"
ac_help="$ac_help
+ --enable-langinfo use nl_langinfo if possible to determine
+ encoding at startup, otherwise use old heuristic"
+ac_help="$ac_help
+ --enable-shared build and link with shared libraries [--enable-shared]"
+ac_help="$ac_help
--enable-64bit enable 64bit support (where applicable)"
ac_help="$ac_help
--enable-64bit-vis enable 64bit Sparc VIS support"
ac_help="$ac_help
--enable-symbols build with debugging symbols [--disable-symbols]"
ac_help="$ac_help
- --enable-shared build and link with shared libraries [--enable-shared]"
+ --enable-framework package shared libraries in frameworks [--disable-framework]"
# Initialize some variables set by options.
# The variables have the same names as the options, with
program_transform_name=s,x,x,
silent=
site=
-sitefile=
srcdir=
target=NONE
verbose=
--help print this message
--no-create do not create output files
--quiet, --silent do not print \`checking...' messages
- --site-file=FILE use FILE as the site file
--version print the version of autoconf that created configure
Directory and file names:
--prefix=PREFIX install architecture-independent files in PREFIX
-site=* | --site=* | --sit=*)
site="$ac_optarg" ;;
- -site-file | --site-file | --site-fil | --site-fi | --site-f)
- ac_prev=sitefile ;;
- -site-file=* | --site-file=* | --site-fil=* | --site-fi=* | --site-f=*)
- sitefile="$ac_optarg" ;;
-
-srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
ac_prev=srcdir ;;
-srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
# Prefer explicitly selected file to automatically selected ones.
-if test -z "$sitefile"; then
- if test -z "$CONFIG_SITE"; then
- if test "x$prefix" != xNONE; then
- CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
- else
- CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
- fi
+if test -z "$CONFIG_SITE"; then
+ if test "x$prefix" != xNONE; then
+ CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
+ else
+ CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
fi
-else
- CONFIG_SITE="$sitefile"
fi
for ac_site_file in $CONFIG_SITE; do
if test -r "$ac_site_file"; then
fi
-# RCS: @(#) $Id$
-TCL_VERSION=8.3
+
+TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=3
-TCL_PATCH_LEVEL=".2"
+TCL_MINOR_VERSION=4
+TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
if test "${exec_prefix}" = "NONE"; then
exec_prefix=$prefix
fi
+# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
+eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`
#------------------------------------------------------------------------
+# Compress and/or soft link the manpages?
+#------------------------------------------------------------------------
+
+
+ echo $ac_n "checking whether to use symlinks for manpages""... $ac_c" 1>&6
+echo "configure:575: checking whether to use symlinks for manpages" >&5
+ # Check whether --enable-man-symlinks or --disable-man-symlinks was given.
+if test "${enable_man_symlinks+set}" = set; then
+ enableval="$enable_man_symlinks"
+ test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --symlinks"
+else
+ enableval="no"
+fi
+
+ echo "$ac_t""$enableval" 1>&6
+
+ echo $ac_n "checking compression for manpages""... $ac_c" 1>&6
+echo "configure:587: checking compression for manpages" >&5
+ # Check whether --enable-man-compression or --disable-man-compression was given.
+if test "${enable_man_compression+set}" = set; then
+ enableval="$enable_man_compression"
+ test "$enableval" = "yes" && echo && { echo "configure: error: missing argument to --enable-man-compression" 1>&2; exit 1; }
+ test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --compress $enableval"
+else
+ enableval="no"
+fi
+
+ echo "$ac_t""$enableval" 1>&6
+
+
+
+
+#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------
+# If the user did not set CFLAGS, set it now to keep
+# the AC_PROG_CC macro from adding "-g -O2".
+if test "${CFLAGS+set}" != "set" ; then
+ CFLAGS=""
+fi
+
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:575: checking for $ac_word" >&5
+echo "configure:615: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:605: checking for $ac_word" >&5
+echo "configure:645: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
# Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:656: checking for $ac_word" >&5
+echo "configure:696: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
-echo "configure:688: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
+echo "configure:728: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
cat > conftest.$ac_ext << EOF
-#line 699 "configure"
+#line 739 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
-if { (eval echo configure:704: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:744: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
ac_cv_prog_cc_works=yes
# If we can't run a trivial program, we are probably using a cross compiler.
if (./conftest; exit) 2>/dev/null; then
{ echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
-echo "configure:730: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
+echo "configure:770: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
-echo "configure:735: checking whether we are using GNU C" >&5
+echo "configure:775: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
yes;
#endif
EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:744: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:784: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-echo "configure:763: checking whether ${CC-cc} accepts -g" >&5
+echo "configure:803: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
fi
-# Extract the first word of "ranlib", so it can be a program name with args.
-set dummy ranlib; ac_word=$2
-echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:797: checking for $ac_word" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test -n "$RANLIB"; then
- ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
-else
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
- ac_dummy="$PATH"
- for ac_dir in $ac_dummy; do
- test -z "$ac_dir" && ac_dir=.
- if test -f $ac_dir/$ac_word; then
- ac_cv_prog_RANLIB="ranlib"
- break
- fi
- done
- IFS="$ac_save_ifs"
- test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
-fi
-fi
-RANLIB="$ac_cv_prog_RANLIB"
-if test -n "$RANLIB"; then
- echo "$ac_t""$RANLIB" 1>&6
-else
- echo "$ac_t""no" 1>&6
-fi
-
-
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
-echo "configure:826: checking how to run the C preprocessor" >&5
+echo "configure:835: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
-#line 841 "configure"
+#line 850 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:847: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:856: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
-#line 858 "configure"
+#line 867 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:864: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:873: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
rm -rf conftest*
CPP="${CC-cc} -nologo -E"
cat > conftest.$ac_ext <<EOF
-#line 875 "configure"
+#line 884 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:881: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:890: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:909: checking for $ac_hdr" >&5
+echo "configure:918: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 914 "configure"
+#line 923 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:919: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:928: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
done
-# CYGNUS LOCAL
-# dje/win32
-AR=${AR-ar}
-# We need this for substitutions in Makefile.in.
-ac_aux_dir=
-for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
- if test -f $ac_dir/install-sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install-sh -c"
- break
- elif test -f $ac_dir/install.sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install.sh -c"
- break
- fi
-done
-if test -z "$ac_aux_dir"; then
- { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
-fi
-ac_config_guess=$ac_aux_dir/config.guess
-ac_config_sub=$ac_aux_dir/config.sub
-ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
-
-# Find a good install program. We prefer a C program (faster),
-# so one script is as good as another. But avoid the broken or
-# incompatible versions:
-# SysV /etc/install, /usr/sbin/install
-# SunOS /usr/etc/install
-# IRIX /sbin/install
-# AIX /bin/install
-# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag
-# AFS /usr/afsws/bin/install, which mishandles nonexistent args
-# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
-# ./install, which can be erroneously created by make from ./install.sh.
-echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
-echo "configure:981: checking for a BSD compatible install" >&5
-if test -z "$INSTALL"; then
-if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- IFS="${IFS= }"; ac_save_IFS="$IFS"; IFS=":"
- for ac_dir in $PATH; do
- # Account for people who put trailing slashes in PATH elements.
- case "$ac_dir/" in
- /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
- *)
- # OSF1 and SCO ODT 3.0 have their own names for install.
- # Don't use installbsd from OSF since it installs stuff as root
- # by default.
- for ac_prog in ginstall scoinst install; do
- if test -f $ac_dir/$ac_prog; then
- if test $ac_prog = install &&
- grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
- # AIX install. It has an incompatible calling convention.
- :
- else
- ac_cv_path_install="$ac_dir/$ac_prog -c"
- break 2
- fi
- fi
- done
- ;;
- esac
- done
- IFS="$ac_save_IFS"
-
-fi
- if test "${ac_cv_path_install+set}" = set; then
- INSTALL="$ac_cv_path_install"
- else
- # As a last resort, use the slow shell script. We don't cache a
- # path for INSTALL within a source directory, because that will
- # break other packages using the cache if that directory is
- # removed, or if the path is relative.
- INSTALL="$ac_install_sh"
- fi
-fi
-echo "$ac_t""$INSTALL" 1>&6
-
-# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
-# It thinks the first close brace ends the variable substitution.
-test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
-
-test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL_PROGRAM}'
-
-test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
-
-# END CYGNUS LOCAL
-
-#--------------------------------------------------------------------
-# CYGNUS LOCAL:
-# This is for LynxOS, which needs a flag to force true POSIX when
-# building. It's weirder than that, cause the flag varies depending
-# how old the compiler is. So...
-# -X is for the old "cc" and "gcc" (based on 1.42)
-# -mposix is for the new gcc (at least 2.5.8)
-# This modifies the value of $CC to have the POSIX flag added
-# so everything will configure correctly.
-#--------------------------------------------------------------------
-
-echo $ac_n "checking to see if this is LynxOS""... $ac_c" 1>&6
-echo "configure:1047: checking to see if this is LynxOS" >&5
-if eval "test \"`echo '$''{'ac_cv_os_lynx'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1052 "configure"
-#include "confdefs.h"
-/*
- * The old Lynx "cc" only defines "Lynx", but the newer one uses "__Lynx__"
- */
-#if defined(__Lynx__) || defined(Lynx)
-yes
-#endif
-
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "yes" >/dev/null 2>&1; then
- rm -rf conftest*
- ac_cv_os_lynx=yes
-else
- rm -rf conftest*
- ac_cv_os_lynx=no
-fi
-rm -f conftest*
-
-fi
-
-#
-if test "$ac_cv_os_lynx" = "yes" ; then
- echo "$ac_t""yes" 1>&6
- cat >> confdefs.h <<\EOF
-#define LYNX 1
-EOF
-
- echo $ac_n "checking whether -mposix or -X is available""... $ac_c" 1>&6
-echo "configure:1082: checking whether -mposix or -X is available" >&5
- if eval "test \"`echo '$''{'ac_cv_c_posix_flag'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1087 "configure"
-#include "confdefs.h"
-
-int main() {
-
- /*
- * This flag varies depending on how old the compiler is.
- * -X is for the old "cc" and "gcc" (based on 1.42).
- * -mposix is for the new gcc (at least 2.5.8).
- */
- #if defined(__GNUC__) && __GNUC__ >= 2
- choke me
- #endif
-
-; return 0; }
-EOF
-if { (eval echo configure:1103: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_c_posix_flag=" -mposix"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_c_posix_flag=" -X"
-fi
-rm -f conftest*
-fi
-
- CC="$CC $ac_cv_c_posix_flag"
- echo "$ac_t""$ac_cv_c_posix_flag" 1>&6
- else
- echo "$ac_t""no" 1>&6
-fi
-
-
#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
-echo "configure:1128: checking for building with threads" >&5
+echo "configure:961: checking for building with threads" >&5
# Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
enableval="$enable_threads"
#define TCL_THREADS 1
EOF
+ # USE_THREAD_ALLOC tells us to try the special thread-based
+ # allocator that significantly reduces lock contention
+ cat >> confdefs.h <<\EOF
+#define USE_THREAD_ALLOC 1
+EOF
+
cat >> confdefs.h <<\EOF
#define _REENTRANT 1
EOF
EOF
echo $ac_n "checking for pthread_mutex_init in -lpthread""... $ac_c" 1>&6
-echo "configure:1154: checking for pthread_mutex_init in -lpthread" >&5
+echo "configure:993: checking for pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-lpthread $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1162 "configure"
+#line 1001 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
pthread_mutex_init()
; return 0; }
EOF
-if { (eval echo configure:1173: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1012: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
# pthread.h, but that will work with libpthread really doesn't
# exist, like AIX 4.2. [Bug: 4359]
echo $ac_n "checking for __pthread_mutex_init in -lpthread""... $ac_c" 1>&6
-echo "configure:1201: checking for __pthread_mutex_init in -lpthread" >&5
+echo "configure:1040: checking for __pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'__pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-lpthread $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1209 "configure"
+#line 1048 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
__pthread_mutex_init()
; return 0; }
EOF
-if { (eval echo configure:1220: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1059: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
THREADS_LIBS=" -lpthread"
else
echo $ac_n "checking for pthread_mutex_init in -lpthreads""... $ac_c" 1>&6
-echo "configure:1248: checking for pthread_mutex_init in -lpthreads" >&5
+echo "configure:1087: checking for pthread_mutex_init in -lpthreads" >&5
ac_lib_var=`echo pthreads'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-lpthreads $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1256 "configure"
+#line 1095 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
pthread_mutex_init()
; return 0; }
EOF
-if { (eval echo configure:1267: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1106: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
THREADS_LIBS=" -lpthreads"
else
echo $ac_n "checking for pthread_mutex_init in -lc""... $ac_c" 1>&6
-echo "configure:1293: checking for pthread_mutex_init in -lc" >&5
+echo "configure:1132: checking for pthread_mutex_init in -lc" >&5
ac_lib_var=`echo c'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-lc $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 1301 "configure"
+#line 1140 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
pthread_mutex_init()
; return 0; }
EOF
-if { (eval echo configure:1312: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1151: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
if test "$tcl_ok" = "no"; then
- TCL_THREADS=0
- echo "configure: warning: "Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..."" 1>&2
- fi
- fi
- fi
-
- # Does the pthread-implementation provide
- # 'pthread_attr_setstacksize' ?
-
- for ac_func in pthread_attr_setstacksize
-do
-echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:1346: checking for $ac_func" >&5
-if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "checking for pthread_mutex_init in -lc_r""... $ac_c" 1>&6
+echo "configure:1174: checking for pthread_mutex_init in -lc_r" >&5
+ac_lib_var=`echo c_r'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
- cat > conftest.$ac_ext <<EOF
-#line 1351 "configure"
+ ac_save_LIBS="$LIBS"
+LIBS="-lc_r $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1182 "configure"
#include "confdefs.h"
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func(); below. */
-#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
-char $ac_func();
+char pthread_mutex_init();
int main() {
-
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
-choke me
-#else
-$ac_func();
-#endif
-
+pthread_mutex_init()
; return 0; }
EOF
-if { (eval echo configure:1374: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1193: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
- eval "ac_cv_func_$ac_func=yes"
+ eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
- eval "ac_cv_func_$ac_func=no"
+ eval "ac_cv_lib_$ac_lib_var=no"
fi
rm -f conftest*
-fi
+LIBS="$ac_save_LIBS"
-if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
echo "$ac_t""yes" 1>&6
- ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_func 1
-EOF
-
+ tcl_ok=yes
else
echo "$ac_t""no" 1>&6
+tcl_ok=no
fi
-done
-
- else
- TCL_THREADS=0
- echo "$ac_t""no (default)" 1>&6
- fi
-
-
-#------------------------------------------------------------------------
-# If we're using GCC, see if the compiler understands -pipe. If so, use it.
-# It makes compiling go faster. (This is only a performance feature.)
-#------------------------------------------------------------------------
-
-if test -z "$no_pipe"; then
-if test -n "$GCC"; then
- echo $ac_n "checking if the compiler understands -pipe""... $ac_c" 1>&6
-echo "configure:1412: checking if the compiler understands -pipe" >&5
- OLDCC="$CC"
- CC="$CC -pipe"
- cat > conftest.$ac_ext <<EOF
-#line 1416 "configure"
-#include "confdefs.h"
-
-int main() {
-; return 0; }
-EOF
-if { (eval echo configure:1423: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- echo "$ac_t""yes" 1>&6
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- CC="$OLDCC"
- echo "$ac_t""no" 1>&6
-fi
-rm -f conftest*
-fi
-fi
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -pthread"
+ else
+ TCL_THREADS=0
+ echo "configure: warning: "Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile..."" 1>&2
+ fi
+ fi
+ fi
+ fi
-#--------------------------------------------------------------------
-# Supply substitutes for missing POSIX library procedures, or
-# set flags so Tcl uses alternate procedures.
-#--------------------------------------------------------------------
+ # Does the pthread-implementation provide
+ # 'pthread_attr_setstacksize' ?
-# Check if Posix compliant getcwd exists, if not we'll use getwd.
-for ac_func in getcwd
+ for ac_func in pthread_attr_setstacksize
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:1446: checking for $ac_func" >&5
+echo "configure:1231: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1451 "configure"
+#line 1236 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:1474: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1259: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
else
echo "$ac_t""no" 1>&6
-cat >> confdefs.h <<\EOF
-#define USEGETWD 1
-EOF
-
fi
done
-# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
-# define USEGETWD even if the posix getcwd exists. Add a test ?
-
-for ac_func in opendir strstr
+ for ac_func in readdir_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:1508: checking for $ac_func" >&5
+echo "configure:1286: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1513 "configure"
+#line 1291 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
; return 0; }
EOF
-if { (eval echo configure:1536: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1314: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
else
echo "$ac_t""no" 1>&6
-LIBOBJS="$LIBOBJS ${ac_func}.${ac_objext}"
fi
done
+ else
+ TCL_THREADS=0
+ echo "$ac_t""no (default)" 1>&6
+ fi
+
-for ac_func in strtol tmpnam waitpid
-do
-echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
-echo "configure:1566: checking for $ac_func" >&5
-if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
+#------------------------------------------------------------------------
+# If we're using GCC, see if the compiler understands -pipe. If so, use it.
+# It makes compiling go faster. (This is only a performance feature.)
+#------------------------------------------------------------------------
+
+if test -z "$no_pipe"; then
+if test -n "$GCC"; then
+ echo $ac_n "checking if the compiler understands -pipe""... $ac_c" 1>&6
+echo "configure:1353: checking if the compiler understands -pipe" >&5
+ OLDCC="$CC"
+ CC="$CC -pipe"
cat > conftest.$ac_ext <<EOF
-#line 1571 "configure"
+#line 1357 "configure"
#include "confdefs.h"
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char $ac_func(); below. */
+
+int main() {
+
+; return 0; }
+EOF
+if { (eval echo configure:1364: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ echo "$ac_t""yes" 1>&6
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ CC="$OLDCC"
+ echo "$ac_t""no" 1>&6
+fi
+rm -f conftest*
+fi
+fi
+
+#--------------------------------------------------------------------
+# Detect what compiler flags to set for 64-bit support.
+#--------------------------------------------------------------------
+
+
+ echo $ac_n "checking for required early compiler flags""... $ac_c" 1>&6
+echo "configure:1384: checking for required early compiler flags" >&5
+ tcl_flags=""
+
+ if eval "test \"`echo '$''{'tcl_cv_flag__isoc99_source'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1391 "configure"
+#include "confdefs.h"
+#include <stdlib.h>
+int main() {
+char *p = (char *)strtoll; char *q = (char *)strtoull;
+; return 0; }
+EOF
+if { (eval echo configure:1398: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_flag__isoc99_source=no
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ cat > conftest.$ac_ext <<EOF
+#line 1406 "configure"
+#include "confdefs.h"
+#define _ISOC99_SOURCE 1
+#include <stdlib.h>
+int main() {
+char *p = (char *)strtoll; char *q = (char *)strtoull;
+; return 0; }
+EOF
+if { (eval echo configure:1414: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_flag__isoc99_source=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ tcl_cv_flag__isoc99_source=no
+fi
+rm -f conftest*
+fi
+rm -f conftest*
+fi
+
+ if test "x${tcl_cv_flag__isoc99_source}" = "xyes" ; then
+ cat >> confdefs.h <<\EOF
+#define _ISOC99_SOURCE 1
+EOF
+
+ tcl_flags="$tcl_flags _ISOC99_SOURCE"
+ fi
+
+ if eval "test \"`echo '$''{'tcl_cv_flag__largefile64_source'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1440 "configure"
+#include "confdefs.h"
+#include <sys/stat.h>
+int main() {
+struct stat64 buf; int i = stat64("/", &buf);
+; return 0; }
+EOF
+if { (eval echo configure:1447: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_flag__largefile64_source=no
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ cat > conftest.$ac_ext <<EOF
+#line 1455 "configure"
+#include "confdefs.h"
+#define _LARGEFILE64_SOURCE 1
+#include <sys/stat.h>
+int main() {
+struct stat64 buf; int i = stat64("/", &buf);
+; return 0; }
+EOF
+if { (eval echo configure:1463: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_flag__largefile64_source=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ tcl_cv_flag__largefile64_source=no
+fi
+rm -f conftest*
+fi
+rm -f conftest*
+fi
+
+ if test "x${tcl_cv_flag__largefile64_source}" = "xyes" ; then
+ cat >> confdefs.h <<\EOF
+#define _LARGEFILE64_SOURCE 1
+EOF
+
+ tcl_flags="$tcl_flags _LARGEFILE64_SOURCE"
+ fi
+ if test "x${tcl_flags}" = "x" ; then
+ echo "$ac_t""none" 1>&6
+ else
+ echo "$ac_t""${tcl_flags}" 1>&6
+ fi
+
+
+ echo $ac_n "checking for 64-bit integer type""... $ac_c" 1>&6
+echo "configure:1492: checking for 64-bit integer type" >&5
+ if eval "test \"`echo '$''{'tcl_cv_type_64bit'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+ tcl_cv_type_64bit=none
+ # See if the compiler knows natively about __int64
+ cat > conftest.$ac_ext <<EOF
+#line 1500 "configure"
+#include "confdefs.h"
+
+int main() {
+__int64 value = (__int64) 0;
+; return 0; }
+EOF
+if { (eval echo configure:1507: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_type_64bit=__int64
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ tcl_type_64bit="long long"
+fi
+rm -f conftest*
+ # See if we should use long anyway Note that we substitute in the
+ # type that is our current guess for a 64-bit type inside this check
+ # program, so it should be modified only carefully...
+ if test "$cross_compiling" = yes; then
+ :
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1524 "configure"
+#include "confdefs.h"
+#include <unistd.h>
+ int main() {exit(!(sizeof(${tcl_type_64bit}) > sizeof(long)));}
+
+EOF
+if { (eval echo configure:1530: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+then
+ tcl_cv_type_64bit=${tcl_type_64bit}
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ :
+fi
+rm -fr conftest*
+fi
+
+fi
+
+ if test "${tcl_cv_type_64bit}" = none ; then
+ cat >> confdefs.h <<\EOF
+#define TCL_WIDE_INT_IS_LONG 1
+EOF
+
+ echo "$ac_t""using long" 1>&6
+ else
+ cat >> confdefs.h <<EOF
+#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}
+EOF
+
+ echo "$ac_t""${tcl_cv_type_64bit}" 1>&6
+
+ # Now check for auxiliary declarations
+ echo $ac_n "checking for struct dirent64""... $ac_c" 1>&6
+echo "configure:1559: checking for struct dirent64" >&5
+ if eval "test \"`echo '$''{'tcl_cv_struct_dirent64'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+ cat > conftest.$ac_ext <<EOF
+#line 1565 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#include <sys/dirent.h>
+int main() {
+struct dirent64 p;
+; return 0; }
+EOF
+if { (eval echo configure:1573: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_struct_dirent64=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ tcl_cv_struct_dirent64=no
+fi
+rm -f conftest*
+fi
+
+ if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_STRUCT_DIRENT64 1
+EOF
+
+ fi
+ echo "$ac_t""${tcl_cv_struct_dirent64}" 1>&6
+
+ echo $ac_n "checking for struct stat64""... $ac_c" 1>&6
+echo "configure:1594: checking for struct stat64" >&5
+ if eval "test \"`echo '$''{'tcl_cv_struct_stat64'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+ cat > conftest.$ac_ext <<EOF
+#line 1600 "configure"
+#include "confdefs.h"
+#include <sys/stat.h>
+int main() {
+struct stat64 p;
+
+; return 0; }
+EOF
+if { (eval echo configure:1608: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_struct_stat64=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ tcl_cv_struct_stat64=no
+fi
+rm -f conftest*
+fi
+
+ if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_STRUCT_STAT64 1
+EOF
+
+ fi
+ echo "$ac_t""${tcl_cv_struct_stat64}" 1>&6
+
+ echo $ac_n "checking for off64_t""... $ac_c" 1>&6
+echo "configure:1629: checking for off64_t" >&5
+ if eval "test \"`echo '$''{'tcl_cv_type_off64_t'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+ cat > conftest.$ac_ext <<EOF
+#line 1635 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+int main() {
+off64_t offset;
+
+; return 0; }
+EOF
+if { (eval echo configure:1643: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_type_off64_t=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ tcl_cv_type_off64_t=no
+fi
+rm -f conftest*
+fi
+
+ if test "x${tcl_cv_type_off64_t}" = "xyes" ; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_TYPE_OFF64_T 1
+EOF
+
+ fi
+ echo "$ac_t""${tcl_cv_type_off64_t}" 1>&6
+ fi
+
+#--------------------------------------------------------------------
+# Check endianness because we can optimize comparisons of
+# Tcl_UniChar strings to memcmp on big-endian systems.
+#--------------------------------------------------------------------
+
+echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6
+echo "configure:1670: checking whether byte ordering is bigendian" >&5
+if eval "test \"`echo '$''{'ac_cv_c_bigendian'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_cv_c_bigendian=unknown
+# See if sys/param.h defines the BYTE_ORDER macro.
+cat > conftest.$ac_ext <<EOF
+#line 1677 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#include <sys/param.h>
+int main() {
+
+#if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN
+ bogus endian macros
+#endif
+; return 0; }
+EOF
+if { (eval echo configure:1688: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ # It does; now see whether it defined to BIG_ENDIAN or not.
+cat > conftest.$ac_ext <<EOF
+#line 1692 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#include <sys/param.h>
+int main() {
+
+#if BYTE_ORDER != BIG_ENDIAN
+ not big endian
+#endif
+; return 0; }
+EOF
+if { (eval echo configure:1703: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ ac_cv_c_bigendian=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ ac_cv_c_bigendian=no
+fi
+rm -f conftest*
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+fi
+rm -f conftest*
+if test $ac_cv_c_bigendian = unknown; then
+if test "$cross_compiling" = yes; then
+ { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1723 "configure"
+#include "confdefs.h"
+main () {
+ /* Are we little or big endian? From Harbison&Steele. */
+ union
+ {
+ long l;
+ char c[sizeof (long)];
+ } u;
+ u.l = 1;
+ exit (u.c[sizeof (long) - 1] == 1);
+}
+EOF
+if { (eval echo configure:1736: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+then
+ ac_cv_c_bigendian=no
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ ac_cv_c_bigendian=yes
+fi
+rm -fr conftest*
+fi
+
+fi
+fi
+
+echo "$ac_t""$ac_cv_c_bigendian" 1>&6
+if test $ac_cv_c_bigendian = yes; then
+ cat >> confdefs.h <<\EOF
+#define WORDS_BIGENDIAN 1
+EOF
+
+fi
+
+
+#--------------------------------------------------------------------
+# Supply substitutes for missing POSIX library procedures, or
+# set flags so Tcl uses alternate procedures.
+#--------------------------------------------------------------------
+
+# Check if Posix compliant getcwd exists, if not we'll use getwd.
+for ac_func in getcwd
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:1769: checking for $ac_func" >&5
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1774 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char $ac_func();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1797: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
+EOF
+
+else
+ echo "$ac_t""no" 1>&6
+cat >> confdefs.h <<\EOF
+#define USEGETWD 1
+EOF
+
+fi
+done
+
+# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
+# define USEGETWD even if the posix getcwd exists. Add a test ?
+
+for ac_func in opendir strstr
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:1831: checking for $ac_func" >&5
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1836 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char $ac_func();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1859: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_func_$ac_func=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
+EOF
+
+else
+ echo "$ac_t""no" 1>&6
+LIBOBJS="$LIBOBJS ${ac_func}.${ac_objext}"
+fi
+done
+
+
+
+for ac_func in strtol strtoll strtoull tmpnam waitpid
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:1889: checking for $ac_func" >&5
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1894 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
; return 0; }
EOF
-if { (eval echo configure:1594: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1917: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
echo $ac_n "checking for strerror""... $ac_c" 1>&6
-echo "configure:1621: checking for strerror" >&5
+echo "configure:1944: checking for strerror" >&5
if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1626 "configure"
+#line 1949 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strerror(); below. */
; return 0; }
EOF
-if { (eval echo configure:1649: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:1972: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strerror=yes"
else
fi
echo $ac_n "checking for getwd""... $ac_c" 1>&6
-echo "configure:1673: checking for getwd" >&5
+echo "configure:1996: checking for getwd" >&5
if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1678 "configure"
+#line 2001 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char getwd(); below. */
; return 0; }
EOF
-if { (eval echo configure:1701: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:2024: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_getwd=yes"
else
fi
echo $ac_n "checking for wait3""... $ac_c" 1>&6
-echo "configure:1725: checking for wait3" >&5
+echo "configure:2048: checking for wait3" >&5
if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1730 "configure"
+#line 2053 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char wait3(); below. */
; return 0; }
EOF
-if { (eval echo configure:1753: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:2076: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_wait3=yes"
else
fi
echo $ac_n "checking for uname""... $ac_c" 1>&6
-echo "configure:1777: checking for uname" >&5
+echo "configure:2100: checking for uname" >&5
if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1782 "configure"
+#line 2105 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char uname(); below. */
; return 0; }
EOF
-if { (eval echo configure:1805: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:2128: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_uname=yes"
else
fi
echo $ac_n "checking for realpath""... $ac_c" 1>&6
-echo "configure:1829: checking for realpath" >&5
+echo "configure:2152: checking for realpath" >&5
if eval "test \"`echo '$''{'ac_cv_func_realpath'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1834 "configure"
+#line 2157 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char realpath(); below. */
; return 0; }
EOF
-if { (eval echo configure:1857: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:2180: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_realpath=yes"
else
#--------------------------------------------------------------------
-
echo $ac_n "checking dirent.h""... $ac_c" 1>&6
-echo "configure:1893: checking dirent.h" >&5
+echo "configure:2215: checking dirent.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 1895 "configure"
+#line 2217 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <dirent.h>
; return 0; }
EOF
-if { (eval echo configure:1921: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:2243: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
tcl_ok=yes
else
echo "$ac_t""$tcl_ok" 1>&6
ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
-echo "configure:1942: checking for errno.h" >&5
+echo "configure:2264: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1947 "configure"
+#line 2269 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1952: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2274: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "float.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for float.h""... $ac_c" 1>&6
-echo "configure:1979: checking for float.h" >&5
+echo "configure:2301: checking for float.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1984 "configure"
+#line 2306 "configure"
#include "confdefs.h"
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1989: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2311: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "values.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for values.h""... $ac_c" 1>&6
-echo "configure:2016: checking for values.h" >&5
+echo "configure:2338: checking for values.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2021 "configure"
+#line 2343 "configure"
#include "confdefs.h"
#include <values.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2026: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2348: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "limits.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for limits.h""... $ac_c" 1>&6
-echo "configure:2053: checking for limits.h" >&5
+echo "configure:2375: checking for limits.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2058 "configure"
+#line 2380 "configure"
#include "confdefs.h"
#include <limits.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2063: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2385: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "stdlib.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6
-echo "configure:2090: checking for stdlib.h" >&5
+echo "configure:2412: checking for stdlib.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2095 "configure"
+#line 2417 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2100: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2422: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
fi
cat > conftest.$ac_ext <<EOF
-#line 2123 "configure"
+#line 2445 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
rm -f conftest*
cat > conftest.$ac_ext <<EOF
-#line 2137 "configure"
+#line 2459 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
rm -f conftest*
cat > conftest.$ac_ext <<EOF
-#line 2151 "configure"
+#line 2473 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
fi
ac_safe=`echo "string.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for string.h""... $ac_c" 1>&6
-echo "configure:2172: checking for string.h" >&5
+echo "configure:2494: checking for string.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2177 "configure"
+#line 2499 "configure"
#include "confdefs.h"
#include <string.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2182: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2504: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
fi
cat > conftest.$ac_ext <<EOF
-#line 2205 "configure"
+#line 2527 "configure"
#include "confdefs.h"
#include <string.h>
EOF
rm -f conftest*
cat > conftest.$ac_ext <<EOF
-#line 2219 "configure"
+#line 2541 "configure"
#include "confdefs.h"
#include <string.h>
EOF
ac_safe=`echo "sys/wait.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6
-echo "configure:2245: checking for sys/wait.h" >&5
+echo "configure:2567: checking for sys/wait.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2250 "configure"
+#line 2572 "configure"
#include "confdefs.h"
#include <sys/wait.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2255: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2577: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
-echo "configure:2282: checking for dlfcn.h" >&5
+echo "configure:2604: checking for dlfcn.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2287 "configure"
+#line 2609 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2292: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2614: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:2324: checking for $ac_hdr" >&5
+echo "configure:2646: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2329 "configure"
+#line 2651 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2334: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:2656: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
#---------------------------------------------------------------------------
- echo $ac_n "checking termios vs. termio vs. sgtty""... $ac_c" 1>&6
-echo "configure:2371: checking termios vs. termio vs. sgtty" >&5
+ for ac_hdr in sys/modem.h
+do
+ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+echo "configure:2696: checking for $ac_hdr" >&5
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2701 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:2706: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=yes"
+else
+ echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_hdr 1
+EOF
+
+else
+ echo "$ac_t""no" 1>&6
+fi
+done
+ echo $ac_n "checking termios vs. termio vs. sgtty""... $ac_c" 1>&6
+echo "configure:2733: checking termios vs. termio vs. sgtty" >&5
+ if eval "test \"`echo '$''{'tcl_cv_api_serial'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
if test "$cross_compiling" = yes; then
- tk_ok=no
+ tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
-#line 2377 "configure"
+#line 2742 "configure"
#include "confdefs.h"
#include <termios.h>
-main()
-{
+int main() {
struct termios t;
if (tcgetattr(0, &t) == 0) {
cfsetospeed(&t, 0);
return 1;
}
EOF
-if { (eval echo configure:2393: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:2757: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
- tk_ok=termios
+ tcl_cv_api_serial=termios
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
- tk_ok=no
+ tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
-
- if test $tk_ok = termios; then
- cat >> confdefs.h <<\EOF
-#define USE_TERMIOS 1
-EOF
-
- else
+ if test $tcl_cv_api_serial = no ; then
if test "$cross_compiling" = yes; then
- tk_ok=no
+ tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
-#line 2416 "configure"
+#line 2774 "configure"
#include "confdefs.h"
#include <termio.h>
-main()
-{
+int main() {
struct termio t;
if (ioctl(0, TCGETA, &t) == 0) {
t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
return 0;
}
return 1;
- }
+}
EOF
-if { (eval echo configure:2431: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:2788: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
- tk_ok=termio
+ tcl_cv_api_serial=termio
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
- tk_ok=no
+ tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
-
- if test $tk_ok = termio; then
- cat >> confdefs.h <<\EOF
-#define USE_TERMIO 1
-EOF
-
- else
+ fi
+ if test $tcl_cv_api_serial = no ; then
if test "$cross_compiling" = yes; then
- tk_ok=none
+ tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
-#line 2454 "configure"
+#line 2806 "configure"
#include "confdefs.h"
#include <sgtty.h>
-main()
-{
+int main() {
struct sgttyb t;
if (ioctl(0, TIOCGETP, &t) == 0) {
t.sg_ospeed = 0;
return 1;
}
EOF
-if { (eval echo configure:2470: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:2821: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
- tk_ok=sgtty
+ tcl_cv_api_serial=sgtty
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
- tk_ok=none
+ tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
- if test $tk_ok = sgtty; then
- cat >> confdefs.h <<\EOF
-#define USE_SGTTY 1
+ fi
+ if test $tcl_cv_api_serial = no ; then
+ if test "$cross_compiling" = yes; then
+ tcl_cv_api_serial=no
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2839 "configure"
+#include "confdefs.h"
+
+#include <termios.h>
+#include <errno.h>
+
+int main() {
+ struct termios t;
+ if (tcgetattr(0, &t) == 0
+ || errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
+ cfsetospeed(&t, 0);
+ t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
+ return 0;
+ }
+ return 1;
+}
EOF
+if { (eval echo configure:2856: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+then
+ tcl_cv_api_serial=termios
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ tcl_cv_api_serial=no
+fi
+rm -fr conftest*
+fi
fi
+ if test $tcl_cv_api_serial = no; then
+ if test "$cross_compiling" = yes; then
+ tcl_cv_api_serial=no
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2874 "configure"
+#include "confdefs.h"
+
+#include <termio.h>
+#include <errno.h>
+
+int main() {
+ struct termio t;
+ if (ioctl(0, TCGETA, &t) == 0
+ || errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
+ t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
+ return 0;
+ }
+ return 1;
+ }
+EOF
+if { (eval echo configure:2890: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+then
+ tcl_cv_api_serial=termio
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ tcl_cv_api_serial=no
+fi
+rm -fr conftest*
+fi
+
fi
+ if test $tcl_cv_api_serial = no; then
+ if test "$cross_compiling" = yes; then
+ tcl_cv_api_serial=none
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2908 "configure"
+#include "confdefs.h"
+
+#include <sgtty.h>
+#include <errno.h>
+
+int main() {
+ struct sgttyb t;
+ if (ioctl(0, TIOCGETP, &t) == 0
+ || errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
+ t.sg_ospeed = 0;
+ t.sg_flags |= ODDP | EVENP | RAW;
+ return 0;
+ }
+ return 1;
+}
+EOF
+if { (eval echo configure:2925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+then
+ tcl_cv_api_serial=sgtty
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ tcl_cv_api_serial=none
+fi
+rm -fr conftest*
+fi
+
fi
- echo "$ac_t""$tk_ok" 1>&6
+fi
+
+ case $tcl_cv_api_serial in
+ termios) cat >> confdefs.h <<\EOF
+#define USE_TERMIOS 1
+EOF
+;;
+ termio) cat >> confdefs.h <<\EOF
+#define USE_TERMIO 1
+EOF
+;;
+ sgtty) cat >> confdefs.h <<\EOF
+#define USE_SGTTY 1
+EOF
+;;
+ esac
+ echo "$ac_t""$tcl_cv_api_serial" 1>&6
#--------------------------------------------------------------------
# special flag.
#--------------------------------------------------------------------
-echo $ac_n "checking fd_set and sys/select""... $ac_c" 1>&6
-echo "configure:2504: checking fd_set and sys/select" >&5
-cat > conftest.$ac_ext <<EOF
-#line 2506 "configure"
+echo $ac_n "checking for fd_set in sys/types""... $ac_c" 1>&6
+echo "configure:2968: checking for fd_set in sys/types" >&5
+if eval "test \"`echo '$''{'tcl_cv_type_fd_set'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 2973 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() {
fd_set readMask, writeMask;
; return 0; }
EOF
-if { (eval echo configure:2513: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:2980: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
- tk_ok=yes
+ tcl_cv_type_fd_set=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
- tk_ok=no
+ tcl_cv_type_fd_set=no
fi
rm -f conftest*
-if test $tk_ok = no; then
- cat > conftest.$ac_ext <<EOF
-#line 2525 "configure"
+fi
+
+echo "$ac_t""$tcl_cv_type_fd_set" 1>&6
+tk_ok=$tcl_cv_type_fd_set
+if test $tcl_cv_type_fd_set = no; then
+ echo $ac_n "checking for fd_mask in sys/select""... $ac_c" 1>&6
+echo "configure:2996: checking for fd_mask in sys/select" >&5
+ if eval "test \"`echo '$''{'tcl_cv_grep_fd_mask'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3001 "configure"
#include "confdefs.h"
#include <sys/select.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "fd_mask" >/dev/null 2>&1; then
rm -rf conftest*
- tk_ok=yes
+ tcl_cv_grep_fd_mask=present
+else
+ rm -rf conftest*
+ tcl_cv_grep_fd_mask=missing
fi
rm -f conftest*
- if test $tk_ok = yes; then
+fi
+
+ echo "$ac_t""$tcl_cv_grep_fd_mask" 1>&6
+ if test $tcl_cv_grep_fd_mask = present; then
cat >> confdefs.h <<\EOF
#define HAVE_SYS_SELECT_H 1
EOF
+ tk_ok=yes
fi
fi
-echo "$ac_t""$tk_ok" 1>&6
if test $tk_ok = no; then
cat >> confdefs.h <<\EOF
#define NO_FD_SET 1
#------------------------------------------------------------------------------
echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6
-echo "configure:2556: checking whether struct tm is in sys/time.h or time.h" >&5
+echo "configure:3038: checking whether struct tm is in sys/time.h or time.h" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2561 "configure"
+#line 3043 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <time.h>
struct tm *tp; tp->tm_sec;
; return 0; }
EOF
-if { (eval echo configure:2569: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3051: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_tm=time.h
else
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:2594: checking for $ac_hdr" >&5
+echo "configure:3076: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2599 "configure"
+#line 3081 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2604: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:3086: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
done
echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
-echo "configure:2631: checking whether time.h and sys/time.h may both be included" >&5
+echo "configure:3113: checking whether time.h and sys/time.h may both be included" >&5
if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2636 "configure"
+#line 3118 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
struct tm *tp;
; return 0; }
EOF
-if { (eval echo configure:2645: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3127: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_time=yes
else
fi
echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6
-echo "configure:2666: checking for tm_zone in struct tm" >&5
+echo "configure:3148: checking for tm_zone in struct tm" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2671 "configure"
+#line 3153 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_cv_struct_tm>
struct tm tm; tm.tm_zone;
; return 0; }
EOF
-if { (eval echo configure:2679: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3161: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_tm_zone=yes
else
else
echo $ac_n "checking for tzname""... $ac_c" 1>&6
-echo "configure:2699: checking for tzname" >&5
+echo "configure:3181: checking for tzname" >&5
if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2704 "configure"
+#line 3186 "configure"
#include "confdefs.h"
#include <time.h>
#ifndef tzname /* For SGI. */
atoi(*tzname);
; return 0; }
EOF
-if { (eval echo configure:2714: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:3196: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
ac_cv_var_tzname=yes
else
fi
- echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
-echo "configure:2737: checking tm_tzadj in struct tm" >&5
- cat > conftest.$ac_ext <<EOF
-#line 2739 "configure"
+ for ac_func in gmtime_r localtime_r
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+echo "configure:3221: checking for $ac_func" >&5
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3226 "configure"
#include "confdefs.h"
-#include <time.h>
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char $ac_func(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char $ac_func();
+
int main() {
-struct tm tm; tm.tm_tzadj;
+
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
; return 0; }
EOF
-if { (eval echo configure:2746: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3249: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
- cat >> confdefs.h <<\EOF
-#define HAVE_TM_TZADJ 1
-EOF
-
- echo "$ac_t""yes" 1>&6
+ eval "ac_cv_func_$ac_func=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
- echo "$ac_t""no" 1>&6
+ eval "ac_cv_func_$ac_func=no"
fi
rm -f conftest*
+fi
- echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6
-echo "configure:2762: checking tm_gmtoff in struct tm" >&5
- cat > conftest.$ac_ext <<EOF
-#line 2764 "configure"
-#include "confdefs.h"
-#include <time.h>
-int main() {
-struct tm tm; tm.tm_gmtoff;
-; return 0; }
-EOF
-if { (eval echo configure:2771: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- cat >> confdefs.h <<\EOF
-#define HAVE_TM_GMTOFF 1
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+ cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
EOF
-
- echo "$ac_t""yes" 1>&6
+
else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
echo "$ac_t""no" 1>&6
fi
-rm -f conftest*
+done
+
- #
- # Its important to include time.h in this check, as some systems
- # (like convex) have timezone functions, etc.
- #
- have_timezone=no
- echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
-echo "configure:2792: checking long timezone variable" >&5
- cat > conftest.$ac_ext <<EOF
-#line 2794 "configure"
+ echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
+echo "configure:3275: checking tm_tzadj in struct tm" >&5
+ if eval "test \"`echo '$''{'tcl_cv_member_tm_tzadj'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3280 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
-extern long timezone;
- timezone += 1;
- exit (0);
+struct tm tm; tm.tm_tzadj;
; return 0; }
EOF
-if { (eval echo configure:2803: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3287: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
- have_timezone=yes
- cat >> confdefs.h <<\EOF
-#define HAVE_TIMEZONE_VAR 1
-EOF
-
- echo "$ac_t""yes" 1>&6
+ tcl_cv_member_tm_tzadj=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
- echo "$ac_t""no" 1>&6
+ tcl_cv_member_tm_tzadj=no
fi
rm -f conftest*
+fi
- #
- # On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
- #
- if test "$have_timezone" = no; then
- echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
-echo "configure:2824: checking time_t timezone variable" >&5
- cat > conftest.$ac_ext <<EOF
-#line 2826 "configure"
+ echo "$ac_t""$tcl_cv_member_tm_tzadj" 1>&6
+ if test $tcl_cv_member_tm_tzadj = yes ; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_TM_TZADJ 1
+EOF
+
+ fi
+
+ echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6
+echo "configure:3308: checking tm_gmtoff in struct tm" >&5
+ if eval "test \"`echo '$''{'tcl_cv_member_tm_gmtoff'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3313 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
-extern time_t timezone;
- timezone += 1;
- exit (0);
+struct tm tm; tm.tm_gmtoff;
; return 0; }
EOF
-if { (eval echo configure:2835: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3320: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
- cat >> confdefs.h <<\EOF
-#define HAVE_TIMEZONE_VAR 1
-EOF
-
- echo "$ac_t""yes" 1>&6
+ tcl_cv_member_tm_gmtoff=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
- echo "$ac_t""no" 1>&6
+ tcl_cv_member_tm_gmtoff=no
fi
rm -f conftest*
+fi
+
+ echo "$ac_t""$tcl_cv_member_tm_gmtoff" 1>&6
+ if test $tcl_cv_member_tm_gmtoff = yes ; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_TM_GMTOFF 1
+EOF
+
fi
#
- # On some systems (eg Solaris 2.5.1), timezone is not declared in
- # time.h unless you jump through hoops. Instead of that, we just
- # declare it ourselves when necessary.
+ # Its important to include time.h in this check, as some systems
+ # (like convex) have timezone functions, etc.
#
- if test "$have_timezone" = yes; then
- echo $ac_n "checking for timezone declaration""... $ac_c" 1>&6
-echo "configure:2858: checking for timezone declaration" >&5
-
- tzrx='^[ ]*extern.*timezone'
-
- cat > conftest.$ac_ext <<EOF
-#line 2863 "configure"
+ echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
+echo "configure:3345: checking long timezone variable" >&5
+ if eval "test \"`echo '$''{'tcl_cv_var_timezone'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 3350 "configure"
#include "confdefs.h"
#include <time.h>
+int main() {
+extern long timezone;
+ timezone += 1;
+ exit (0);
+; return 0; }
EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "$tzrx" >/dev/null 2>&1; then
+if { (eval echo configure:3359: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
-
- cat >> confdefs.h <<\EOF
-#define HAVE_TIMEZONE_DECL 1
-EOF
-
- echo "$ac_t""found" 1>&6
+ tcl_cv_timezone_long=yes
else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
rm -rf conftest*
- echo "$ac_t""missing" 1>&6
+ tcl_cv_timezone_long=no
fi
rm -f conftest*
+fi
- fi
-
- #
- # AIX does not have a timezone field in struct tm. When the AIX bsd
- # library is used, the timezone global and the gettimeofday methods are
- # to be avoided for timezone deduction instead, we deduce the timezone
- # by comparing the localtime result on a known GMT value.
- #
+ echo "$ac_t""$tcl_cv_timezone_long" 1>&6
+ if test $tcl_cv_timezone_long = yes ; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_TIMEZONE_VAR 1
+EOF
- if test "`uname -s`" = "AIX" ; then
- echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6
-echo "configure:2893: checking for gettimeofday in -lbsd" >&5
-ac_lib_var=`echo bsd'_'gettimeofday | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ else
+ #
+ # On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
+ #
+ echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
+echo "configure:3382: checking time_t timezone variable" >&5
+ if eval "test \"`echo '$''{'tcl_cv_timezone_time'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
- ac_save_LIBS="$LIBS"
-LIBS="-lbsd $LIBS"
-cat > conftest.$ac_ext <<EOF
-#line 2901 "configure"
+ cat > conftest.$ac_ext <<EOF
+#line 3387 "configure"
#include "confdefs.h"
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char gettimeofday();
-
+#include <time.h>
int main() {
-gettimeofday()
+extern time_t timezone;
+ timezone += 1;
+ exit (0);
; return 0; }
EOF
-if { (eval echo configure:2912: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:3396: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=yes"
+ tcl_cv_timezone_time=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=no"
+ tcl_cv_timezone_time=no
fi
rm -f conftest*
-LIBS="$ac_save_LIBS"
-
-fi
-if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- libbsd=yes
-else
- echo "$ac_t""no" 1>&6
fi
- if test $libbsd = yes; then
+ echo "$ac_t""$tcl_cv_timezone_time" 1>&6
+ if test $tcl_cv_timezone_time = yes ; then
cat >> confdefs.h <<\EOF
-#define USE_DELTA_FOR_TZ 1
+#define HAVE_TIMEZONE_VAR 1
EOF
fi
# in struct stat. But we might be able to use fstatfs instead.
#--------------------------------------------------------------------
echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6
-echo "configure:2946: checking for st_blksize in struct stat" >&5
+echo "configure:3423: checking for st_blksize in struct stat" >&5
if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2951 "configure"
+#line 3428 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
struct stat s; s.st_blksize;
; return 0; }
EOF
-if { (eval echo configure:2959: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:3436: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_blksize=yes
else
fi
echo $ac_n "checking for fstatfs""... $ac_c" 1>&6
-echo "configure:2980: checking for fstatfs" >&5
+echo "configure:3457: checking for fstatfs" >&5
if eval "test \"`echo '$''{'ac_cv_func_fstatfs'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 2985 "configure"
+#line 3462 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char fstatfs(); below. */
; return 0; }
EOF
-if { (eval echo configure:3008: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:3485: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_fstatfs=yes"
else
# data, this checks it and add memcmp.o to LIBOBJS if needed
#--------------------------------------------------------------------
echo $ac_n "checking for 8-bit clean memcmp""... $ac_c" 1>&6
-echo "configure:3037: checking for 8-bit clean memcmp" >&5
+echo "configure:3514: checking for 8-bit clean memcmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_memcmp_clean'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_cv_func_memcmp_clean=no
else
cat > conftest.$ac_ext <<EOF
-#line 3045 "configure"
+#line 3522 "configure"
#include "confdefs.h"
main()
}
EOF
-if { (eval echo configure:3055: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3532: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
ac_cv_func_memcmp_clean=yes
else
# {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
echo $ac_n "checking for memmove""... $ac_c" 1>&6
-echo "configure:3079: checking for memmove" >&5
+echo "configure:3556: checking for memmove" >&5
if eval "test \"`echo '$''{'ac_cv_func_memmove'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3084 "configure"
+#line 3561 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char memmove(); below. */
; return 0; }
EOF
-if { (eval echo configure:3107: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:3584: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_memmove=yes"
else
#--------------------------------------------------------------------
echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6
-echo "configure:3140: checking proper strstr implementation" >&5
+echo "configure:3617: checking proper strstr implementation" >&5
if test "$cross_compiling" = yes; then
tcl_ok=no
else
cat > conftest.$ac_ext <<EOF
-#line 3145 "configure"
+#line 3622 "configure"
#include "confdefs.h"
extern int strstr();
}
EOF
-if { (eval echo configure:3155: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3632: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_ok=yes
else
#--------------------------------------------------------------------
echo $ac_n "checking for strtoul""... $ac_c" 1>&6
-echo "configure:3181: checking for strtoul" >&5
+echo "configure:3658: checking for strtoul" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3186 "configure"
+#line 3663 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtoul(); below. */
; return 0; }
EOF
-if { (eval echo configure:3209: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:3686: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strtoul=yes"
else
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 3233 "configure"
+#line 3710 "configure"
#include "confdefs.h"
extern int strtoul();
exit(0);
}
EOF
-if { (eval echo configure:3249: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3726: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
#--------------------------------------------------------------------
echo $ac_n "checking for strtod""... $ac_c" 1>&6
-echo "configure:3272: checking for strtod" >&5
+echo "configure:3749: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3277 "configure"
+#line 3754 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
; return 0; }
EOF
-if { (eval echo configure:3300: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:3777: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strtod=yes"
else
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
-#line 3324 "configure"
+#line 3801 "configure"
#include "confdefs.h"
extern double strtod();
exit(0);
}
EOF
-if { (eval echo configure:3340: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3817: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
echo $ac_n "checking for strtod""... $ac_c" 1>&6
-echo "configure:3366: checking for strtod" >&5
+echo "configure:3843: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3371 "configure"
+#line 3848 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
; return 0; }
EOF
-if { (eval echo configure:3394: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:3871: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strtod=yes"
else
if test "$tcl_strtod" = 1; then
echo $ac_n "checking for Solaris2.4/Tru64 strtod bugs""... $ac_c" 1>&6
-echo "configure:3416: checking for Solaris2.4/Tru64 strtod bugs" >&5
- if test "$cross_compiling" = yes; then
- tcl_ok=0
+echo "configure:3893: checking for Solaris2.4/Tru64 strtod bugs" >&5
+ if eval "test \"`echo '$''{'tcl_cv_strtod_buggy'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+
+ if test "$cross_compiling" = yes; then
+ tcl_cv_strtod_buggy=0
else
cat > conftest.$ac_ext <<EOF
-#line 3421 "configure"
+#line 3902 "configure"
#include "confdefs.h"
- extern double strtod();
- int main()
- {
- char *string = "NaN", *spaceString = " ";
- char *term;
- double value;
- value = strtod(string, &term);
- if ((term != string) && (term[-1] == 0)) {
- exit(1);
- }
- value = strtod(spaceString, &term);
- if (term == (spaceString+1)) {
- exit(1);
+ extern double strtod();
+ int main() {
+ char *infString="Inf", *nanString="NaN", *spaceString=" ";
+ char *term;
+ double value;
+ value = strtod(infString, &term);
+ if ((term != infString) && (term[-1] == 0)) {
+ exit(1);
+ }
+ value = strtod(nanString, &term);
+ if ((term != nanString) && (term[-1] == 0)) {
+ exit(1);
+ }
+ value = strtod(spaceString, &term);
+ if (term == (spaceString+1)) {
+ exit(1);
+ }
+ exit(0);
}
- exit(0);
- }
EOF
-if { (eval echo configure:3441: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:3925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
- tcl_ok=1
+ tcl_cv_strtod_buggy=1
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
- tcl_ok=0
+ tcl_cv_strtod_buggy=0
fi
rm -fr conftest*
fi
- if test "$tcl_ok" = 1; then
+fi
+
+ if test "$tcl_cv_strtod_buggy" = 1; then
echo "$ac_t""ok" 1>&6
else
echo "$ac_t""buggy" 1>&6
#--------------------------------------------------------------------
echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6
-echo "configure:3472: checking for ANSI C header files" >&5
+echo "configure:3958: checking for ANSI C header files" >&5
if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3477 "configure"
+#line 3963 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:3485: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:3971: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
if test $ac_cv_header_stdc = yes; then
# SunOS 4.x string.h does not declare mem*, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 3502 "configure"
+#line 3988 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if test $ac_cv_header_stdc = yes; then
# ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
-#line 3520 "configure"
+#line 4006 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
:
else
cat > conftest.$ac_ext <<EOF
-#line 3541 "configure"
+#line 4027 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
exit (0); }
EOF
-if { (eval echo configure:3552: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:4038: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
fi
echo $ac_n "checking for mode_t""... $ac_c" 1>&6
-echo "configure:3576: checking for mode_t" >&5
+echo "configure:4062: checking for mode_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3581 "configure"
+#line 4067 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
fi
echo $ac_n "checking for pid_t""... $ac_c" 1>&6
-echo "configure:3609: checking for pid_t" >&5
+echo "configure:4095: checking for pid_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3614 "configure"
+#line 4100 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
fi
echo $ac_n "checking for size_t""... $ac_c" 1>&6
-echo "configure:3642: checking for size_t" >&5
+echo "configure:4128: checking for size_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3647 "configure"
+#line 4133 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
fi
echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6
-echo "configure:3675: checking for uid_t in sys/types.h" >&5
+echo "configure:4161: checking for uid_t in sys/types.h" >&5
if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3680 "configure"
+#line 4166 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
fi
+echo $ac_n "checking for socklen_t""... $ac_c" 1>&6
+echo "configure:4196: checking for socklen_t" >&5
+if eval "test \"`echo '$''{'ac_cv_type_socklen_t'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 4201 "configure"
+#include "confdefs.h"
+
+ #include <sys/types.h>
+ #include <sys/socket.h>
+ #if STDC_HEADERS
+ #include <stdlib.h>
+ #include <stddef.h>
+ #endif
+
+EOF
+if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
+ egrep "(^|[^a-zA-Z_0-9])socklen_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then
+ rm -rf conftest*
+ ac_cv_type_socklen_t=yes
+else
+ rm -rf conftest*
+ ac_cv_type_socklen_t=no
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$ac_cv_type_socklen_t" 1>&6
+if test $ac_cv_type_socklen_t = no; then
+ cat >> confdefs.h <<\EOF
+#define socklen_t unsigned
+EOF
+
+fi
+
#--------------------------------------------------------------------
# If a system doesn't have an opendir function (man, that's old!)
# then we have to supply a different version of dirent.h which
#--------------------------------------------------------------------
echo $ac_n "checking for opendir""... $ac_c" 1>&6
-echo "configure:3717: checking for opendir" >&5
+echo "configure:4240: checking for opendir" >&5
if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3722 "configure"
+#line 4245 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char opendir(); below. */
; return 0; }
EOF
-if { (eval echo configure:3745: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4268: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_opendir=yes"
else
# environments. Checking the usability of WIFEXITED seems to do
# the trick.
#--------------------------------------------------------------------
-
-echo $ac_n "checking union wait""... $ac_c" 1>&6
-echo "configure:3778: checking union wait" >&5
-cat > conftest.$ac_ext <<EOF
-#line 3780 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <sys/wait.h>
-int main() {
-
-union wait x;
-WIFEXITED(x); /* Generates compiler error if WIFEXITED
- * uses an int. */
-
-; return 0; }
-EOF
-if { (eval echo configure:3792: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
- rm -rf conftest*
- tcl_ok=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- tcl_ok=no
-fi
-rm -f conftest*
-echo "$ac_t""$tcl_ok" 1>&6
-if test $tcl_ok = no; then
- cat >> confdefs.h <<\EOF
-#define NO_UNION_WAIT 1
-EOF
-
-fi
-
-#--------------------------------------------------------------------
-# Check to see whether the system supports the matherr function
-# and its associated type "struct exception".
-#--------------------------------------------------------------------
-
-echo $ac_n "checking matherr support""... $ac_c" 1>&6
-echo "configure:3816: checking matherr support" >&5
-cat > conftest.$ac_ext <<EOF
-#line 3818 "configure"
-#include "confdefs.h"
-#include <math.h>
-int main() {
-
-struct exception x;
-x.type = DOMAIN;
-x.type = SING;
-
-; return 0; }
-EOF
-if { (eval echo configure:3829: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- tcl_ok=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- tcl_ok=no
-fi
-rm -f conftest*
-echo "$ac_t""$tcl_ok" 1>&6
-if test $tcl_ok = yes; then
- cat >> confdefs.h <<\EOF
-#define NEED_MATHERR 1
-EOF
-
-fi
-
-#--------------------------------------------------------------------
-# Check to see whether the system provides a vfork kernel call.
-# If not, then use fork instead. Also, check for a problem with
-# vforks and signals that can cause core dumps if a vforked child
-# resets a signal handler. If the problem exists, then use fork
-# instead of vfork.
-#--------------------------------------------------------------------
-
-echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6
-echo "configure:3856: checking return type of signal handlers" >&5
-if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 3861 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <signal.h>
-#ifdef signal
-#undef signal
-#endif
-#ifdef __cplusplus
-extern "C" void (*signal (int, void (*)(int)))(int);
-#else
-void (*signal ()) ();
-#endif
-
-int main() {
-int i;
-; return 0; }
-EOF
-if { (eval echo configure:3878: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_type_signal=void
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_type_signal=int
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_type_signal" 1>&6
-cat >> confdefs.h <<EOF
-#define RETSIGTYPE $ac_cv_type_signal
-EOF
-
-
-echo $ac_n "checking for vfork""... $ac_c" 1>&6
-echo "configure:3897: checking for vfork" >&5
-if eval "test \"`echo '$''{'ac_cv_func_vfork'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 3902 "configure"
-#include "confdefs.h"
-/* System header to define __stub macros and hopefully few prototypes,
- which can conflict with char vfork(); below. */
-#include <assert.h>
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char vfork();
-
-int main() {
-
-/* The GNU C library defines this for functions which it implements
- to always fail with ENOSYS. Some functions are actually named
- something starting with __ and the normal name is an alias. */
-#if defined (__stub_vfork) || defined (__stub___vfork)
-choke me
-#else
-vfork();
-#endif
-
-; return 0; }
-EOF
-if { (eval echo configure:3925: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
- rm -rf conftest*
- eval "ac_cv_func_vfork=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_func_vfork=no"
-fi
-rm -f conftest*
-fi
-
-if eval "test \"`echo '$ac_cv_func_'vfork`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- tcl_ok=1
-else
- echo "$ac_t""no" 1>&6
-tcl_ok=0
-fi
-
-if test "$tcl_ok" = 1; then
- echo $ac_n "checking vfork/signal bug""... $ac_c" 1>&6
-echo "configure:3947: checking vfork/signal bug" >&5;
- if test "$cross_compiling" = yes; then
- tcl_ok=0
+
+echo $ac_n "checking union wait""... $ac_c" 1>&6
+echo "configure:4301: checking union wait" >&5
+if eval "test \"`echo '$''{'tcl_cv_union_wait'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 3952 "configure"
+#line 4306 "configure"
#include "confdefs.h"
-
-#include <stdio.h>
-#include <signal.h>
+#include <sys/types.h>
#include <sys/wait.h>
-int gotSignal = 0;
-sigProc(sig)
- int sig;
-{
- gotSignal = 1;
-}
-main()
-{
- int pid, sts;
- (void) signal(SIGCHLD, sigProc);
- pid = vfork();
- if (pid < 0) {
- exit(1);
- } else if (pid == 0) {
- (void) signal(SIGCHLD, SIG_DFL);
- _exit(0);
- } else {
- (void) wait(&sts);
- }
- exit((gotSignal) ? 0 : 1);
-}
+int main() {
+
+union wait x;
+WIFEXITED(x); /* Generates compiler error if WIFEXITED
+ * uses an int. */
+
+; return 0; }
EOF
-if { (eval echo configure:3980: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
-then
- tcl_ok=1
+if { (eval echo configure:4318: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+ rm -rf conftest*
+ tcl_cv_union_wait=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
- rm -fr conftest*
- tcl_ok=0
+ rm -rf conftest*
+ tcl_cv_union_wait=no
fi
-rm -fr conftest*
+rm -f conftest*
fi
- if test "$tcl_ok" = 1; then
- echo "$ac_t""ok" 1>&6
- else
- echo "$ac_t""buggy, using fork instead" 1>&6
- fi
-fi
-rm -f core
-if test "$tcl_ok" = 0; then
+echo "$ac_t""$tcl_cv_union_wait" 1>&6
+if test $tcl_cv_union_wait = no; then
cat >> confdefs.h <<\EOF
-#define vfork fork
+#define NO_UNION_WAIT 1
EOF
fi
#--------------------------------------------------------------------
echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6
-echo "configure:4013: checking for strncasecmp" >&5
+echo "configure:4345: checking for strncasecmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4018 "configure"
+#line 4350 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strncasecmp(); below. */
; return 0; }
EOF
-if { (eval echo configure:4041: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4373: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strncasecmp=yes"
else
if test "$tcl_ok" = 0; then
echo $ac_n "checking for strncasecmp in -lsocket""... $ac_c" 1>&6
-echo "configure:4063: checking for strncasecmp in -lsocket" >&5
+echo "configure:4395: checking for strncasecmp in -lsocket" >&5
ac_lib_var=`echo socket'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4071 "configure"
+#line 4403 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
strncasecmp()
; return 0; }
EOF
-if { (eval echo configure:4082: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4414: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
if test "$tcl_ok" = 0; then
echo $ac_n "checking for strncasecmp in -linet""... $ac_c" 1>&6
-echo "configure:4106: checking for strncasecmp in -linet" >&5
+echo "configure:4438: checking for strncasecmp in -linet" >&5
ac_lib_var=`echo inet'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4114 "configure"
+#line 4446 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
strncasecmp()
; return 0; }
EOF
-if { (eval echo configure:4125: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4457: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
#--------------------------------------------------------------------
echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6
-echo "configure:4163: checking for BSDgettimeofday" >&5
+echo "configure:4495: checking for BSDgettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4168 "configure"
+#line 4500 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char BSDgettimeofday(); below. */
; return 0; }
EOF
-if { (eval echo configure:4191: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4523: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_BSDgettimeofday=yes"
else
else
echo "$ac_t""no" 1>&6
-echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
-echo "configure:4212: checking for gettimeofday" >&5
+
+ echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
+echo "configure:4545: checking for gettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4217 "configure"
+#line 4550 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gettimeofday(); below. */
; return 0; }
EOF
-if { (eval echo configure:4240: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4573: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gettimeofday=yes"
else
fi
+
fi
echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6
-echo "configure:4266: checking for gettimeofday declaration" >&5
-cat > conftest.$ac_ext <<EOF
-#line 4268 "configure"
+echo "configure:4600: checking for gettimeofday declaration" >&5
+if eval "test \"`echo '$''{'tcl_cv_grep_gettimeofday'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 4605 "configure"
#include "confdefs.h"
#include <sys/time.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "gettimeofday" >/dev/null 2>&1; then
rm -rf conftest*
- echo "$ac_t""present" 1>&6
+ tcl_cv_grep_gettimeofday=present
else
rm -rf conftest*
-
- echo "$ac_t""missing" 1>&6
+ tcl_cv_grep_gettimeofday=missing
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$tcl_cv_grep_gettimeofday" 1>&6
+if test $tcl_cv_grep_gettimeofday = missing ; then
cat >> confdefs.h <<\EOF
#define GETTOD_NOT_DECLARED 1
EOF
-
fi
-rm -f conftest*
-
#--------------------------------------------------------------------
# The following code checks to see whether it is possible to get
#--------------------------------------------------------------------
echo $ac_n "checking whether char is unsigned""... $ac_c" 1>&6
-echo "configure:4296: checking whether char is unsigned" >&5
+echo "configure:4636: checking whether char is unsigned" >&5
if eval "test \"`echo '$''{'ac_cv_c_char_unsigned'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$GCC" = yes; then
# GCC predefines this symbol on systems where it applies.
cat > conftest.$ac_ext <<EOF
-#line 4303 "configure"
+#line 4643 "configure"
#include "confdefs.h"
#ifdef __CHAR_UNSIGNED__
yes
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
cat > conftest.$ac_ext <<EOF
-#line 4325 "configure"
+#line 4665 "configure"
#include "confdefs.h"
/* volatile prevents gcc2 from optimizing the test away on sparcs. */
#if !defined(__STDC__) || __STDC__ != 1
volatile char c = 255; exit(c < 0);
}
EOF
-if { (eval echo configure:4335: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+if { (eval echo configure:4675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
ac_cv_c_char_unsigned=yes
else
fi
echo $ac_n "checking signed char declarations""... $ac_c" 1>&6
-echo "configure:4359: checking signed char declarations" >&5
-cat > conftest.$ac_ext <<EOF
-#line 4361 "configure"
+echo "configure:4699: checking signed char declarations" >&5
+if eval "test \"`echo '$''{'tcl_cv_char_signed'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 4704 "configure"
#include "confdefs.h"
int main() {
-signed char *p;
-p = 0;
-
+ signed char *p;
+ p = 0;
+
; return 0; }
EOF
-if { (eval echo configure:4371: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:4714: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
- tcl_ok=yes
+ tcl_cv_char_signed=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
- tcl_ok=no
+ tcl_cv_char_signed=no
fi
rm -f conftest*
-echo "$ac_t""$tcl_ok" 1>&6
-if test $tcl_ok = yes; then
+fi
+
+echo "$ac_t""$tcl_cv_char_signed" 1>&6
+if test $tcl_cv_char_signed = yes; then
cat >> confdefs.h <<\EOF
#define HAVE_SIGNED_CHAR 1
EOF
fi
+#--------------------------------------------------------------------
+# Does putenv() copy or not? We need to know to avoid memory leaks.
+#--------------------------------------------------------------------
+
+echo $ac_n "checking for a putenv() that copies the buffer""... $ac_c" 1>&6
+echo "configure:4739: checking for a putenv() that copies the buffer" >&5
+if eval "test \"`echo '$''{'tcl_cv_putenv_copy'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ if test "$cross_compiling" = yes; then
+ tcl_cv_putenv_copy=no
+else
+ cat > conftest.$ac_ext <<EOF
+#line 4747 "configure"
+#include "confdefs.h"
+
+ #include <stdlib.h>
+ #define OURVAR "havecopy=yes"
+ int main (int argc, char *argv)
+ {
+ char *foo, *bar;
+ foo = (char *)strdup(OURVAR);
+ putenv(foo);
+ strcpy((char *)(strchr(foo, '=') + 1), "no");
+ bar = getenv("havecopy");
+ if (!strcmp(bar, "no")) {
+ /* doesnt copy */
+ return 0;
+ } else {
+ /* does copy */
+ return 1;
+ }
+ }
+
+EOF
+if { (eval echo configure:4769: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+then
+ tcl_cv_putenv_copy=no
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ tcl_cv_putenv_copy=yes
+fi
+rm -fr conftest*
+fi
+
+
+fi
+
+echo "$ac_t""$tcl_cv_putenv_copy" 1>&6
+if test $tcl_cv_putenv_copy = yes; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_PUTENV_THAT_COPIES 1
+EOF
+
+fi
+
+#--------------------------------------------------------------------
+# Check for support of nl_langinfo function
+#--------------------------------------------------------------------
+
+
+ # Check whether --enable-langinfo or --disable-langinfo was given.
+if test "${enable_langinfo+set}" = set; then
+ enableval="$enable_langinfo"
+ langinfo_ok=$enableval
+else
+ langinfo_ok=yes
+fi
+
+
+ HAVE_LANGINFO=0
+ if test "$langinfo_ok" = "yes"; then
+ if test "$langinfo_ok" = "yes"; then
+ ac_safe=`echo "langinfo.h" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for langinfo.h""... $ac_c" 1>&6
+echo "configure:4811: checking for langinfo.h" >&5
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 4816 "configure"
+#include "confdefs.h"
+#include <langinfo.h>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:4821: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=yes"
+else
+ echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ langinfo_ok=yes
+else
+ echo "$ac_t""no" 1>&6
+langinfo_ok=no
+fi
+
+ fi
+ fi
+ echo $ac_n "checking whether to use nl_langinfo""... $ac_c" 1>&6
+echo "configure:4846: checking whether to use nl_langinfo" >&5
+ if test "$langinfo_ok" = "yes"; then
+ cat > conftest.$ac_ext <<EOF
+#line 4849 "configure"
+#include "confdefs.h"
+#include <langinfo.h>
+int main() {
+nl_langinfo(CODESET);
+; return 0; }
+EOF
+if { (eval echo configure:4856: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ langinfo_ok=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ langinfo_ok=no
+fi
+rm -f conftest*
+ if test "$langinfo_ok" = "no"; then
+ langinfo_ok="no (could not compile with nl_langinfo)";
+ fi
+ if test "$langinfo_ok" = "yes"; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_LANGINFO 1
+EOF
+
+ fi
+ fi
+ echo "$ac_t""$langinfo_ok" 1>&6
+
#--------------------------------------------------------------------
# Look for libraries that we will need when compiling the Tcl shell
#--------------------------------------------------------------------
echo $ac_n "checking for sin""... $ac_c" 1>&6
-echo "configure:4403: checking for sin" >&5
+echo "configure:4892: checking for sin" >&5
if eval "test \"`echo '$''{'ac_cv_func_sin'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4408 "configure"
+#line 4897 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char sin(); below. */
; return 0; }
EOF
-if { (eval echo configure:4431: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4920: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_sin=yes"
else
fi
echo $ac_n "checking for main in -lieee""... $ac_c" 1>&6
-echo "configure:4452: checking for main in -lieee" >&5
+echo "configure:4941: checking for main in -lieee" >&5
ac_lib_var=`echo ieee'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-lieee $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4460 "configure"
+#line 4949 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:4467: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4956: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
#--------------------------------------------------------------------
- # On AIX systems, libbsd.a has to be linked in to support
- # non-blocking file IO. This library has to be linked in after
- # the MATH_LIBS or it breaks the pow() function. The way to
- # insure proper sequencing, is to add it to the tail of MATH_LIBS.
- # This library also supplies gettimeofday.
- #--------------------------------------------------------------------
-
- libbsd=no
- if test "`uname -s`" = "AIX" ; then
- echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6
-echo "configure:4499: checking for gettimeofday in -lbsd" >&5
-ac_lib_var=`echo bsd'_'gettimeofday | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- ac_save_LIBS="$LIBS"
-LIBS="-lbsd $LIBS"
-cat > conftest.$ac_ext <<EOF
-#line 4507 "configure"
-#include "confdefs.h"
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char gettimeofday();
-
-int main() {
-gettimeofday()
-; return 0; }
-EOF
-if { (eval echo configure:4518: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=no"
-fi
-rm -f conftest*
-LIBS="$ac_save_LIBS"
-
-fi
-if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- libbsd=yes
-else
- echo "$ac_t""no" 1>&6
-fi
-
- if test $libbsd = yes; then
- MATH_LIBS="$MATH_LIBS -lbsd"
- fi
- fi
-
-
- #--------------------------------------------------------------------
# Interactive UNIX requires -linet instead of -lsocket, plus it
# needs net/errno.h to define the socket-related error codes.
#--------------------------------------------------------------------
echo $ac_n "checking for main in -linet""... $ac_c" 1>&6
-echo "configure:4550: checking for main in -linet" >&5
+echo "configure:4983: checking for main in -linet" >&5
ac_lib_var=`echo inet'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4558 "configure"
+#line 4991 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
-if { (eval echo configure:4565: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:4998: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
ac_safe=`echo "net/errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for net/errno.h""... $ac_c" 1>&6
-echo "configure:4587: checking for net/errno.h" >&5
+echo "configure:5020: checking for net/errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4592 "configure"
+#line 5025 "configure"
#include "confdefs.h"
#include <net/errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:4597: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:5030: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
# if -lsocket doesn't work by itself.
#--------------------------------------------------------------------
- # CYGNUS LOCAL: Store any socket library(ies) in the cache, and don't
- # mess up the cache values of the functions we check for.
- echo $ac_n "checking for socket libraries""... $ac_c" 1>&6
-echo "configure:4643: checking for socket libraries" >&5
-if eval "test \"`echo '$''{'tcl_cv_lib_sockets'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- tcl_cv_lib_sockets=
- tcl_checkBoth=0
- unset ac_cv_func_connect
- echo $ac_n "checking for connect""... $ac_c" 1>&6
-echo "configure:4651: checking for connect" >&5
+ tcl_checkBoth=0
+ echo $ac_n "checking for connect""... $ac_c" 1>&6
+echo "configure:5075: checking for connect" >&5
if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4656 "configure"
+#line 5080 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
; return 0; }
EOF
-if { (eval echo configure:4679: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:5103: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_connect=yes"
else
tcl_checkSocket=1
fi
- if test "$tcl_checkSocket" = 1; then
- unset ac_cv_func_connect
- echo $ac_n "checking for main in -lsocket""... $ac_c" 1>&6
-echo "configure:4702: checking for main in -lsocket" >&5
-ac_lib_var=`echo socket'_'main | sed 'y%./+-%__p_%'`
+ if test "$tcl_checkSocket" = 1; then
+ echo $ac_n "checking for setsockopt""... $ac_c" 1>&6
+echo "configure:5125: checking for setsockopt" >&5
+if eval "test \"`echo '$''{'ac_cv_func_setsockopt'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 5130 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+ which can conflict with char setsockopt(); below. */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char setsockopt();
+
+int main() {
+
+/* The GNU C library defines this for functions which it implements
+ to always fail with ENOSYS. Some functions are actually named
+ something starting with __ and the normal name is an alias. */
+#if defined (__stub_setsockopt) || defined (__stub___setsockopt)
+choke me
+#else
+setsockopt();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:5153: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+ rm -rf conftest*
+ eval "ac_cv_func_setsockopt=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_func_setsockopt=no"
+fi
+rm -f conftest*
+fi
+
+if eval "test \"`echo '$ac_cv_func_'setsockopt`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ :
+else
+ echo "$ac_t""no" 1>&6
+echo $ac_n "checking for setsockopt in -lsocket""... $ac_c" 1>&6
+echo "configure:5171: checking for setsockopt in -lsocket" >&5
+ac_lib_var=`echo socket'_'setsockopt | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4710 "configure"
+#line 5179 "configure"
#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char setsockopt();
int main() {
-main()
+setsockopt()
; return 0; }
EOF
-if { (eval echo configure:4717: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:5190: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
echo "$ac_t""yes" 1>&6
- tcl_cv_lib_sockets="-lsocket"
+ LIBS="$LIBS -lsocket"
else
echo "$ac_t""no" 1>&6
tcl_checkBoth=1
fi
- fi
- if test "$tcl_checkBoth" = 1; then
- tcl_oldLibs=$LIBS
- LIBS="$LIBS -lsocket -lnsl"
- unset ac_cv_func_accept
- echo $ac_n "checking for accept""... $ac_c" 1>&6
-echo "configure:4744: checking for accept" >&5
+fi
+
+ fi
+ if test "$tcl_checkBoth" = 1; then
+ tk_oldLibs=$LIBS
+ LIBS="$LIBS -lsocket -lnsl"
+ echo $ac_n "checking for accept""... $ac_c" 1>&6
+echo "configure:5218: checking for accept" >&5
if eval "test \"`echo '$''{'ac_cv_func_accept'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4749 "configure"
+#line 5223 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char accept(); below. */
; return 0; }
EOF
-if { (eval echo configure:4772: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:5246: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_accept=yes"
else
if eval "test \"`echo '$ac_cv_func_'accept`\" = yes"; then
echo "$ac_t""yes" 1>&6
tcl_checkNsl=0
- tcl_cv_lib_sockets="-lsocket -lnsl"
else
echo "$ac_t""no" 1>&6
+LIBS=$tk_oldLibs
fi
- unset ac_cv_func_accept
- LIBS=$tcl_oldLibs
- fi
- unset ac_cv_func_gethostbyname
- tcl_oldLibs=$LIBS
- LIBS="$LIBS $tcl_cv_lib_sockets"
- echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
-echo "configure:4799: checking for gethostbyname" >&5
+ fi
+ echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
+echo "configure:5268: checking for gethostbyname" >&5
if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 4804 "configure"
+#line 5273 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
; return 0; }
EOF
-if { (eval echo configure:4827: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:5296: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gethostbyname=yes"
else
:
else
echo "$ac_t""no" 1>&6
-echo $ac_n "checking for main in -lnsl""... $ac_c" 1>&6
-echo "configure:4845: checking for main in -lnsl" >&5
-ac_lib_var=`echo nsl'_'main | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
+echo "configure:5314: checking for gethostbyname in -lnsl" >&5
+ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lnsl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 4853 "configure"
+#line 5322 "configure"
#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char gethostbyname();
int main() {
-main()
+gethostbyname()
; return 0; }
EOF
-if { (eval echo configure:4860: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:5333: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
echo "$ac_t""yes" 1>&6
- tcl_cv_lib_sockets="$tcl_cv_lib_sockets -lnsl"
+ LIBS="$LIBS -lnsl"
else
echo "$ac_t""no" 1>&6
fi
fi
- unset ac_cv_func_gethostbyname
- LIBS=$tcl_oldLIBS
-
-fi
-
-echo "$ac_t""$tcl_cv_lib_sockets" 1>&6
- test -z "$tcl_cv_lib_sockets" || LIBS="$LIBS $tcl_cv_lib_sockets"
# Don't perform the eval of the libraries here because DL_LIBS
# won't be set until we call SC_CONFIG_CFLAGS
- TCL_LIBS='${DL_LIBS} ${LIBS} ${MATH_LIBS}'
-
-
+ TCL_LIBS='${DL_LIBS} ${LIBS} ${MATH_LIBS}'
+
+
+
+
+# Add the threads support libraries
+
+LIBS="$LIBS$THREADS_LIBS"
+
+
+ echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
+echo "configure:5370: checking how to build libraries" >&5
+ # Check whether --enable-shared or --disable-shared was given.
+if test "${enable_shared+set}" = set; then
+ enableval="$enable_shared"
+ tcl_ok=$enableval
+else
+ tcl_ok=no
+fi
+
+ if test "${enable_shared+set}" = set; then
+ enableval="$enable_shared"
+ tcl_ok=$enableval
+ else
+ tcl_ok=no
+ fi
-# Add the threads support libraries
+ if test "$tcl_ok" = "yes" ; then
+ echo "$ac_t""shared" 1>&6
+ SHARED_BUILD=1
+ else
+ echo "$ac_t""static" 1>&6
+ SHARED_BUILD=0
+ cat >> confdefs.h <<\EOF
+#define STATIC_BUILD 1
+EOF
+
+ fi
-LIBS="$LIBS$THREADS_LIBS"
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
+# Extract the first word of "ranlib", so it can be a program name with args.
+set dummy ranlib; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+echo "configure:5409: checking for $ac_word" >&5
+if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ if test -n "$RANLIB"; then
+ ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
+else
+ IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
+ ac_dummy="$PATH"
+ for ac_dir in $ac_dummy; do
+ test -z "$ac_dir" && ac_dir=.
+ if test -f $ac_dir/$ac_word; then
+ ac_cv_prog_RANLIB="ranlib"
+ break
+ fi
+ done
+ IFS="$ac_save_ifs"
+ test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
+fi
+fi
+RANLIB="$ac_cv_prog_RANLIB"
+if test -n "$RANLIB"; then
+ echo "$ac_t""$RANLIB" 1>&6
+else
+ echo "$ac_t""no" 1>&6
+fi
+
# Step 0.a: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
-echo "configure:4913: checking if 64bit support is requested" >&5
+echo "configure:5441: checking if 64bit support is requested" >&5
# Check whether --enable-64bit or --disable-64bit was given.
if test "${enable_64bit+set}" = set; then
enableval="$enable_64bit"
# Step 0.b: Enable Solaris 64 bit VIS support?
echo $ac_n "checking if 64bit Sparc VIS support is requested""... $ac_c" 1>&6
-echo "configure:4933: checking if 64bit Sparc VIS support is requested" >&5
+echo "configure:5461: checking if 64bit Sparc VIS support is requested" >&5
# Check whether --enable-64bit-vis or --disable-64bit-vis was given.
if test "${enable_64bit_vis+set}" = set; then
enableval="$enable_64bit_vis"
# there are a few systems, like Next, where this doesn't work.
echo $ac_n "checking system version (for dynamic loading)""... $ac_c" 1>&6
-echo "configure:4957: checking system version (for dynamic loading)" >&5
+echo "configure:5485: checking system version (for dynamic loading)" >&5
if test -f /usr/lib/NextStep/software_version; then
system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
else
fi
fi
- echo $ac_n "checking if gcc is being used""... $ac_c" 1>&6
-echo "configure:4980: checking if gcc is being used" >&5
- if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then
- using_gcc="yes"
- else
- using_gcc="no"
- fi
-
- echo "$ac_t""$using_gcc ($CC)" 1>&6
-
# Step 2: check for existence of -ldl library. This is needed because
# Linux can use either -ldl or -ldld for dynamic loading.
echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
-echo "configure:4993: checking for dlopen in -ldl" >&5
+echo "configure:5511: checking for dlopen in -ldl" >&5
ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-ldl $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 5001 "configure"
+#line 5519 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
dlopen()
; return 0; }
EOF
-if { (eval echo configure:5012: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:5530: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
fi
+ # Require ranlib early so we can override it in special cases below.
+
+
+
# Step 3: set configuration options based on system name and version.
do64bit_ok=no
- fullSrcDir=`cd $srcdir; pwd`
EXTRA_CFLAGS=""
TCL_EXPORT_FILE_SUFFIX=""
UNSHARED_LIB_SUFFIX=""
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE=-O
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
CFLAGS_WARNING="-Wall -Wconversion -Wno-implicit-int"
else
CFLAGS_WARNING=""
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:5057: checking for $ac_word" >&5
+echo "configure:5578: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
STLIB_LD='${AR} cr'
+ LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
+ PLAT_OBJS=""
case $system in
- AIX-4.[2-9])
- if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then
+ AIX-5.*)
+ if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
# AIX requires the _r compiler when gcc isn't being used
if test "${CC}" != "cc_r" ; then
CC=${CC}_r
fi
echo "$ac_t""Using $CC for compiling with threads" 1>&6
fi
+ LIBS="$LIBS -lc"
+ # AIX-5 uses ELF style dynamic libraries
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
+ if test "`uname -m`" = "ia64" ; then
+ # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC
+ SHLIB_LD="/usr/ccs/bin/ld -G -z text"
+ # AIX-5 has dl* in libc.so
+ DL_LIBS=""
+ if test "$GCC" = "yes" ; then
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ else
+ CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
+ fi
+ LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
+ else
+ SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
+ DL_LIBS="-ldl"
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ TCL_NEEDS_EXP_FILE=1
+ TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
+ fi
+
+ # Note: need the LIBS below, otherwise Tk won't find Tcl's
+ # symbols when dynamically loaded into tclsh.
+
DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
- TCL_NEEDS_EXP_FILE=1
- TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
+
+ LD_LIBRARY_PATH_VAR="LIBPATH"
+
+ # Check to enable 64-bit flags for compiler/linker
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
+ else
+ do64bit_ok=yes
+ EXTRA_CFLAGS="-q64"
+ LDFLAGS="-q64"
+ RANLIB="${RANLIB} -X64"
+ AR="${AR} -X64"
+ SHLIB_LD_FLAGS="-b64"
+ fi
+ fi
;;
AIX-*)
- if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then
+ if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
# AIX requires the _r compiler when gcc isn't being used
if test "${CC}" != "cc_r" ; then
CC=${CC}_r
fi
echo "$ac_t""Using $CC for compiling with threads" 1>&6
fi
+ LIBS="$LIBS -lc"
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
+ SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
- LIBOBJS="$LIBOBJS tclLoadAix.o"
- DL_LIBS="-lld"
+ DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ LD_LIBRARY_PATH_VAR="LIBPATH"
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
+
+ # AIX v<=4.1 has some different flags than 4.2+
+ if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
+ LIBOBJS="$LIBOBJS tclLoadAix.o"
+ DL_LIBS="-lld"
+ fi
+
+ # On AIX <=v4 systems, libbsd.a has to be linked in to support
+ # non-blocking file IO. This library has to be linked in after
+ # the MATH_LIBS or it breaks the pow() function. The way to
+ # insure proper sequencing, is to add it to the tail of MATH_LIBS.
+ # This library also supplies gettimeofday.
+ #
+ # AIX does not have a timezone field in struct tm. When the AIX
+ # bsd library is used, the timezone global and the gettimeofday
+ # methods are to be avoided for timezone deduction instead, we
+ # deduce the timezone by comparing the localtime result on a
+ # known GMT value.
+
+ echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6
+echo "configure:5704: checking for gettimeofday in -lbsd" >&5
+ac_lib_var=`echo bsd'_'gettimeofday | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_save_LIBS="$LIBS"
+LIBS="-lbsd $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 5712 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char gettimeofday();
+
+int main() {
+gettimeofday()
+; return 0; }
+EOF
+if { (eval echo configure:5723: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ libbsd=yes
+else
+ echo "$ac_t""no" 1>&6
+libbsd=no
+fi
+
+ if test $libbsd = yes; then
+ MATH_LIBS="$MATH_LIBS -lbsd"
+ cat >> confdefs.h <<\EOF
+#define USE_DELTA_FOR_TZ 1
+EOF
+
+ fi
+
+ # Check to enable 64-bit flags for compiler/linker
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
+ else
+ do64bit_ok=yes
+ EXTRA_CFLAGS="-q64"
+ LDFLAGS="-q64"
+ RANLIB="${RANLIB} -X64"
+ AR="${AR} -X64"
+ SHLIB_LD_FLAGS="-b64"
+ fi
+ fi
;;
BSD/OS-2.1*|BSD/OS-3*)
SHLIB_CFLAGS=""
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
BSD/OS-4.*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="-export-dynamic"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
dgux*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
- HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*|HP-UX-*.11.*)
+ HP-UX-*.11.*)
+ # Use updated header definitions where possible
+ cat >> confdefs.h <<\EOF
+#define _XOPEN_SOURCE_EXTENDED 1
+EOF
+
+
+ SHLIB_SUFFIX=".sl"
+ echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
+echo "configure:5808: checking for shl_load in -ldld" >&5
+ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ ac_save_LIBS="$LIBS"
+LIBS="-ldld $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 5816 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error. */
+/* We use char because int might match the return type of a gcc2
+ builtin and then its argument prototype would still apply. */
+char shl_load();
+
+int main() {
+shl_load()
+; return 0; }
+EOF
+if { (eval echo configure:5827: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=yes"
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+ tcl_ok=yes
+else
+ echo "$ac_t""no" 1>&6
+tcl_ok=no
+fi
+
+ if test "$tcl_ok" = yes; then
+ SHLIB_CFLAGS="+z"
+ SHLIB_LD="ld -b"
+ SHLIB_LD_LIBS='${LIBS}'
+ DL_OBJS="tclLoadShl.o"
+ DL_LIBS="-ldld"
+ LDFLAGS="-Wl,-E"
+ CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
+ LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
+ LD_LIBRARY_PATH_VAR="SHLIB_PATH"
+ fi
+
+ # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
+ #EXTRA_CFLAGS="+DAportable"
+
+ # Check to enable 64-bit flags for compiler/linker
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ hpux_arch=`gcc -dumpmachine`
+ case $hpux_arch in
+ hppa64*)
+ # 64-bit gcc in use. Fix flags for GNU ld.
+ do64bit_ok=yes
+ SHLIB_LD="gcc -shared"
+ SHLIB_LD_LIBS=""
+ LD_SEARCH_FLAGS=''
+ CC_SEARCH_FLAGS=''
+ ;;
+ *)
+ echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
+ ;;
+ esac
+ else
+ do64bit_ok=yes
+ EXTRA_CFLAGS="+DA2.0W"
+ LDFLAGS="+DA2.0W $LDFLAGS"
+ fi
+ fi
+ ;;
+ HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
SHLIB_SUFFIX=".sl"
echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
-echo "configure:5157: checking for shl_load in -ldld" >&5
+echo "configure:5890: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
ac_save_LIBS="$LIBS"
LIBS="-ldld $LIBS"
cat > conftest.$ac_ext <<EOF
-#line 5165 "configure"
+#line 5898 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
shl_load()
; return 0; }
EOF
-if { (eval echo configure:5176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:5909: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="-Wl,-E"
- LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
+ CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
+ LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
+ LD_LIBRARY_PATH_VAR="SHLIB_PATH"
fi
;;
IRIX-4.*)
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="-Wl,-D,08000000"
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
;;
- IRIX-5.*|IRIX-6.*|IRIX64-6.5*)
+ IRIX-5.*)
+ SHLIB_CFLAGS=""
+ SHLIB_LD="ld -shared -rdata_shared"
+ SHLIB_LD_LIBS='${LIBS}'
+ SHLIB_SUFFIX=".so"
+ DL_OBJS="tclLoadDl.o"
+ DL_LIBS=""
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ EXTRA_CFLAGS=""
+ LDFLAGS=""
+ ;;
+ IRIX-6.*|IRIX64-6.5*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
- if test "$using_gcc" = "yes" ; then
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ if test "$GCC" = "yes" ; then
EXTRA_CFLAGS="-mabi=n32"
LDFLAGS="-mabi=n32"
else
LDFLAGS="-n32"
fi
;;
- IRIX64-6.*)
- SHLIB_CFLAGS=""
- SHLIB_LD="ld -32 -shared -rdata_shared"
- SHLIB_LD_LIBS='${LIBS}'
- SHLIB_SUFFIX=".so"
- DL_OBJS="tclLoadDl.o"
- DL_LIBS=""
- LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
- ;;
- Linux*)
+ IRIX64-6.*)
+ SHLIB_CFLAGS=""
+ SHLIB_LD="ld -n32 -shared -rdata_shared"
+ SHLIB_LD_LIBS='${LIBS}'
+ SHLIB_SUFFIX=".so"
+ DL_OBJS="tclLoadDl.o"
+ DL_LIBS=""
+ LDFLAGS=""
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+
+ # Check to enable 64-bit flags for compiler/linker
+
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ echo "configure: warning: 64bit mode not supported by gcc" 1>&2
+ else
+ do64bit_ok=yes
+ SHLIB_LD="ld -64 -shared -rdata_shared"
+ EXTRA_CFLAGS="-64"
+ LDFLAGS="-64"
+ fi
+ fi
+ ;;
+ Linux*)
+ SHLIB_CFLAGS="-fPIC"
+ SHLIB_LD_LIBS='${LIBS}'
+ SHLIB_SUFFIX=".so"
+
+ # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
+ # when you inline the string and math operations. Turn this off to
+ # get rid of the warnings.
+
+ CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
+
+ if test "$have_dl" = yes; then
+ SHLIB_LD="${CC} -shared"
+ DL_OBJS="tclLoadDl.o"
+ DL_LIBS="-ldl"
+ LDFLAGS="-rdynamic"
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ else
+ ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for dld.h""... $ac_c" 1>&6
+echo "configure:6036: checking for dld.h" >&5
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 6041 "configure"
+#include "confdefs.h"
+#include <dld.h>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:6046: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
+if test -z "$ac_err"; then
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=yes"
+else
+ echo "$ac_err" >&5
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+ echo "$ac_t""yes" 1>&6
+
+ SHLIB_LD="ld -shared"
+ DL_OBJS="tclLoadDld.o"
+ DL_LIBS="-ldld"
+ LDFLAGS=""
+ CC_SEARCH_FLAGS=""
+ LD_SEARCH_FLAGS=""
+else
+ echo "$ac_t""no" 1>&6
+fi
+
+ fi
+ if test "`uname -m`" = "alpha" ; then
+ EXTRA_CFLAGS="-mieee"
+ fi
+
+ # The combo of gcc + glibc has a bug related
+ # to inlining of functions like strtod(). The
+ # -fno-builtin flag should address this problem
+ # but it does not work. The -fno-inline flag
+ # is kind of overkill but it works.
+ # Disable inlining only when one of the
+ # files in compat/*.c is being linked in.
+ if test x"${LIBOBJS}" != x ; then
+ EXTRA_CFLAGS="${EXTRA_CFLAGS} -fno-inline"
+ fi
+
+ # XIM peeking works under XFree86.
+ cat >> confdefs.h <<\EOF
+#define PEEK_XCLOSEIM 1
+EOF
+
+
+ ;;
+ GNU*)
SHLIB_CFLAGS="-fPIC"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
- # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
- # when you inline the string and math operations. Turn this off to
- # get rid of the warnings.
-
- CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
-
if test "$have_dl" = yes; then
SHLIB_LD="${CC} -shared"
- DL_OBJS="tclLoadDl.o"
+ DL_OBJS=""
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS=""
+ LD_SEARCH_FLAGS=""
else
ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
-echo "configure:5272: checking for dld.h" >&5
+echo "configure:6111: checking for dld.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5277 "configure"
+#line 6116 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5282: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6121: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
SHLIB_LD="ld -shared"
- DL_OBJS="tclLoadDld.o"
+ DL_OBJS=""
DL_LIBS="-ldld"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
else
echo "$ac_t""no" 1>&6
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
MP-RAS-*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="-Wl,-Bexport"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
NetBSD-*|FreeBSD-[1-2].*|OpenBSD-*)
# Not available on all versions: check for include file.
ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
-echo "configure:5337: checking for dlfcn.h" >&5
+echo "configure:6179: checking for dlfcn.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5342 "configure"
+#line 6184 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5347: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6189: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
echo $ac_n "checking for ELF""... $ac_c" 1>&6
-echo "configure:5374: checking for ELF" >&5
+echo "configure:6217: checking for ELF" >&5
cat > conftest.$ac_ext <<EOF
-#line 5376 "configure"
+#line 6219 "configure"
#include "confdefs.h"
#ifdef __ELF__
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
fi
# FreeBSD 3.* and greater have ELF.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
- SHLIB_LD_LIBS=""
+ SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="-export-dynamic"
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ if test "${TCL_THREADS}" = "1" ; then
+ # The -pthread needs to go in the CFLAGS, not LIBS
+ LIBS=`echo $LIBS | sed s/-pthread//`
+ EXTRA_CFLAGS="-pthread"
+ LDFLAGS="$LDFLAGS -pthread"
+ fi
+ case $system in
+ FreeBSD-3.*)
+ # FreeBSD-3 doesn't handle version numbers with dots.
+ UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
+ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
+ TCL_LIB_VERSIONS_OK=nodots
+ ;;
+ esac
+ ;;
+ Rhapsody-*|Darwin-*)
+ SHLIB_CFLAGS="-fno-common"
+ SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
+ TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"
+ TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TK_LIB_FILE} -prebind -seg1addr 0xb000000"
+ SHLIB_LD_LIBS='${LIBS}'
+ SHLIB_SUFFIX=".dylib"
+ DL_OBJS="tclLoadDyld.o"
+ PLAT_OBJS="tclMacOSXBundle.o"
+ DL_LIBS=""
+ LDFLAGS="-prebind"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
+ CFLAGS_OPTIMIZE="-Os"
+ LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
+ # for compatibility with autoconf vers 2.13 :
+ HACK=""
+ EXTRA_CFLAGS="-DMA${HACK}C_OSX_TCL -DHAVE_CFBUNDLE -DTCL_DEFAULT_ENCODING=\\\"utf-8\\\""
+ LIBS="$LIBS -framework CoreFoundation"
;;
NEXTSTEP-*)
SHLIB_CFLAGS=""
DL_OBJS="tclLoadNext.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OS/390-*)
DL_OBJS="tclLoadOSF.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OSF1-1.*)
# OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
SHLIB_CFLAGS="-fPIC"
- SHLIB_LD="ld -shared"
+ if test "$SHARED_BUILD" = "1" ; then
+ SHLIB_LD="ld -shared"
+ else
+ SHLIB_LD="ld -non_shared"
+ fi
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OSF1-V*)
# Digital OSF/1
SHLIB_CFLAGS=""
- SHLIB_LD='ld -shared -expect_unresolved "*"'
+ if test "$SHARED_BUILD" = "1" ; then
+ SHLIB_LD='ld -shared -expect_unresolved "*"'
+ else
+ SHLIB_LD='ld -non_shared -expect_unresolved "*"'
+ fi
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
- if test "$using_gcc" = "no" ; then
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ if test "$GCC" != "yes" ; then
EXTRA_CFLAGS="-DHAVE_TZSET -std1"
fi
# see pthread_intro(3) for pthread support on osf1, k.furukawa
if test "${TCL_THREADS}" = "1" ; then
+ EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
- if test "$using_gcc" = "no" ; then
+ LIBS=`echo $LIBS | sed s/-lpthreads//`
+ if test "$GCC" = "yes" ; then
+ LIBS="$LIBS -lpthread -lmach -lexc"
+ else
EXTRA_CFLAGS="${EXTRA_CFLAGS} -pthread"
LDFLAGS="-pthread"
- else
- LIBS=`echo $LIBS | sed s/-lpthreads//`
- LIBS="$LIBS -lpthread -lmach -lexc"
fi
fi
;;
+ QNX-6*)
+ # QNX RTP
+ # This may work for all QNX, but it was only reported for v6.
+ SHLIB_CFLAGS="-fPIC"
+ SHLIB_LD="ld -Bshareable -x"
+ SHLIB_LD_LIBS=""
+ SHLIB_SUFFIX=".so"
+ DL_OBJS="tclLoadDl.o"
+ # dlopen is in -lc on QNX
+ DL_LIBS=""
+ LDFLAGS=""
+ CC_SEARCH_FLAGS=""
+ LD_SEARCH_FLAGS=""
+ ;;
RISCos-*)
SHLIB_CFLAGS="-G 0"
SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="-Wl,-D,08000000"
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
SCO_SV-3.2*)
# Note, dlopen is available only on SCO 3.2.5 and greater. However,
# this test works, since "uname -s" was non-standard in 3.2.4 and
# below.
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
SHLIB_CFLAGS="-fPIC -melf"
LDFLAGS="-melf -Wl,-Bexport"
else
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- LDFLAGS="-belf -Wl,-Bexport"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SINIX*5.4*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SunOS-4*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# SunOS can't handle version numbers with dots in them in library
# specs, like -ltcl7.5, so use -ltcl75 instead. Also, it
TCL_LIB_VERSIONS_OK=nodots
;;
SunOS-5.[0-6]*)
+
+ # Note: If _REENTRANT isn't defined, then Solaris
+ # won't define thread-safe library routines.
+
+ cat >> confdefs.h <<\EOF
+#define _REENTRANT 1
+EOF
+
+ cat >> confdefs.h <<\EOF
+#define _POSIX_PTHREAD_SEMANTICS 1
+EOF
+
+
SHLIB_CFLAGS="-KPIC"
- SHLIB_LD="/usr/ccs/bin/ld -G -z text"
# Note: need the LIBS below, otherwise Tk won't find Tcl's
# symbols when dynamically loaded into tclsh.
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ if test "$GCC" = "yes" ; then
+ SHLIB_LD="$CC -shared"
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ else
+ SHLIB_LD="/usr/ccs/bin/ld -G -z text"
+ CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ fi
;;
SunOS-5*)
+
+ # Note: If _REENTRANT isn't defined, then Solaris
+ # won't define thread-safe library routines.
+
+ cat >> confdefs.h <<\EOF
+#define _REENTRANT 1
+EOF
+
+ cat >> confdefs.h <<\EOF
+#define _POSIX_PTHREAD_SEMANTICS 1
+EOF
+
+
SHLIB_CFLAGS="-KPIC"
- SHLIB_LD="/usr/ccs/bin/ld -G -z text"
LDFLAGS=""
- do64bit_ok=no
+ # Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes" ; then
arch=`isainfo`
if test "$arch" = "sparcv9 sparc" ; then
- if test "$using_gcc" = "no" ; then
+ if test "$GCC" = "yes" ; then
+ echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
+ else
do64bit_ok=yes
if test "$do64bitVIS" = "yes" ; then
EXTRA_CFLAGS="-xarch=v9a"
EXTRA_CFLAGS="-xarch=v9"
LDFLAGS="-xarch=v9"
fi
- else
- echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
fi
else
echo "configure: warning: "64bit mode only supported sparcv9 system"" 1>&2
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
- if test "$using_gcc" = "yes" ; then
- LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ if test "$GCC" = "yes" ; then
+ SHLIB_LD="$CC -shared"
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else
+ SHLIB_LD="/usr/ccs/bin/ld -G -z text"
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
fi
;;
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="-Wl,-D,08000000"
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
- if test "$using_gcc" = "no" ; then
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ if test "$GCC" != "yes" ; then
EXTRA_CFLAGS="-DHAVE_TZSET -std1"
fi
;;
# that don't grok the -Bexport option. Test that it does.
hold_ldflags=$LDFLAGS
echo $ac_n "checking for ld accepts -Bexport flag""... $ac_c" 1>&6
-echo "configure:5631: checking for ld accepts -Bexport flag" >&5
+echo "configure:6577: checking for ld accepts -Bexport flag" >&5
LDFLAGS="${LDFLAGS} -Wl,-Bexport"
cat > conftest.$ac_ext <<EOF
-#line 5634 "configure"
+#line 6580 "configure"
#include "confdefs.h"
int main() {
int i;
; return 0; }
EOF
-if { (eval echo configure:5641: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:6587: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
found=yes
else
else
LDFLAGS=""
fi
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
esac
if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6
-echo "configure:5687: checking sys/exec.h" >&5
+echo "configure:6634: checking sys/exec.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 5689 "configure"
+#line 6636 "configure"
#include "confdefs.h"
#include <sys/exec.h>
int main() {
; return 0; }
EOF
-if { (eval echo configure:5707: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:6654: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_ok=usable
else
else
echo $ac_n "checking a.out.h""... $ac_c" 1>&6
-echo "configure:5725: checking a.out.h" >&5
+echo "configure:6672: checking a.out.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 5727 "configure"
+#line 6674 "configure"
#include "confdefs.h"
#include <a.out.h>
int main() {
; return 0; }
EOF
-if { (eval echo configure:5745: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:6692: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_ok=usable
else
else
echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6
-echo "configure:5763: checking sys/exec_aout.h" >&5
+echo "configure:6710: checking sys/exec_aout.h" >&5
cat > conftest.$ac_ext <<EOF
-#line 5765 "configure"
+#line 6712 "configure"
#include "confdefs.h"
#include <sys/exec_aout.h>
int main() {
; return 0; }
EOF
-if { (eval echo configure:5783: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:6730: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_ok=usable
else
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
BUILD_DLTEST=""
fi
# standard manufacturer compiler.
if test "$DL_OBJS" != "tclLoadNone.o" ; then
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
case $system in
AIX-*)
;;
;;
NetBSD-*|FreeBSD-*|OpenBSD-*)
;;
+ Rhapsody-*|Darwin-*)
+ ;;
RISCos-*)
;;
SCO_SV-3.2*)
UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
fi
-# CYGNUS LOCAL
- TCL_LIB_SUFFIX=.a
+ if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
+ LIB_SUFFIX=${SHARED_LIB_SUFFIX}
+ MAKE_LIB='${SHLIB_LD} -o $@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
+ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
+ else
+ LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
+
+ if test "$RANLIB" = "" ; then
+ MAKE_LIB='$(STLIB_LD) $@ ${OBJS}'
+ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
+ else
+ MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
+ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))'
+ fi
+
+ fi
+
+
+ # Stub lib does not depend on shared/static configuration
+ if test "$RANLIB" = "" ; then
+ MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
+ INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)'
+ else
+ MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
+ INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))'
+ fi
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-# END CYGNUS LOCAL
+
echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
-echo "configure:5883: checking for build with symbols" >&5
+echo "configure:6882: checking for build with symbols" >&5
# Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
enableval="$enable_symbols"
tcl_ok=no
fi
- if test "$tcl_ok" = "yes"; then
- CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
- LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
- DBGX=g
- echo "$ac_t""yes" 1>&6
- else
+# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
+ if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
echo "$ac_t""no" 1>&6
+ else
+ CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
+ LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
+ DBGX=g
+ if test "$tcl_ok" = "yes"; then
+ echo "$ac_t""yes (standard debugging)" 1>&6
+ fi
+ fi
+
+
+
+ if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
+ cat >> confdefs.h <<\EOF
+#define TCL_MEM_DEBUG 1
+EOF
+
+ fi
+
+ if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
+ cat >> confdefs.h <<\EOF
+#define TCL_COMPILE_DEBUG 1
+EOF
+
+ cat >> confdefs.h <<\EOF
+#define TCL_COMPILE_STATS 1
+EOF
+
+ fi
+
+ if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
+ if test "$tcl_ok" = "all"; then
+ echo "$ac_t""enabled symbols mem compile debugging" 1>&6
+ else
+ echo "$ac_t""enabled $tcl_ok debugging" 1>&6
+ fi
fi
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:5919: checking for $ac_hdr" >&5
+echo "configure:6949: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5924 "configure"
+#line 6954 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5929: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6959: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:5959: checking for $ac_hdr" >&5
+echo "configure:6989: checking for $ac_hdr" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 5964 "configure"
+#line 6994 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:5969: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:6999: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
done
echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c" 1>&6
-echo "configure:5996: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
+echo "configure:7026: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
if test -f /usr/lib/NextStep/software_version; then
system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
else
case $system in
# There used to be code here to use FIONBIO under AIX. However, it
# was reported that FIONBIO doesn't work under AIX 3.2.5. Since
- # using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO
- # code (JO, 5/31/97).
-
- OSF*)
- cat >> confdefs.h <<\EOF
-#define USE_FIONBIO 1
-EOF
-
- echo "$ac_t""FIONBIO" 1>&6
- ;;
- SunOS-4*)
- cat >> confdefs.h <<\EOF
-#define USE_FIONBIO 1
-EOF
-
- echo "$ac_t""FIONBIO" 1>&6
- ;;
- ULTRIX-4.*)
- cat >> confdefs.h <<\EOF
-#define USE_FIONBIO 1
-EOF
-
- echo "$ac_t""FIONBIO" 1>&6
- ;;
- *)
- echo "$ac_t""O_NONBLOCK" 1>&6
- ;;
- esac
-
-
-#--------------------------------------------------------------------
-# The statements below define a collection of symbols related to
-# building libtcl as a shared library instead of a static library.
-#--------------------------------------------------------------------
-
-TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
-TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
-
-
- echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
-echo "configure:6058: checking how to build libraries" >&5
- # Check whether --enable-shared or --disable-shared was given.
-if test "${enable_shared+set}" = set; then
- enableval="$enable_shared"
- tcl_ok=$enableval
-else
- tcl_ok=no
-fi
-
-
- if test "${enable_shared+set}" = set; then
- enableval="$enable_shared"
- tcl_ok=$enableval
- else
- tcl_ok=no
- fi
-
- if test "$tcl_ok" = "yes" ; then
- echo "$ac_t""shared" 1>&6
- SHARED_BUILD=1
- else
- echo "$ac_t""static" 1>&6
- SHARED_BUILD=0
- cat >> confdefs.h <<\EOF
-#define STATIC_BUILD 1
-EOF
-
- fi
-
-
-if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != "" ; then
- TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}"
- TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
-
- libname=tcl
- suffix=${TCL_SHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32* | *cygwin*)
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- TCL_LIB_FILE=$long_libname
-
-
- # FIXME: Why does MAKE_LIB not use a generic LIB_FILE variable
- # that is replaced with the Makefiles specific stub lib name?
- if test "x$DL_OBJS" = "xtclLoadAout.o"; then
- MAKE_LIB="\${STLIB_LD} \${TCL_LIB_FILE} \${OBJS}"
- else
- MAKE_LIB="\${SHLIB_LD} -o \${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}"
- RANLIB=":"
- fi
-else
- case $system in
- BSD/OS*)
- ;;
-
- AIX-*)
- ;;
-
- *)
- SHLIB_LD_LIBS=""
- ;;
- esac
- TCL_SHLIB_CFLAGS=""
- TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
-
- libname=tcl
- suffix=${TCL_UNSHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- else
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- fi
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- TCL_LIB_FILE=$long_libname
-
- MAKE_LIB="\${STLIB_LD} \${TCL_LIB_FILE} \${OBJS}"
-fi
-
-# Note: in the following variable, it's important to use the absolute
-# path name of the Tcl directory rather than "..": this is because
-# AIX remembers this path and will attempt to use it at run-time to look
-# up the Tcl library.
-
-if test "$SHARED_BUILD" = "0" -o $TCL_NEEDS_EXP_FILE = 0; then
-
- libname=tcl
- version=$TCL_VERSION
+ # using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO
+ # code (JO, 5/31/97).
- if test "$TCL_LIB_SUFFIX" = "" ; then
- { echo "configure: error: The TCL_LIB_SUFFIX variable is not defined" 1>&2; exit 1; }
- fi
+ OSF*)
+ cat >> confdefs.h <<\EOF
+#define USE_FIONBIO 1
+EOF
- # If the . character is not allowed in lib name, remove it from version
- if test "${TCL_LIB_VERSIONS_OK}" != "ok"; then
- version=`echo $version | tr -d .`
- fi
+ echo "$ac_t""FIONBIO" 1>&6
+ ;;
+ SunOS-4*)
+ cat >> confdefs.h <<\EOF
+#define USE_FIONBIO 1
+EOF
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "short_libname=\"${TCL_VENDOR_PREFIX}${libname}${version}${TCL_LIB_SUFFIX}\""
- else
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}${TCL_DBGX}"
- fi
- ;;
- *)
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}\${TCL_DBGX}"
- ;;
- esac
+ echo "$ac_t""FIONBIO" 1>&6
+ ;;
+ ULTRIX-4.*)
+ cat >> confdefs.h <<\EOF
+#define USE_FIONBIO 1
+EOF
- TCL_LIB_FLAG=$short_libname
+ echo "$ac_t""FIONBIO" 1>&6
+ ;;
+ *)
+ echo "$ac_t""O_NONBLOCK" 1>&6
+ ;;
+ esac
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="`pwd`/${TCL_LIB_FLAG}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_BUILD_LIB_SPEC" 1>&2; exit 1; }
- fi
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_BUILD_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_BUILD_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_BUILD_LIB_SPEC=$val
- ;;
- esac
+#--------------------------------------------------------------------
+# The statements below define a collection of symbols related to
+# building libtcl as a shared library instead of a static library.
+#--------------------------------------------------------------------
- else
-
- val=`pwd`
+TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
+TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
+eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
+ echo $ac_n "checking how to package libraries""... $ac_c" 1>&6
+echo "configure:7089: checking how to package libraries" >&5
+ # Check whether --enable-framework or --disable-framework was given.
+if test "${enable_framework+set}" = set; then
+ enableval="$enable_framework"
+ tcl_ok=$enableval
+else
+ tcl_ok=no
+fi
- TCL_BUILD_LIB_SPEC="-L${dirname} ${TCL_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
- ;;
- esac
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="${exec_prefix}/lib/${TCL_LIB_FLAG}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_LIB_SPEC" 1>&2; exit 1; }
- fi
+ if test "${enable_framework+set}" = set; then
+ enableval="$enable_framework"
+ tcl_ok=$enableval
+ else
+ tcl_ok=no
+ fi
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_LIB_SPEC=$val
- ;;
- esac
+ if test "$tcl_ok" = "yes" ; then
+ echo "$ac_t""framework" 1>&6
+ FRAMEWORK_BUILD=1
+ if test "${SHARED_BUILD}" = "0" ; then
+ echo "configure: warning: "Frameworks can only be built if --enable-shared is yes"" 1>&2
+ FRAMEWORK_BUILD=0
+ fi
+ else
+ echo "$ac_t""standard shared library" 1>&6
+ FRAMEWORK_BUILD=0
+ fi
- else
-
- val=${exec_prefix}/lib
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
+# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
+# so that the backslashes quoting the DBX braces are dropped.
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
+# Trick to replace DBGX with TCL_DBGX
+DBGX='${TCL_DBGX}'
+eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
- TCL_LIB_SPEC="-L${dirname} ${TCL_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_LIB_SPEC="-L${exec_prefix}/lib ${TCL_LIB_FLAG}"
- ;;
- esac
+# Note: in the following variable, it's important to use the absolute
+# path name of the Tcl directory rather than "..": this is because
+# AIX remembers this path and will attempt to use it at run-time to look
+# up the Tcl library.
+if test "$FRAMEWORK_BUILD" = "1" ; then
+ TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
+ TCL_LIB_SPEC="-framework Tcl"
+ TCL_LIB_FILE="Tcl"
+elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
+ if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
+ TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
+ else
+ TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
+ fi
+ TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
+ TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
else
- # FIXME: This if branch needs to be updated with respect
- # to the library macro changes above!
TCL_BUILD_EXP_FILE="lib.exp"
eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\""
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`"
- TCL_LIB_SPEC="-Wl,-bI:${exec_prefix}/lib/${TCL_EXP_FILE} -L`pwd`"
+ TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`"
else
TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}"
- TCL_LIB_SPEC="-bI:${exec_prefix}/lib/${TCL_EXP_FILE}"
+ TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}"
fi
fi
-
-
- val="`pwd`/${TCL_LIB_FILE}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_LIB_FULL_PATH" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_LIB_FULL_PATH=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_LIB_FULL_PATH="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_LIB_FULL_PATH=$val
- ;;
- esac
-
-
-
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
# another for platform-independent scripts.
#--------------------------------------------------------------------
-if test "$prefix" != "$exec_prefix"; then
- TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib"
+if test "$FRAMEWORK_BUILD" = "1" ; then
+ TCL_PACKAGE_PATH="${libdir}/Resources/Scripts"
+elif test "$prefix" != "$exec_prefix"; then
+ TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
TCL_PACKAGE_PATH="${prefix}/lib"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
-# stub support. Note that the STUB_LIB_FILE variable must
-# be set in the Makefile before running MAKE_STUB_LIB.
+# stub support.
#--------------------------------------------------------------------
-MAKE_STUB_LIB="\${STLIB_LD} \${STUB_LIB_FILE} \${STUB_LIB_OBJS}"
-
-
- libname=tclstub
- suffix=${TCL_UNSHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- else
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- fi
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- TCL_STUB_LIB_FILE=$long_libname
-
-
-
- libname=tclstub
- version=$TCL_VERSION
-
- if test "$TCL_LIB_SUFFIX" = "" ; then
- { echo "configure: error: The TCL_LIB_SUFFIX variable is not defined" 1>&2; exit 1; }
- fi
-
- # If the . character is not allowed in lib name, remove it from version
- if test "${TCL_LIB_VERSIONS_OK}" != "ok"; then
- version=`echo $version | tr -d .`
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "short_libname=\"${TCL_VENDOR_PREFIX}${libname}${version}${TCL_LIB_SUFFIX}\""
- else
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}${TCL_DBGX}"
- fi
- ;;
- *)
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}\${TCL_DBGX}"
- ;;
- esac
-
- TCL_STUB_LIB_FLAG=$short_libname
-
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="`pwd`/${TCL_STUB_LIB_FLAG}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_BUILD_STUB_LIB_SPEC" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_BUILD_STUB_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_BUILD_STUB_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_BUILD_STUB_LIB_SPEC=$val
- ;;
- esac
-
- else
-
- val=`pwd`
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
-
- TCL_BUILD_STUB_LIB_SPEC="-L${dirname} ${TCL_STUB_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
- ;;
- esac
-
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="${exec_prefix}/lib/${TCL_STUB_LIB_FLAG}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_STUB_LIB_SPEC" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_STUB_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_STUB_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_STUB_LIB_SPEC=$val
- ;;
- esac
-
- else
-
- val=${exec_prefix}/lib
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
-
- TCL_STUB_LIB_SPEC="-L${dirname} ${TCL_STUB_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_STUB_LIB_SPEC="-L${exec_prefix}/lib ${TCL_STUB_LIB_FLAG}"
- ;;
- esac
-
-
-
-
- val="`pwd`/${TCL_STUB_LIB_FILE}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_BUILD_STUB_LIB_PATH" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_BUILD_STUB_LIB_PATH=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_BUILD_STUB_LIB_PATH="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_BUILD_STUB_LIB_PATH=$val
- ;;
- esac
-
-
+# Replace ${VERSION} with contents of ${TCL_VERSION}
+eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
+# Replace DBGX with TCL_DBGX
+eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
-
- val="${exec_prefix}/lib/${TCL_STUB_LIB_FILE}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_STUB_LIB_PATH" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_STUB_LIB_PATH=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_STUB_LIB_PATH="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_STUB_LIB_PATH=$val
- ;;
- esac
+if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
+ TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
+else
+ TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
+fi
+TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
+TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"
+TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
+TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"
+# Install time header dir can be set via --includedir
+eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
-
-
-
-
-
-
-
-
-
-
-
-
trap '' 1 2 15
cat > confcache <<\EOF
# This file is a shell script that caches the results of configure
# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
-cat > conftest.defs <<\EOF
-s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
-s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g
-s%\[%\\&%g
-s%\]%\\&%g
-s%\$%$$%g
-EOF
-DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
-rm -f conftest.defs
+#
+# If the first sed substitution is executed (which looks for macros that
+# take arguments), then we branch to the quote section. Otherwise,
+# look for a macro that doesn't take arguments.
+cat >confdef2opt.sed <<\_ACEOF
+t clear
+: clear
+s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g
+t quote
+s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g
+t quote
+d
+: quote
+s,[ `~#$^&*(){}\\|;'"<>?],\\&,g
+s,\[,\\&,g
+s,\],\\&,g
+s,\$,$$,g
+p
+_ACEOF
+# We use echo to avoid assuming a particular line-breaking character.
+# The extra dot is to prevent the shell from consuming trailing
+# line-breaks from the sub-command output. A line-break within
+# single-quotes doesn't work because, if this script is created in a
+# platform that uses two characters for line-breaks (e.g., DOS), tr
+# would break.
+ac_LF_and_DOT=`echo; echo .`
+DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'`
+rm -f confdef2opt.sed
# Without the "./", some shells look in PATH for config.status.
done
ac_given_srcdir=$srcdir
-ac_given_INSTALL="$INSTALL"
-trap 'rm -fr `echo "Makefile tclConfig.sh" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
+trap 'rm -fr `echo "Makefile dltest/Makefile tclConfig.sh" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
EOF
cat >> $CONFIG_STATUS <<EOF
s%@oldincludedir@%$oldincludedir%g
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g
+s%@MKLINKS_FLAGS@%$MKLINKS_FLAGS%g
s%@CC@%$CC%g
-s%@RANLIB@%$RANLIB%g
s%@CPP@%$CPP%g
-s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
-s%@INSTALL_SCRIPT@%$INSTALL_SCRIPT%g
-s%@INSTALL_DATA@%$INSTALL_DATA%g
+s%@TCL_THREADS@%$TCL_THREADS%g
s%@LIBOBJS@%$LIBOBJS%g
s%@TCL_LIBS@%$TCL_LIBS%g
s%@MATH_LIBS@%$MATH_LIBS%g
+s%@RANLIB@%$RANLIB%g
s%@AR@%$AR%g
-s%@TCL_LIB_SUFFIX@%$TCL_LIB_SUFFIX%g
s%@DL_LIBS@%$DL_LIBS%g
+s%@DL_OBJS@%$DL_OBJS%g
+s%@PLAT_OBJS@%$PLAT_OBJS%g
s%@CFLAGS_DEBUG@%$CFLAGS_DEBUG%g
s%@CFLAGS_OPTIMIZE@%$CFLAGS_OPTIMIZE%g
s%@CFLAGS_WARNING@%$CFLAGS_WARNING%g
+s%@EXTRA_CFLAGS@%$EXTRA_CFLAGS%g
+s%@LDFLAGS_DEBUG@%$LDFLAGS_DEBUG%g
+s%@LDFLAGS_OPTIMIZE@%$LDFLAGS_OPTIMIZE%g
+s%@CC_SEARCH_FLAGS@%$CC_SEARCH_FLAGS%g
+s%@LD_SEARCH_FLAGS@%$LD_SEARCH_FLAGS%g
+s%@STLIB_LD@%$STLIB_LD%g
+s%@SHLIB_LD@%$SHLIB_LD%g
+s%@TCL_SHLIB_LD_EXTRAS@%$TCL_SHLIB_LD_EXTRAS%g
+s%@TK_SHLIB_LD_EXTRAS@%$TK_SHLIB_LD_EXTRAS%g
+s%@SHLIB_LD_FLAGS@%$SHLIB_LD_FLAGS%g
+s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g
+s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g
+s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g
+s%@MAKE_LIB@%$MAKE_LIB%g
+s%@MAKE_STUB_LIB@%$MAKE_STUB_LIB%g
+s%@INSTALL_LIB@%$INSTALL_LIB%g
+s%@INSTALL_STUB_LIB@%$INSTALL_STUB_LIB%g
+s%@CFLAGS_DEFAULT@%$CFLAGS_DEFAULT%g
+s%@LDFLAGS_DEFAULT@%$LDFLAGS_DEFAULT%g
+s%@TCL_VERSION@%$TCL_VERSION%g
+s%@TCL_MAJOR_VERSION@%$TCL_MAJOR_VERSION%g
+s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g
+s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g
+s%@TCL_LIB_FILE@%$TCL_LIB_FILE%g
+s%@TCL_LIB_FLAG@%$TCL_LIB_FLAG%g
+s%@TCL_LIB_SPEC@%$TCL_LIB_SPEC%g
s%@TCL_STUB_LIB_FILE@%$TCL_STUB_LIB_FILE%g
s%@TCL_STUB_LIB_FLAG@%$TCL_STUB_LIB_FLAG%g
-s%@TCL_BUILD_STUB_LIB_SPEC@%$TCL_BUILD_STUB_LIB_SPEC%g
s%@TCL_STUB_LIB_SPEC@%$TCL_STUB_LIB_SPEC%g
-s%@TCL_BUILD_STUB_LIB_PATH@%$TCL_BUILD_STUB_LIB_PATH%g
s%@TCL_STUB_LIB_PATH@%$TCL_STUB_LIB_PATH%g
-s%@MAKE_STUB_LIB@%$MAKE_STUB_LIB%g
-s%@BUILD_DLTEST@%$BUILD_DLTEST%g
-s%@CFLAGS_DEFAULT@%$CFLAGS_DEFAULT%g
+s%@TCL_INCLUDE_SPEC@%$TCL_INCLUDE_SPEC%g
+s%@TCL_BUILD_STUB_LIB_SPEC@%$TCL_BUILD_STUB_LIB_SPEC%g
+s%@TCL_BUILD_STUB_LIB_PATH@%$TCL_BUILD_STUB_LIB_PATH%g
+s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g
+s%@TCL_DBGX@%$TCL_DBGX%g
s%@CFG_TCL_SHARED_LIB_SUFFIX@%$CFG_TCL_SHARED_LIB_SUFFIX%g
s%@CFG_TCL_UNSHARED_LIB_SUFFIX@%$CFG_TCL_UNSHARED_LIB_SUFFIX%g
s%@CFG_TCL_EXPORT_FILE_SUFFIX@%$CFG_TCL_EXPORT_FILE_SUFFIX%g
-s%@TCL_DBGX@%$TCL_DBGX%g
-s%@DL_OBJS@%$DL_OBJS%g
-s%@EXTRA_CFLAGS@%$EXTRA_CFLAGS%g
-s%@LDFLAGS_DEFAULT@%$LDFLAGS_DEFAULT%g
-s%@LDFLAGS_DEBUG@%$LDFLAGS_DEBUG%g
-s%@LDFLAGS_OPTIMIZE@%$LDFLAGS_OPTIMIZE%g
-s%@MAKE_LIB@%$MAKE_LIB%g
s%@TCL_SHARED_BUILD@%$TCL_SHARED_BUILD%g
-s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g
-s%@SHLIB_LD@%$SHLIB_LD%g
-s%@STLIB_LD@%$STLIB_LD%g
-s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g
-s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g
+s%@LD_LIBRARY_PATH_VAR@%$LD_LIBRARY_PATH_VAR%g
s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g
-s%@TCL_LD_SEARCH_FLAGS@%$TCL_LD_SEARCH_FLAGS%g
-s%@TCL_LDFLAGS_DEBUG@%$TCL_LDFLAGS_DEBUG%g
-s%@TCL_LDFLAGS_OPTIMIZE@%$TCL_LDFLAGS_OPTIMIZE%g
-s%@TCL_LIB_FILE@%$TCL_LIB_FILE%g
-s%@TCL_LIB_FULL_PATH@%$TCL_LIB_FULL_PATH%g
-s%@TCL_LIB_FLAG@%$TCL_LIB_FLAG%g
s%@TCL_NEEDS_EXP_FILE@%$TCL_NEEDS_EXP_FILE%g
s%@TCL_BUILD_EXP_FILE@%$TCL_BUILD_EXP_FILE%g
s%@TCL_EXP_FILE@%$TCL_EXP_FILE%g
-s%@TCL_LIB_SPEC@%$TCL_LIB_SPEC%g
s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g
-s%@TCL_MAJOR_VERSION@%$TCL_MAJOR_VERSION%g
-s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g
-s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g
-s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g
s%@TCL_SHARED_LIB_SUFFIX@%$TCL_SHARED_LIB_SUFFIX%g
-s%@TCL_SHLIB_CFLAGS@%$TCL_SHLIB_CFLAGS%g
-s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g
s%@TCL_UNSHARED_LIB_SUFFIX@%$TCL_UNSHARED_LIB_SUFFIX%g
-s%@TCL_VERSION@%$TCL_VERSION%g
-s%@VENDORPREFIX@%$VENDORPREFIX%g
+s%@TCL_HAS_LONGLONG@%$TCL_HAS_LONGLONG%g
+s%@BUILD_DLTEST@%$BUILD_DLTEST%g
+s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g
CEOF
EOF
# Split the substitutions into bite-sized pieces for seds with
# small command number limits, like on Digital OSF/1 and HP-UX.
-ac_max_sed_cmds=60 # Maximum number of lines to put in a sed script.
+ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
ac_file=1 # Number of current file.
ac_beg=1 # First line for current file.
ac_end=$ac_max_sed_cmds # Line after last line for current file.
cat >> $CONFIG_STATUS <<EOF
-CONFIG_FILES=\${CONFIG_FILES-"Makefile tclConfig.sh"}
+CONFIG_FILES=\${CONFIG_FILES-"Makefile dltest/Makefile tclConfig.sh"}
EOF
cat >> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
top_srcdir="$ac_dots$ac_given_srcdir" ;;
esac
- case "$ac_given_INSTALL" in
- [/$]*) INSTALL="$ac_given_INSTALL" ;;
- *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
- esac
echo creating "$ac_file"
rm -f "$ac_file"
s%@configure_input@%$configure_input%g
s%@srcdir@%$srcdir%g
s%@top_srcdir@%$top_srcdir%g
-s%@INSTALL@%$INSTALL%g
" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
fi; done
rm -f conftest.s*
rm -fr confdefs* $ac_clean_files
test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
-
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
-
-# CYGNUS LOCAL, need 2.5 or higher for --bindir et al
-AC_PREREQ(2.5)
-# END CYGNUS LOCAL
+#
+# RCS: @(#) $Id$
AC_INIT(../generic/tcl.h)
-# RCS: @(#) $Id$
+AC_PREREQ(2.13)
-TCL_VERSION=8.3
+TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=3
-TCL_PATCH_LEVEL=".2"
+TCL_MINOR_VERSION=4
+TCL_PATCH_LEVEL=".1"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
if test "${exec_prefix}" = "NONE"; then
exec_prefix=$prefix
fi
+# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
+eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`
#------------------------------------------------------------------------
+# Compress and/or soft link the manpages?
+#------------------------------------------------------------------------
+SC_CONFIG_MANPAGES
+
+#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------
-AC_PROG_CC
-AC_PROG_RANLIB
+# If the user did not set CFLAGS, set it now to keep
+# the AC_PROG_CC macro from adding "-g -O2".
+if test "${CFLAGS+set}" != "set" ; then
+ CFLAGS=""
+fi
+AC_PROG_CC
AC_HAVE_HEADERS(unistd.h limits.h)
-# CYGNUS LOCAL
-# dje/win32
-AR=${AR-ar}
-# We need this for substitutions in Makefile.in.
-AC_PROG_INSTALL
-# END CYGNUS LOCAL
-
-#--------------------------------------------------------------------
-# CYGNUS LOCAL:
-# This is for LynxOS, which needs a flag to force true POSIX when
-# building. It's weirder than that, cause the flag varies depending
-# how old the compiler is. So...
-# -X is for the old "cc" and "gcc" (based on 1.42)
-# -mposix is for the new gcc (at least 2.5.8)
-# This modifies the value of $CC to have the POSIX flag added
-# so everything will configure correctly.
-#--------------------------------------------------------------------
-CY_AC_TCL_LYNX_POSIX
-
#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------
fi
#--------------------------------------------------------------------
+# Detect what compiler flags to set for 64-bit support.
+#--------------------------------------------------------------------
+
+SC_TCL_EARLY_FLAGS
+
+SC_TCL_64BIT_FLAGS
+
+#--------------------------------------------------------------------
+# Check endianness because we can optimize comparisons of
+# Tcl_UniChar strings to memcmp on big-endian systems.
+#--------------------------------------------------------------------
+
+AC_C_BIGENDIAN
+
+#--------------------------------------------------------------------
# Supply substitutes for missing POSIX library procedures, or
# set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------
# Check if Posix compliant getcwd exists, if not we'll use getwd.
-AC_CHECK_FUNCS(getcwd, , AC_DEFINE(USEGETWD))
+AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD)])
# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?
AC_REPLACE_FUNCS(opendir strstr)
-AC_REPLACE_FUNCS(strtol tmpnam waitpid)
-AC_CHECK_FUNC(strerror, , AC_DEFINE(NO_STRERROR))
-AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD))
-AC_CHECK_FUNC(wait3, , AC_DEFINE(NO_WAIT3))
-AC_CHECK_FUNC(uname, , AC_DEFINE(NO_UNAME))
-AC_CHECK_FUNC(realpath, , AC_DEFINE(NO_REALPATH))
+AC_REPLACE_FUNCS(strtol strtoll strtoull tmpnam waitpid)
+AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR)])
+AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD)])
+AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3)])
+AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME)])
+AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH)])
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special
# special flag.
#--------------------------------------------------------------------
-AC_MSG_CHECKING([fd_set and sys/select])
-AC_TRY_COMPILE([#include <sys/types.h>],
- [fd_set readMask, writeMask;], tk_ok=yes, tk_ok=no)
-if test $tk_ok = no; then
- AC_HEADER_EGREP(fd_mask, sys/select.h, tk_ok=yes)
- if test $tk_ok = yes; then
+AC_MSG_CHECKING([for fd_set in sys/types])
+AC_CACHE_VAL(tcl_cv_type_fd_set,
+ AC_TRY_COMPILE([#include <sys/types.h>],[fd_set readMask, writeMask;],
+ tcl_cv_type_fd_set=yes, tcl_cv_type_fd_set=no))
+AC_MSG_RESULT($tcl_cv_type_fd_set)
+tk_ok=$tcl_cv_type_fd_set
+if test $tcl_cv_type_fd_set = no; then
+ AC_MSG_CHECKING([for fd_mask in sys/select])
+ AC_CACHE_VAL(tcl_cv_grep_fd_mask,
+ AC_HEADER_EGREP(fd_mask, sys/select.h,
+ tcl_cv_grep_fd_mask=present, tcl_cv_grep_fd_mask=missing))
+ AC_MSG_RESULT($tcl_cv_grep_fd_mask)
+ if test $tcl_cv_grep_fd_mask = present; then
AC_DEFINE(HAVE_SYS_SELECT_H)
+ tk_ok=yes
fi
fi
-AC_MSG_RESULT($tk_ok)
if test $tk_ok = no; then
AC_DEFINE(NO_FD_SET)
fi
# in struct stat. But we might be able to use fstatfs instead.
#--------------------------------------------------------------------
AC_STRUCT_ST_BLKSIZE
-AC_CHECK_FUNC(fstatfs, , AC_DEFINE(NO_FSTATFS))
+AC_CHECK_FUNC(fstatfs, , [AC_DEFINE(NO_FSTATFS)])
#--------------------------------------------------------------------
# Some system have no memcmp or it does not work with 8 bit
# have no memmove (we assume they have bcopy instead).
# {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
-AC_CHECK_FUNC(memmove, , AC_DEFINE(NO_MEMMOVE) AC_DEFINE(NO_STRING_H))
+AC_CHECK_FUNC(memmove, , [AC_DEFINE(NO_MEMMOVE) AC_DEFINE(NO_STRING_H)])
#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even
AC_TYPE_SIZE_T
AC_TYPE_UID_T
+AC_MSG_CHECKING([for socklen_t])
+AC_CACHE_VAL(ac_cv_type_socklen_t,[AC_EGREP_CPP(changequote(<<,>>)dnl
+<<(^|[^a-zA-Z_0-9])socklen_t[^a-zA-Z_0-9]>>dnl
+changequote([,]),[
+ #include <sys/types.h>
+ #include <sys/socket.h>
+ #if STDC_HEADERS
+ #include <stdlib.h>
+ #include <stddef.h>
+ #endif
+ ], ac_cv_type_socklen_t=yes, ac_cv_type_socklen_t=no)])
+AC_MSG_RESULT($ac_cv_type_socklen_t)
+if test $ac_cv_type_socklen_t = no; then
+ AC_DEFINE(socklen_t, unsigned)
+fi
+
#--------------------------------------------------------------------
# If a system doesn't have an opendir function (man, that's old!)
# then we have to supply a different version of dirent.h which
# provided. This version only works with V7-style directories.
#--------------------------------------------------------------------
-AC_CHECK_FUNC(opendir, , AC_DEFINE(USE_DIRENT2_H))
+AC_CHECK_FUNC(opendir, , [AC_DEFINE(USE_DIRENT2_H)])
#--------------------------------------------------------------------
# The check below checks whether <sys/wait.h> defines the type
#--------------------------------------------------------------------
AC_MSG_CHECKING([union wait])
-AC_TRY_LINK([#include <sys/types.h>
+AC_CACHE_VAL(tcl_cv_union_wait,
+ AC_TRY_LINK([#include <sys/types.h>
#include <sys/wait.h>], [
union wait x;
WIFEXITED(x); /* Generates compiler error if WIFEXITED
* uses an int. */
-], tcl_ok=yes, tcl_ok=no)
-AC_MSG_RESULT($tcl_ok)
-if test $tcl_ok = no; then
+ ], tcl_cv_union_wait=yes, tcl_cv_union_wait=no))
+AC_MSG_RESULT($tcl_cv_union_wait)
+if test $tcl_cv_union_wait = no; then
AC_DEFINE(NO_UNION_WAIT)
fi
#--------------------------------------------------------------------
-# Check to see whether the system supports the matherr function
-# and its associated type "struct exception".
-#--------------------------------------------------------------------
-
-AC_MSG_CHECKING([matherr support])
-AC_TRY_COMPILE([#include <math.h>], [
-struct exception x;
-x.type = DOMAIN;
-x.type = SING;
-], tcl_ok=yes, tcl_ok=no)
-AC_MSG_RESULT($tcl_ok)
-if test $tcl_ok = yes; then
- AC_DEFINE(NEED_MATHERR)
-fi
-
-#--------------------------------------------------------------------
-# Check to see whether the system provides a vfork kernel call.
-# If not, then use fork instead. Also, check for a problem with
-# vforks and signals that can cause core dumps if a vforked child
-# resets a signal handler. If the problem exists, then use fork
-# instead of vfork.
-#--------------------------------------------------------------------
-
-AC_TYPE_SIGNAL()
-AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0)
-if test "$tcl_ok" = 1; then
- AC_MSG_CHECKING([vfork/signal bug]);
- AC_TRY_RUN([
-#include <stdio.h>
-#include <signal.h>
-#include <sys/wait.h>
-int gotSignal = 0;
-sigProc(sig)
- int sig;
-{
- gotSignal = 1;
-}
-main()
-{
- int pid, sts;
- (void) signal(SIGCHLD, sigProc);
- pid = vfork();
- if (pid < 0) {
- exit(1);
- } else if (pid == 0) {
- (void) signal(SIGCHLD, SIG_DFL);
- _exit(0);
- } else {
- (void) wait(&sts);
- }
- exit((gotSignal) ? 0 : 1);
-}], tcl_ok=1, tcl_ok=0, tcl_ok=0)
- if test "$tcl_ok" = 1; then
- AC_MSG_RESULT(ok)
- else
- AC_MSG_RESULT([buggy, using fork instead])
- fi
-fi
-rm -f core
-if test "$tcl_ok" = 0; then
- AC_DEFINE(vfork, fork)
-fi
-
-#--------------------------------------------------------------------
# Check whether there is an strncasecmp function on this system.
# This is a bit tricky because under SCO it's in -lsocket and
# under Sequent Dynix it's in -linet.
# declare it.
#--------------------------------------------------------------------
-AC_CHECK_FUNC(BSDgettimeofday, AC_DEFINE(HAVE_BSDGETTIMEOFDAY),
- AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD)))
+AC_CHECK_FUNC(BSDgettimeofday,
+ [AC_DEFINE(HAVE_BSDGETTIMEOFDAY)], [
+ AC_CHECK_FUNC(gettimeofday, , [AC_DEFINE(NO_GETTOD)])
+])
AC_MSG_CHECKING([for gettimeofday declaration])
-AC_EGREP_HEADER(gettimeofday, sys/time.h, AC_MSG_RESULT(present), [
- AC_MSG_RESULT(missing)
+AC_CACHE_VAL(tcl_cv_grep_gettimeofday,
+ AC_EGREP_HEADER(gettimeofday, sys/time.h,
+ tcl_cv_grep_gettimeofday=present, tcl_cv_grep_gettimeofday=missing))
+AC_MSG_RESULT($tcl_cv_grep_gettimeofday)
+if test $tcl_cv_grep_gettimeofday = missing ; then
AC_DEFINE(GETTOD_NOT_DECLARED)
-])
+fi
#--------------------------------------------------------------------
# The following code checks to see whether it is possible to get
AC_C_CHAR_UNSIGNED
AC_MSG_CHECKING([signed char declarations])
-AC_TRY_COMPILE(, [
-signed char *p;
-p = 0;
-], tcl_ok=yes, tcl_ok=no)
-AC_MSG_RESULT($tcl_ok)
-if test $tcl_ok = yes; then
+AC_CACHE_VAL(tcl_cv_char_signed,
+ AC_TRY_COMPILE(, [
+ signed char *p;
+ p = 0;
+ ], tcl_cv_char_signed=yes, tcl_cv_char_signed=no))
+AC_MSG_RESULT($tcl_cv_char_signed)
+if test $tcl_cv_char_signed = yes; then
AC_DEFINE(HAVE_SIGNED_CHAR)
fi
+#--------------------------------------------------------------------
+# Does putenv() copy or not? We need to know to avoid memory leaks.
+#--------------------------------------------------------------------
+
+AC_MSG_CHECKING([for a putenv() that copies the buffer])
+AC_CACHE_VAL(tcl_cv_putenv_copy,
+ AC_TRY_RUN([
+ #include <stdlib.h>
+ #define OURVAR "havecopy=yes"
+ int main (int argc, char *argv[])
+ {
+ char *foo, *bar;
+ foo = (char *)strdup(OURVAR);
+ putenv(foo);
+ strcpy((char *)(strchr(foo, '=') + 1), "no");
+ bar = getenv("havecopy");
+ if (!strcmp(bar, "no")) {
+ /* doesnt copy */
+ return 0;
+ } else {
+ /* does copy */
+ return 1;
+ }
+ }
+ ],
+ tcl_cv_putenv_copy=no,
+ tcl_cv_putenv_copy=yes,
+ tcl_cv_putenv_copy=no)
+)
+AC_MSG_RESULT($tcl_cv_putenv_copy)
+if test $tcl_cv_putenv_copy = yes; then
+ AC_DEFINE(HAVE_PUTENV_THAT_COPIES)
+fi
+
+#--------------------------------------------------------------------
+# Check for support of nl_langinfo function
+#--------------------------------------------------------------------
+
+SC_ENABLE_LANGINFO
#--------------------------------------------------------------------
# Look for libraries that we will need when compiling the Tcl shell
LIBS="$LIBS$THREADS_LIBS"
+SC_ENABLE_SHARED
+
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
+eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"
-SC_ENABLE_SHARED
+SC_ENABLE_FRAMEWORK
-if test "${SHARED_BUILD}" = "1" -a "${SHLIB_SUFFIX}" != "" ; then
- TCL_SHLIB_CFLAGS="${SHLIB_CFLAGS}"
- TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
- TCL_TOOL_SHARED_LIB_LONGNAME(TCL_LIB_FILE, tcl, ${TCL_SHARED_LIB_SUFFIX})
-
- # FIXME: Why does MAKE_LIB not use a generic LIB_FILE variable
- # that is replaced with the Makefiles specific stub lib name?
- if test "x$DL_OBJS" = "xtclLoadAout.o"; then
- MAKE_LIB="\${STLIB_LD} \${TCL_LIB_FILE} \${OBJS}"
- else
- MAKE_LIB="\${SHLIB_LD} -o \${TCL_LIB_FILE} \${OBJS} ${SHLIB_LD_LIBS}"
- RANLIB=":"
- fi
-else
- case $system in
- BSD/OS*)
- ;;
-
- AIX-*)
- ;;
-
- *)
- SHLIB_LD_LIBS=""
- ;;
- esac
- TCL_SHLIB_CFLAGS=""
- TCL_LD_SEARCH_FLAGS="${LD_SEARCH_FLAGS}"
- TCL_TOOL_STATIC_LIB_LONGNAME(TCL_LIB_FILE, tcl, ${TCL_UNSHARED_LIB_SUFFIX})
- MAKE_LIB="\${STLIB_LD} \${TCL_LIB_FILE} \${OBJS}"
-fi
+# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
+# so that the backslashes quoting the DBX braces are dropped.
+
+# Trick to replace DBGX with TCL_DBGX
+DBGX='${TCL_DBGX}'
+eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
# Note: in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..": this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
-if test "$SHARED_BUILD" = "0" -o $TCL_NEEDS_EXP_FILE = 0; then
- TCL_TOOL_LIB_SHORTNAME(TCL_LIB_FLAG, tcl, $TCL_VERSION)
- TCL_TOOL_LIB_SPEC(TCL_BUILD_LIB_SPEC, `pwd`, ${TCL_LIB_FLAG})
- TCL_TOOL_LIB_SPEC(TCL_LIB_SPEC, ${exec_prefix}/lib, ${TCL_LIB_FLAG})
+if test "$FRAMEWORK_BUILD" = "1" ; then
+ TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
+ TCL_LIB_SPEC="-framework Tcl"
+ TCL_LIB_FILE="Tcl"
+elif test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
+ if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
+ TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
+ else
+ TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
+ fi
+ TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
+ TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
else
- # FIXME: This if branch needs to be updated with respect
- # to the library macro changes above!
TCL_BUILD_EXP_FILE="lib.exp"
eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\""
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`"
- TCL_LIB_SPEC="-Wl,-bI:${exec_prefix}/lib/${TCL_EXP_FILE} -L`pwd`"
+ TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`"
else
TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}"
- TCL_LIB_SPEC="-bI:${exec_prefix}/lib/${TCL_EXP_FILE}"
+ TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}"
fi
fi
-TCL_TOOL_LIB_PATH(TCL_LIB_FULL_PATH, `pwd`, ${TCL_LIB_FILE})
-
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
# another for platform-independent scripts.
#--------------------------------------------------------------------
-if test "$prefix" != "$exec_prefix"; then
- TCL_PACKAGE_PATH="${exec_prefix}/lib ${prefix}/lib"
+if test "$FRAMEWORK_BUILD" = "1" ; then
+ TCL_PACKAGE_PATH="${libdir}/Resources/Scripts"
+elif test "$prefix" != "$exec_prefix"; then
+ TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
TCL_PACKAGE_PATH="${prefix}/lib"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
-# stub support. Note that the STUB_LIB_FILE variable must
-# be set in the Makefile before running MAKE_STUB_LIB.
+# stub support.
#--------------------------------------------------------------------
-MAKE_STUB_LIB="\${STLIB_LD} \${STUB_LIB_FILE} \${STUB_LIB_OBJS}"
+# Replace ${VERSION} with contents of ${TCL_VERSION}
+eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
+# Replace DBGX with TCL_DBGX
+eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
-TCL_TOOL_STATIC_LIB_LONGNAME(TCL_STUB_LIB_FILE, tclstub, ${TCL_UNSHARED_LIB_SUFFIX})
+if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
+ TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
+else
+ TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
+fi
-TCL_TOOL_LIB_SHORTNAME(TCL_STUB_LIB_FLAG, tclstub, $TCL_VERSION)
-TCL_TOOL_LIB_SPEC(TCL_BUILD_STUB_LIB_SPEC, `pwd`, ${TCL_STUB_LIB_FLAG})
-TCL_TOOL_LIB_SPEC(TCL_STUB_LIB_SPEC, ${exec_prefix}/lib, ${TCL_STUB_LIB_FLAG})
+TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
+TCL_STUB_LIB_SPEC="-L${libdir} ${TCL_STUB_LIB_FLAG}"
+TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
+TCL_STUB_LIB_PATH="${libdir}/${TCL_STUB_LIB_FILE}"
-TCL_TOOL_LIB_PATH(TCL_BUILD_STUB_LIB_PATH, `pwd`, ${TCL_STUB_LIB_FILE})
-TCL_TOOL_LIB_PATH(TCL_STUB_LIB_PATH, ${exec_prefix}/lib, ${TCL_STUB_LIB_FILE})
+# Install time header dir can be set via --includedir
+eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
TCL_SHARED_BUILD=${SHARED_BUILD}
+AC_SUBST(TCL_VERSION)
+AC_SUBST(TCL_MAJOR_VERSION)
+AC_SUBST(TCL_MINOR_VERSION)
+AC_SUBST(TCL_PATCH_LEVEL)
+
+AC_SUBST(TCL_LIB_FILE)
+AC_SUBST(TCL_LIB_FLAG)
+AC_SUBST(TCL_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
-AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_SPEC)
-AC_SUBST(TCL_BUILD_STUB_LIB_PATH)
AC_SUBST(TCL_STUB_LIB_PATH)
-AC_SUBST(MAKE_STUB_LIB)
+AC_SUBST(TCL_INCLUDE_SPEC)
+AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
+AC_SUBST(TCL_BUILD_STUB_LIB_PATH)
-AC_SUBST(BUILD_DLTEST)
-AC_SUBST(CFLAGS_DEFAULT)
+AC_SUBST(TCL_SRC_DIR)
+AC_SUBST(TCL_DBGX)
AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX)
-AC_SUBST(TCL_DBGX)
-AC_SUBST(DL_OBJS)
-AC_SUBST(EXTRA_CFLAGS)
-AC_SUBST(LDFLAGS_DEFAULT)
-AC_SUBST(LDFLAGS_DEBUG)
-AC_SUBST(LDFLAGS_OPTIMIZE)
-AC_SUBST(AR)
-AC_SUBST(RANLIB)
-AC_SUBST(MAKE_LIB)
+
AC_SUBST(TCL_SHARED_BUILD)
-AC_SUBST(SHLIB_CFLAGS)
-AC_SUBST(SHLIB_LD)
-AC_SUBST(STLIB_LD)
-AC_SUBST(SHLIB_LD_LIBS)
-AC_SUBST(SHLIB_SUFFIX)
+AC_SUBST(LD_LIBRARY_PATH_VAR)
+
AC_SUBST(TCL_BUILD_LIB_SPEC)
-AC_SUBST(TCL_LD_SEARCH_FLAGS)
-AC_SUBST(TCL_LDFLAGS_DEBUG)
-AC_SUBST(TCL_LDFLAGS_OPTIMIZE)
-AC_SUBST(TCL_LIB_FILE)
-AC_SUBST(TCL_LIB_FULL_PATH)
-AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_NEEDS_EXP_FILE)
AC_SUBST(TCL_BUILD_EXP_FILE)
AC_SUBST(TCL_EXP_FILE)
-AC_SUBST(TCL_LIB_SPEC)
+
AC_SUBST(TCL_LIB_VERSIONS_OK)
-AC_SUBST(TCL_MAJOR_VERSION)
-AC_SUBST(TCL_MINOR_VERSION)
-AC_SUBST(TCL_PACKAGE_PATH)
-AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_SHARED_LIB_SUFFIX)
-AC_SUBST(TCL_SHLIB_CFLAGS)
-AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_UNSHARED_LIB_SUFFIX)
-AC_SUBST(TCL_VERSION)
-AC_SUBST(VENDORPREFIX)
-AC_OUTPUT(Makefile tclConfig.sh)
+AC_SUBST(TCL_HAS_LONGLONG)
+
+AC_SUBST(BUILD_DLTEST)
+AC_SUBST(TCL_PACKAGE_PATH)
+AC_OUTPUT(Makefile dltest/Makefile tclConfig.sh)
TCL_DBGX = @TCL_DBGX@
CC = @CC@
-LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @TCL_LIBS@ -lc
+LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @DL_LIBS@ @LIBS@ @MATH_LIBS@
AC_FLAGS = @EXTRA_CFLAGS@
SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_LD = @SHLIB_LD@
+SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
SHLIB_SUFFIX = @SHLIB_SUFFIX@
-SHLIB_VERSION = @SHLIB_VERSION@
SRC_DIR = @srcdir@
TCL_VERSION= @TCL_VERSION@
-TCL_CFLAGS= @TCL_CFLAGS@
-CFLAGS = -g
-#CC_SWITCHES = $(CFLAGS) ${TCL_CFLAGS} -I${SRC_DIR}/../../generic \
-# -DTCL_MEM_DEBUG ${SHLIB_CFLAGS}
+CFLAGS_DEBUG = @CFLAGS_DEBUG@
+CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
+
+CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX}
+ @touch ../dltest.marker
pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c
- ${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${LIBS}
+ ${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${SHLIB_LD_LIBS}
pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c
- ${SHLIB_LD} -o pkgb${SHLIB_SUFFIX} pkgb.o ${LIBS}
+ ${SHLIB_LD} -o pkgb${SHLIB_SUFFIX} pkgb.o ${SHLIB_LD_LIBS}
pkgc${SHLIB_SUFFIX}: $(SRC_DIR)/pkgc.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c
- ${SHLIB_LD} -o pkgc${SHLIB_SUFFIX} pkgc.o ${LIBS}
+ ${SHLIB_LD} -o pkgc${SHLIB_SUFFIX} pkgc.o ${SHLIB_LD_LIBS}
pkgd${SHLIB_SUFFIX}: $(SRC_DIR)/pkgd.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c
- ${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${LIBS}
+ ${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${SHLIB_LD_LIBS}
pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
- ${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${LIBS}
+ ${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS}
clean:
- rm -f *.o *${SHLIB_SUFFIX} lib.exp
+ rm -f *.o *${SHLIB_SUFFIX} config.cache config.log config.status
+ rm -f lib.exp ../dltest.marker
distclean: clean
- rm -f Makefile config.cache config.log config.status
-
+ rm -f Makefile
This directory contains several files for testing Tcl's dynamic
-loading capabilities. If this directory is present and the files
-in here have been compiled, then the "load" test will use the shared
-libraries present here to run a series of tests. To compile the
-shared libraries, first type "./configure". This will read
-configuration information created when Tcl was configured and
-create Makefile from Makefile.in. Be sure that you have configured
-Tcl before configuring here, since information learned during Tcl's
-configure is needed here. Then type "make" to create the shared
-libraries.
+loading capabilities. If shared libraries are supported then
+the build system in the parent directory will create
+the shared libs and load them into the tcltest executable.
RCS: @(#) $Id$
-
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
-
-
(Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
-
-
(Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
-
-
(Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
-
-
}
return Tcl_Eval(interp, script);
}
-
-
}
return Tcl_Eval(interp, script);
}
-
shift
continue;;
+ -S) stripcmd="$stripprog $2"
+ shift
+ shift
+ continue;;
+
*) if [ x"$src" = x ]
then
src=$1
# the following statements handle both versions.
# 2. Use the -g switch to nm instead of -e under 4.1 (this shows just
# externals, not statics; -g isn't available under 3.2.5, though).
-# 3. Eliminate lines that end in ":": these are the names of object
+# 3. Use the -X32_64 switch to nm on AIX-4+ to handle 32 or 64bit compiles.
+# 4. Eliminate lines that end in ":": these are the names of object
# files (relevant in 4.1 only).
-# 4. Eliminate entries with the "U" key letter; these are undefined
+# 5. Eliminate entries with the "U" key letter; these are undefined
# symbols (relevant in 4.1 only).
-# 5. Eliminate lines that contain the string "0|extern" preceded by space;
+# 6. Eliminate lines that contain the string "0|extern" preceded by space;
# in 3.2.5, these are undefined symbols (address 0).
-# 6. Eliminate lines containing the "unamex" symbol. In 3.2.5, these
+# 7. Eliminate lines containing the "unamex" symbol. In 3.2.5, these
# are also undefined symbols.
-# 7. If a line starts with ".", delete the leading ".", since this will
+# 8. If a line starts with ".", delete the leading ".", since this will
# just cause confusion later.
-# 8. Eliminate everything after the first field in a line, so that we're
+# 9. Eliminate everything after the first field in a line, so that we're
# left with just the symbol name.
nmopts="-g -C"
if test $osver -eq 3; then
nmopts="-e"
fi
+if test $osver -gt 3; then
+ nmopts="$nmopts -X32_64"
+fi
rm -f lib.exp
echo "#! $outputFile" >lib.exp
/usr/ccs/bin/nm $nmopts -h $ofiles | sed -e '/:$/d' -e '/ U /d' -e '/[ ]0|extern/d' -e '/unamex/d' -e 's/^\.//' -e 's/[ |].*//' | sort | uniq >>lib.exp
else
eval $args
fi
-
# The script takes one argument, which is the name of the directory
# where the manual entries have been installed.
+ZIP=true
+while true; do
+ case $1 in
+ -s | --symlinks )
+ S=-s
+ ;;
+ -z | --compress )
+ ZIP=$2
+ shift
+ ;;
+ *) break
+ ;;
+ esac
+ shift
+done
+
if test $# != 1; then
- echo "Usage: mkLinks dir"
+ echo "Usage: mkLinks <options> dir"
exit 1
fi
+if test "x$ZIP" != "xtrue"; then
+ touch TeST
+ $ZIP TeST
+ Z=`ls TeST* | sed 's/^[^.]*//'`
+ rm -f TeST*
+fi
+
cd $1
echo foo > xyzzyTestingAVeryLongFileName.foo
x=`echo xyzzyTe*`
+echo foo > xyzzyTestingaverylongfilename.foo
+y=`echo xyzzyTestingav*`
rm xyzzyTe*
if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then
exit
fi
+if test "$y" != "xyzzyTestingaverylongfilename.foo"; then
+ CASEINSENSITIVEFS=1
+fi
if test -r Access.3; then
- rm -f Tcl_Access.3
- rm -f Tcl_Stat.3
- cp Access.3 Tcl_Access.3
- cp Access.3 Tcl_Stat.3
+ rm -f Access.3.*
+ $ZIP Access.3
+ rm -f Tcl_Access.3 Tcl_Access.3.*
+ rm -f Tcl_Stat.3 Tcl_Stat.3.*
+ ln $S Access.3$Z Tcl_Access.3$Z
+ ln $S Access.3$Z Tcl_Stat.3$Z
fi
if test -r AddErrInfo.3; then
- rm -f Tcl_AddObjErrorInfo.3
- rm -f Tcl_AddErrorInfo.3
- rm -f Tcl_SetObjErrorCode.3
- rm -f Tcl_SetErrorCode.3
- rm -f Tcl_SetErrorCodeVA.3
- rm -f Tcl_PosixError.3
- rm -f Tcl_LogCommandInfo.3
- cp AddErrInfo.3 Tcl_AddObjErrorInfo.3
- cp AddErrInfo.3 Tcl_AddErrorInfo.3
- cp AddErrInfo.3 Tcl_SetObjErrorCode.3
- cp AddErrInfo.3 Tcl_SetErrorCode.3
- cp AddErrInfo.3 Tcl_SetErrorCodeVA.3
- cp AddErrInfo.3 Tcl_PosixError.3
- cp AddErrInfo.3 Tcl_LogCommandInfo.3
+ rm -f AddErrInfo.3.*
+ $ZIP AddErrInfo.3
+ rm -f Tcl_AddObjErrorInfo.3 Tcl_AddObjErrorInfo.3.*
+ rm -f Tcl_AddErrorInfo.3 Tcl_AddErrorInfo.3.*
+ rm -f Tcl_SetObjErrorCode.3 Tcl_SetObjErrorCode.3.*
+ rm -f Tcl_SetErrorCode.3 Tcl_SetErrorCode.3.*
+ rm -f Tcl_SetErrorCodeVA.3 Tcl_SetErrorCodeVA.3.*
+ rm -f Tcl_PosixError.3 Tcl_PosixError.3.*
+ rm -f Tcl_LogCommandInfo.3 Tcl_LogCommandInfo.3.*
+ ln $S AddErrInfo.3$Z Tcl_AddObjErrorInfo.3$Z
+ ln $S AddErrInfo.3$Z Tcl_AddErrorInfo.3$Z
+ ln $S AddErrInfo.3$Z Tcl_SetObjErrorCode.3$Z
+ ln $S AddErrInfo.3$Z Tcl_SetErrorCode.3$Z
+ ln $S AddErrInfo.3$Z Tcl_SetErrorCodeVA.3$Z
+ ln $S AddErrInfo.3$Z Tcl_PosixError.3$Z
+ ln $S AddErrInfo.3$Z Tcl_LogCommandInfo.3$Z
fi
if test -r Alloc.3; then
- rm -f Tcl_Alloc.3
- rm -f Tcl_Free.3
- rm -f Tcl_Realloc.3
- cp Alloc.3 Tcl_Alloc.3
- cp Alloc.3 Tcl_Free.3
- cp Alloc.3 Tcl_Realloc.3
+ rm -f Alloc.3.*
+ $ZIP Alloc.3
+ rm -f Tcl_Alloc.3 Tcl_Alloc.3.*
+ rm -f Tcl_Free.3 Tcl_Free.3.*
+ rm -f Tcl_Realloc.3 Tcl_Realloc.3.*
+ rm -f Tcl_AttemptAlloc.3 Tcl_AttemptAlloc.3.*
+ rm -f Tcl_AttemptRealloc.3 Tcl_AttemptRealloc.3.*
+ rm -f ckalloc.3 ckalloc.3.*
+ rm -f ckfree.3 ckfree.3.*
+ rm -f ckrealloc.3 ckrealloc.3.*
+ rm -f attemptckalloc.3 attemptckalloc.3.*
+ rm -f attemptckrealloc.3 attemptckrealloc.3.*
+ ln $S Alloc.3$Z Tcl_Alloc.3$Z
+ ln $S Alloc.3$Z Tcl_Free.3$Z
+ ln $S Alloc.3$Z Tcl_Realloc.3$Z
+ ln $S Alloc.3$Z Tcl_AttemptAlloc.3$Z
+ ln $S Alloc.3$Z Tcl_AttemptRealloc.3$Z
+ ln $S Alloc.3$Z ckalloc.3$Z
+ ln $S Alloc.3$Z ckfree.3$Z
+ ln $S Alloc.3$Z ckrealloc.3$Z
+ ln $S Alloc.3$Z attemptckalloc.3$Z
+ ln $S Alloc.3$Z attemptckrealloc.3$Z
fi
if test -r AllowExc.3; then
- rm -f Tcl_AllowExceptions.3
- cp AllowExc.3 Tcl_AllowExceptions.3
+ rm -f AllowExc.3.*
+ $ZIP AllowExc.3
+ rm -f Tcl_AllowExceptions.3 Tcl_AllowExceptions.3.*
+ ln $S AllowExc.3$Z Tcl_AllowExceptions.3$Z
fi
if test -r AppInit.3; then
- rm -f Tcl_AppInit.3
- cp AppInit.3 Tcl_AppInit.3
+ rm -f AppInit.3.*
+ $ZIP AppInit.3
+ rm -f Tcl_AppInit.3 Tcl_AppInit.3.*
+ ln $S AppInit.3$Z Tcl_AppInit.3$Z
fi
if test -r AssocData.3; then
- rm -f Tcl_GetAssocData.3
- rm -f Tcl_SetAssocData.3
- rm -f Tcl_DeleteAssocData.3
- cp AssocData.3 Tcl_GetAssocData.3
- cp AssocData.3 Tcl_SetAssocData.3
- cp AssocData.3 Tcl_DeleteAssocData.3
+ rm -f AssocData.3.*
+ $ZIP AssocData.3
+ rm -f Tcl_GetAssocData.3 Tcl_GetAssocData.3.*
+ rm -f Tcl_SetAssocData.3 Tcl_SetAssocData.3.*
+ rm -f Tcl_DeleteAssocData.3 Tcl_DeleteAssocData.3.*
+ ln $S AssocData.3$Z Tcl_GetAssocData.3$Z
+ ln $S AssocData.3$Z Tcl_SetAssocData.3$Z
+ ln $S AssocData.3$Z Tcl_DeleteAssocData.3$Z
fi
if test -r Async.3; then
- rm -f Tcl_AsyncCreate.3
- rm -f Tcl_AsyncMark.3
- rm -f Tcl_AsyncInvoke.3
- rm -f Tcl_AsyncDelete.3
- rm -f Tcl_AsyncReady.3
- cp Async.3 Tcl_AsyncCreate.3
- cp Async.3 Tcl_AsyncMark.3
- cp Async.3 Tcl_AsyncInvoke.3
- cp Async.3 Tcl_AsyncDelete.3
- cp Async.3 Tcl_AsyncReady.3
+ rm -f Async.3.*
+ $ZIP Async.3
+ rm -f Tcl_AsyncCreate.3 Tcl_AsyncCreate.3.*
+ rm -f Tcl_AsyncMark.3 Tcl_AsyncMark.3.*
+ rm -f Tcl_AsyncInvoke.3 Tcl_AsyncInvoke.3.*
+ rm -f Tcl_AsyncDelete.3 Tcl_AsyncDelete.3.*
+ rm -f Tcl_AsyncReady.3 Tcl_AsyncReady.3.*
+ ln $S Async.3$Z Tcl_AsyncCreate.3$Z
+ ln $S Async.3$Z Tcl_AsyncMark.3$Z
+ ln $S Async.3$Z Tcl_AsyncInvoke.3$Z
+ ln $S Async.3$Z Tcl_AsyncDelete.3$Z
+ ln $S Async.3$Z Tcl_AsyncReady.3$Z
fi
if test -r BackgdErr.3; then
- rm -f Tcl_BackgroundError.3
- cp BackgdErr.3 Tcl_BackgroundError.3
+ rm -f BackgdErr.3.*
+ $ZIP BackgdErr.3
+ rm -f Tcl_BackgroundError.3 Tcl_BackgroundError.3.*
+ ln $S BackgdErr.3$Z Tcl_BackgroundError.3$Z
fi
if test -r Backslash.3; then
- rm -f Tcl_Backslash.3
- cp Backslash.3 Tcl_Backslash.3
+ rm -f Backslash.3.*
+ $ZIP Backslash.3
+ rm -f Tcl_Backslash.3 Tcl_Backslash.3.*
+ ln $S Backslash.3$Z Tcl_Backslash.3$Z
fi
if test -r BoolObj.3; then
- rm -f Tcl_NewBooleanObj.3
- rm -f Tcl_SetBooleanObj.3
- rm -f Tcl_GetBooleanFromObj.3
- cp BoolObj.3 Tcl_NewBooleanObj.3
- cp BoolObj.3 Tcl_SetBooleanObj.3
- cp BoolObj.3 Tcl_GetBooleanFromObj.3
+ rm -f BoolObj.3.*
+ $ZIP BoolObj.3
+ rm -f Tcl_NewBooleanObj.3 Tcl_NewBooleanObj.3.*
+ rm -f Tcl_SetBooleanObj.3 Tcl_SetBooleanObj.3.*
+ rm -f Tcl_GetBooleanFromObj.3 Tcl_GetBooleanFromObj.3.*
+ ln $S BoolObj.3$Z Tcl_NewBooleanObj.3$Z
+ ln $S BoolObj.3$Z Tcl_SetBooleanObj.3$Z
+ ln $S BoolObj.3$Z Tcl_GetBooleanFromObj.3$Z
fi
if test -r ByteArrObj.3; then
- rm -f Tcl_NewByteArrayObj.3
- rm -f Tcl_SetByteArrayObj.3
- rm -f Tcl_GetByteArrayFromObj.3
- rm -f Tcl_SetByteArrayLength.3
- cp ByteArrObj.3 Tcl_NewByteArrayObj.3
- cp ByteArrObj.3 Tcl_SetByteArrayObj.3
- cp ByteArrObj.3 Tcl_GetByteArrayFromObj.3
- cp ByteArrObj.3 Tcl_SetByteArrayLength.3
+ rm -f ByteArrObj.3.*
+ $ZIP ByteArrObj.3
+ rm -f Tcl_NewByteArrayObj.3 Tcl_NewByteArrayObj.3.*
+ rm -f Tcl_SetByteArrayObj.3 Tcl_SetByteArrayObj.3.*
+ rm -f Tcl_GetByteArrayFromObj.3 Tcl_GetByteArrayFromObj.3.*
+ rm -f Tcl_SetByteArrayLength.3 Tcl_SetByteArrayLength.3.*
+ ln $S ByteArrObj.3$Z Tcl_NewByteArrayObj.3$Z
+ ln $S ByteArrObj.3$Z Tcl_SetByteArrayObj.3$Z
+ ln $S ByteArrObj.3$Z Tcl_GetByteArrayFromObj.3$Z
+ ln $S ByteArrObj.3$Z Tcl_SetByteArrayLength.3$Z
fi
if test -r CallDel.3; then
- rm -f Tcl_CallWhenDeleted.3
- rm -f Tcl_DontCallWhenDeleted.3
- cp CallDel.3 Tcl_CallWhenDeleted.3
- cp CallDel.3 Tcl_DontCallWhenDeleted.3
+ rm -f CallDel.3.*
+ $ZIP CallDel.3
+ rm -f Tcl_CallWhenDeleted.3 Tcl_CallWhenDeleted.3.*
+ rm -f Tcl_DontCallWhenDeleted.3 Tcl_DontCallWhenDeleted.3.*
+ ln $S CallDel.3$Z Tcl_CallWhenDeleted.3$Z
+ ln $S CallDel.3$Z Tcl_DontCallWhenDeleted.3$Z
fi
if test -r ChnlStack.3; then
- rm -f Tcl_StackChannel.3
- rm -f Tcl_UnstackChannel.3
- rm -f Tcl_GetStackedChannel.3
- cp ChnlStack.3 Tcl_StackChannel.3
- cp ChnlStack.3 Tcl_UnstackChannel.3
- cp ChnlStack.3 Tcl_GetStackedChannel.3
+ rm -f ChnlStack.3.*
+ $ZIP ChnlStack.3
+ rm -f Tcl_StackChannel.3 Tcl_StackChannel.3.*
+ rm -f Tcl_UnstackChannel.3 Tcl_UnstackChannel.3.*
+ rm -f Tcl_GetStackedChannel.3 Tcl_GetStackedChannel.3.*
+ rm -f Tcl_GetTopChannel.3 Tcl_GetTopChannel.3.*
+ ln $S ChnlStack.3$Z Tcl_StackChannel.3$Z
+ ln $S ChnlStack.3$Z Tcl_UnstackChannel.3$Z
+ ln $S ChnlStack.3$Z Tcl_GetStackedChannel.3$Z
+ ln $S ChnlStack.3$Z Tcl_GetTopChannel.3$Z
fi
if test -r CmdCmplt.3; then
- rm -f Tcl_CommandComplete.3
- cp CmdCmplt.3 Tcl_CommandComplete.3
+ rm -f CmdCmplt.3.*
+ $ZIP CmdCmplt.3
+ rm -f Tcl_CommandComplete.3 Tcl_CommandComplete.3.*
+ ln $S CmdCmplt.3$Z Tcl_CommandComplete.3$Z
fi
if test -r Concat.3; then
- rm -f Tcl_Concat.3
- cp Concat.3 Tcl_Concat.3
+ rm -f Concat.3.*
+ $ZIP Concat.3
+ rm -f Tcl_Concat.3 Tcl_Concat.3.*
+ ln $S Concat.3$Z Tcl_Concat.3$Z
fi
if test -r CrtChannel.3; then
- rm -f Tcl_CreateChannel.3
- rm -f Tcl_GetChannelInstanceData.3
- rm -f Tcl_GetChannelType.3
- rm -f Tcl_GetChannelName.3
- rm -f Tcl_GetChannelHandle.3
- rm -f Tcl_GetChannelMode.3
- rm -f Tcl_GetChannelBufferSize.3
- rm -f Tcl_SetChannelBufferSize.3
- rm -f Tcl_NotifyChannel.3
- rm -f Tcl_BadChannelOption.3
- rm -f Tcl_ChannelName.3
- rm -f Tcl_ChannelVersion.3
- rm -f Tcl_ChannelBlockModeProc.3
- rm -f Tcl_ChannelCloseProc.3
- rm -f Tcl_ChannelClose2Proc.3
- rm -f Tcl_ChannelInputProc.3
- rm -f Tcl_ChannelOutputProc.3
- rm -f Tcl_ChannelSeekProc.3
- rm -f Tcl_ChannelSetOptionProc.3
- rm -f Tcl_ChannelGetOptionProc.3
- rm -f Tcl_ChannelWatchProc.3
- rm -f Tcl_ChannelGetHandleProc.3
- rm -f Tcl_ChannelFlushProc.3
- rm -f Tcl_ChannelHandlerProc.3
- cp CrtChannel.3 Tcl_CreateChannel.3
- cp CrtChannel.3 Tcl_GetChannelInstanceData.3
- cp CrtChannel.3 Tcl_GetChannelType.3
- cp CrtChannel.3 Tcl_GetChannelName.3
- cp CrtChannel.3 Tcl_GetChannelHandle.3
- cp CrtChannel.3 Tcl_GetChannelMode.3
- cp CrtChannel.3 Tcl_GetChannelBufferSize.3
- cp CrtChannel.3 Tcl_SetChannelBufferSize.3
- cp CrtChannel.3 Tcl_NotifyChannel.3
- cp CrtChannel.3 Tcl_BadChannelOption.3
- cp CrtChannel.3 Tcl_ChannelName.3
- cp CrtChannel.3 Tcl_ChannelVersion.3
- cp CrtChannel.3 Tcl_ChannelBlockModeProc.3
- cp CrtChannel.3 Tcl_ChannelCloseProc.3
- cp CrtChannel.3 Tcl_ChannelClose2Proc.3
- cp CrtChannel.3 Tcl_ChannelInputProc.3
- cp CrtChannel.3 Tcl_ChannelOutputProc.3
- cp CrtChannel.3 Tcl_ChannelSeekProc.3
- cp CrtChannel.3 Tcl_ChannelSetOptionProc.3
- cp CrtChannel.3 Tcl_ChannelGetOptionProc.3
- cp CrtChannel.3 Tcl_ChannelWatchProc.3
- cp CrtChannel.3 Tcl_ChannelGetHandleProc.3
- cp CrtChannel.3 Tcl_ChannelFlushProc.3
- cp CrtChannel.3 Tcl_ChannelHandlerProc.3
+ rm -f CrtChannel.3.*
+ $ZIP CrtChannel.3
+ rm -f Tcl_CreateChannel.3 Tcl_CreateChannel.3.*
+ rm -f Tcl_GetChannelInstanceData.3 Tcl_GetChannelInstanceData.3.*
+ rm -f Tcl_GetChannelType.3 Tcl_GetChannelType.3.*
+ rm -f Tcl_GetChannelName.3 Tcl_GetChannelName.3.*
+ rm -f Tcl_GetChannelHandle.3 Tcl_GetChannelHandle.3.*
+ rm -f Tcl_GetChannelMode.3 Tcl_GetChannelMode.3.*
+ rm -f Tcl_GetChannelBufferSize.3 Tcl_GetChannelBufferSize.3.*
+ rm -f Tcl_SetChannelBufferSize.3 Tcl_SetChannelBufferSize.3.*
+ rm -f Tcl_NotifyChannel.3 Tcl_NotifyChannel.3.*
+ rm -f Tcl_BadChannelOption.3 Tcl_BadChannelOption.3.*
+ rm -f Tcl_ChannelName.3 Tcl_ChannelName.3.*
+ rm -f Tcl_ChannelVersion.3 Tcl_ChannelVersion.3.*
+ rm -f Tcl_ChannelBlockModeProc.3 Tcl_ChannelBlockModeProc.3.*
+ rm -f Tcl_ChannelCloseProc.3 Tcl_ChannelCloseProc.3.*
+ rm -f Tcl_ChannelClose2Proc.3 Tcl_ChannelClose2Proc.3.*
+ rm -f Tcl_ChannelInputProc.3 Tcl_ChannelInputProc.3.*
+ rm -f Tcl_ChannelOutputProc.3 Tcl_ChannelOutputProc.3.*
+ rm -f Tcl_ChannelSeekProc.3 Tcl_ChannelSeekProc.3.*
+ rm -f Tcl_ChannelWideSeekProc.3 Tcl_ChannelWideSeekProc.3.*
+ rm -f Tcl_ChannelSetOptionProc.3 Tcl_ChannelSetOptionProc.3.*
+ rm -f Tcl_ChannelGetOptionProc.3 Tcl_ChannelGetOptionProc.3.*
+ rm -f Tcl_ChannelWatchProc.3 Tcl_ChannelWatchProc.3.*
+ rm -f Tcl_ChannelGetHandleProc.3 Tcl_ChannelGetHandleProc.3.*
+ rm -f Tcl_ChannelFlushProc.3 Tcl_ChannelFlushProc.3.*
+ rm -f Tcl_ChannelHandlerProc.3 Tcl_ChannelHandlerProc.3.*
+ rm -f Tcl_IsChannelShared.3 Tcl_IsChannelShared.3.*
+ rm -f Tcl_IsChannelRegistered.3 Tcl_IsChannelRegistered.3.*
+ rm -f Tcl_CutChannel.3 Tcl_CutChannel.3.*
+ rm -f Tcl_SpliceChannel.3 Tcl_SpliceChannel.3.*
+ rm -f Tcl_IsChannelExisting.3 Tcl_IsChannelExisting.3.*
+ rm -f Tcl_ClearChannelHandlers.3 Tcl_ClearChannelHandlers.3.*
+ rm -f Tcl_GetChannelThread.3 Tcl_GetChannelThread.3.*
+ rm -f Tcl_ChannelBuffered.3 Tcl_ChannelBuffered.3.*
+ ln $S CrtChannel.3$Z Tcl_CreateChannel.3$Z
+ ln $S CrtChannel.3$Z Tcl_GetChannelInstanceData.3$Z
+ ln $S CrtChannel.3$Z Tcl_GetChannelType.3$Z
+ ln $S CrtChannel.3$Z Tcl_GetChannelName.3$Z
+ ln $S CrtChannel.3$Z Tcl_GetChannelHandle.3$Z
+ ln $S CrtChannel.3$Z Tcl_GetChannelMode.3$Z
+ ln $S CrtChannel.3$Z Tcl_GetChannelBufferSize.3$Z
+ ln $S CrtChannel.3$Z Tcl_SetChannelBufferSize.3$Z
+ ln $S CrtChannel.3$Z Tcl_NotifyChannel.3$Z
+ ln $S CrtChannel.3$Z Tcl_BadChannelOption.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelName.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelVersion.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelBlockModeProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelCloseProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelClose2Proc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelInputProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelOutputProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelSeekProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelWideSeekProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelSetOptionProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelGetOptionProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelWatchProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelGetHandleProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelFlushProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelHandlerProc.3$Z
+ ln $S CrtChannel.3$Z Tcl_IsChannelShared.3$Z
+ ln $S CrtChannel.3$Z Tcl_IsChannelRegistered.3$Z
+ ln $S CrtChannel.3$Z Tcl_CutChannel.3$Z
+ ln $S CrtChannel.3$Z Tcl_SpliceChannel.3$Z
+ ln $S CrtChannel.3$Z Tcl_IsChannelExisting.3$Z
+ ln $S CrtChannel.3$Z Tcl_ClearChannelHandlers.3$Z
+ ln $S CrtChannel.3$Z Tcl_GetChannelThread.3$Z
+ ln $S CrtChannel.3$Z Tcl_ChannelBuffered.3$Z
fi
if test -r CrtChnlHdlr.3; then
- rm -f Tcl_CreateChannelHandler.3
- rm -f Tcl_DeleteChannelHandler.3
- cp CrtChnlHdlr.3 Tcl_CreateChannelHandler.3
- cp CrtChnlHdlr.3 Tcl_DeleteChannelHandler.3
+ rm -f CrtChnlHdlr.3.*
+ $ZIP CrtChnlHdlr.3
+ rm -f Tcl_CreateChannelHandler.3 Tcl_CreateChannelHandler.3.*
+ rm -f Tcl_DeleteChannelHandler.3 Tcl_DeleteChannelHandler.3.*
+ ln $S CrtChnlHdlr.3$Z Tcl_CreateChannelHandler.3$Z
+ ln $S CrtChnlHdlr.3$Z Tcl_DeleteChannelHandler.3$Z
fi
if test -r CrtCloseHdlr.3; then
- rm -f Tcl_CreateCloseHandler.3
- rm -f Tcl_DeleteCloseHandler.3
- cp CrtCloseHdlr.3 Tcl_CreateCloseHandler.3
- cp CrtCloseHdlr.3 Tcl_DeleteCloseHandler.3
+ rm -f CrtCloseHdlr.3.*
+ $ZIP CrtCloseHdlr.3
+ rm -f Tcl_CreateCloseHandler.3 Tcl_CreateCloseHandler.3.*
+ rm -f Tcl_DeleteCloseHandler.3 Tcl_DeleteCloseHandler.3.*
+ ln $S CrtCloseHdlr.3$Z Tcl_CreateCloseHandler.3$Z
+ ln $S CrtCloseHdlr.3$Z Tcl_DeleteCloseHandler.3$Z
fi
if test -r CrtCommand.3; then
- rm -f Tcl_CreateCommand.3
- cp CrtCommand.3 Tcl_CreateCommand.3
+ rm -f CrtCommand.3.*
+ $ZIP CrtCommand.3
+ rm -f Tcl_CreateCommand.3 Tcl_CreateCommand.3.*
+ ln $S CrtCommand.3$Z Tcl_CreateCommand.3$Z
fi
if test -r CrtFileHdlr.3; then
- rm -f Tcl_CreateFileHandler.3
- rm -f Tcl_DeleteFileHandler.3
- cp CrtFileHdlr.3 Tcl_CreateFileHandler.3
- cp CrtFileHdlr.3 Tcl_DeleteFileHandler.3
+ rm -f CrtFileHdlr.3.*
+ $ZIP CrtFileHdlr.3
+ rm -f Tcl_CreateFileHandler.3 Tcl_CreateFileHandler.3.*
+ rm -f Tcl_DeleteFileHandler.3 Tcl_DeleteFileHandler.3.*
+ ln $S CrtFileHdlr.3$Z Tcl_CreateFileHandler.3$Z
+ ln $S CrtFileHdlr.3$Z Tcl_DeleteFileHandler.3$Z
fi
if test -r CrtInterp.3; then
- rm -f Tcl_CreateInterp.3
- rm -f Tcl_DeleteInterp.3
- rm -f Tcl_InterpDeleted.3
- cp CrtInterp.3 Tcl_CreateInterp.3
- cp CrtInterp.3 Tcl_DeleteInterp.3
- cp CrtInterp.3 Tcl_InterpDeleted.3
+ rm -f CrtInterp.3.*
+ $ZIP CrtInterp.3
+ rm -f Tcl_CreateInterp.3 Tcl_CreateInterp.3.*
+ rm -f Tcl_DeleteInterp.3 Tcl_DeleteInterp.3.*
+ rm -f Tcl_InterpDeleted.3 Tcl_InterpDeleted.3.*
+ ln $S CrtInterp.3$Z Tcl_CreateInterp.3$Z
+ ln $S CrtInterp.3$Z Tcl_DeleteInterp.3$Z
+ ln $S CrtInterp.3$Z Tcl_InterpDeleted.3$Z
fi
if test -r CrtMathFnc.3; then
- rm -f Tcl_CreateMathFunc.3
- cp CrtMathFnc.3 Tcl_CreateMathFunc.3
+ rm -f CrtMathFnc.3.*
+ $ZIP CrtMathFnc.3
+ rm -f Tcl_CreateMathFunc.3 Tcl_CreateMathFunc.3.*
+ rm -f Tcl_GetMathFuncInfo.3 Tcl_GetMathFuncInfo.3.*
+ rm -f Tcl_ListMathFuncs.3 Tcl_ListMathFuncs.3.*
+ ln $S CrtMathFnc.3$Z Tcl_CreateMathFunc.3$Z
+ ln $S CrtMathFnc.3$Z Tcl_GetMathFuncInfo.3$Z
+ ln $S CrtMathFnc.3$Z Tcl_ListMathFuncs.3$Z
fi
if test -r CrtObjCmd.3; then
- rm -f Tcl_CreateObjCommand.3
- rm -f Tcl_DeleteCommand.3
- rm -f Tcl_DeleteCommandFromToken.3
- rm -f Tcl_GetCommandInfo.3
- rm -f Tcl_SetCommandInfo.3
- rm -f Tcl_GetCommandName.3
- cp CrtObjCmd.3 Tcl_CreateObjCommand.3
- cp CrtObjCmd.3 Tcl_DeleteCommand.3
- cp CrtObjCmd.3 Tcl_DeleteCommandFromToken.3
- cp CrtObjCmd.3 Tcl_GetCommandInfo.3
- cp CrtObjCmd.3 Tcl_SetCommandInfo.3
- cp CrtObjCmd.3 Tcl_GetCommandName.3
+ rm -f CrtObjCmd.3.*
+ $ZIP CrtObjCmd.3
+ rm -f Tcl_CreateObjCommand.3 Tcl_CreateObjCommand.3.*
+ rm -f Tcl_DeleteCommand.3 Tcl_DeleteCommand.3.*
+ rm -f Tcl_DeleteCommandFromToken.3 Tcl_DeleteCommandFromToken.3.*
+ rm -f Tcl_GetCommandInfo.3 Tcl_GetCommandInfo.3.*
+ rm -f Tcl_GetCommandInfoFromToken.3 Tcl_GetCommandInfoFromToken.3.*
+ rm -f Tcl_SetCommandInfo.3 Tcl_SetCommandInfo.3.*
+ rm -f Tcl_SetCommandInfoFromToken.3 Tcl_SetCommandInfoFromToken.3.*
+ rm -f Tcl_GetCommandName.3 Tcl_GetCommandName.3.*
+ rm -f Tcl_GetCommandFullName.3 Tcl_GetCommandFullName.3.*
+ rm -f Tcl_GetCommandFromObj.3 Tcl_GetCommandFromObj.3.*
+ ln $S CrtObjCmd.3$Z Tcl_CreateObjCommand.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_DeleteCommand.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_DeleteCommandFromToken.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_GetCommandInfo.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_GetCommandInfoFromToken.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_SetCommandInfo.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_SetCommandInfoFromToken.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_GetCommandName.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_GetCommandFullName.3$Z
+ ln $S CrtObjCmd.3$Z Tcl_GetCommandFromObj.3$Z
fi
if test -r CrtSlave.3; then
- rm -f Tcl_IsSafe.3
- rm -f Tcl_MakeSafe.3
- rm -f Tcl_CreateSlave.3
- rm -f Tcl_GetSlave.3
- rm -f Tcl_GetMaster.3
- rm -f Tcl_GetInterpPath.3
- rm -f Tcl_CreateAlias.3
- rm -f Tcl_CreateAliasObj.3
- rm -f Tcl_GetAlias.3
- rm -f Tcl_GetAliasObj.3
- rm -f Tcl_ExposeCommand.3
- rm -f Tcl_HideCommand.3
- cp CrtSlave.3 Tcl_IsSafe.3
- cp CrtSlave.3 Tcl_MakeSafe.3
- cp CrtSlave.3 Tcl_CreateSlave.3
- cp CrtSlave.3 Tcl_GetSlave.3
- cp CrtSlave.3 Tcl_GetMaster.3
- cp CrtSlave.3 Tcl_GetInterpPath.3
- cp CrtSlave.3 Tcl_CreateAlias.3
- cp CrtSlave.3 Tcl_CreateAliasObj.3
- cp CrtSlave.3 Tcl_GetAlias.3
- cp CrtSlave.3 Tcl_GetAliasObj.3
- cp CrtSlave.3 Tcl_ExposeCommand.3
- cp CrtSlave.3 Tcl_HideCommand.3
+ rm -f CrtSlave.3.*
+ $ZIP CrtSlave.3
+ rm -f Tcl_IsSafe.3 Tcl_IsSafe.3.*
+ rm -f Tcl_MakeSafe.3 Tcl_MakeSafe.3.*
+ rm -f Tcl_CreateSlave.3 Tcl_CreateSlave.3.*
+ rm -f Tcl_GetSlave.3 Tcl_GetSlave.3.*
+ rm -f Tcl_GetMaster.3 Tcl_GetMaster.3.*
+ rm -f Tcl_GetInterpPath.3 Tcl_GetInterpPath.3.*
+ rm -f Tcl_CreateAlias.3 Tcl_CreateAlias.3.*
+ rm -f Tcl_CreateAliasObj.3 Tcl_CreateAliasObj.3.*
+ rm -f Tcl_GetAlias.3 Tcl_GetAlias.3.*
+ rm -f Tcl_GetAliasObj.3 Tcl_GetAliasObj.3.*
+ rm -f Tcl_ExposeCommand.3 Tcl_ExposeCommand.3.*
+ rm -f Tcl_HideCommand.3 Tcl_HideCommand.3.*
+ ln $S CrtSlave.3$Z Tcl_IsSafe.3$Z
+ ln $S CrtSlave.3$Z Tcl_MakeSafe.3$Z
+ ln $S CrtSlave.3$Z Tcl_CreateSlave.3$Z
+ ln $S CrtSlave.3$Z Tcl_GetSlave.3$Z
+ ln $S CrtSlave.3$Z Tcl_GetMaster.3$Z
+ ln $S CrtSlave.3$Z Tcl_GetInterpPath.3$Z
+ ln $S CrtSlave.3$Z Tcl_CreateAlias.3$Z
+ ln $S CrtSlave.3$Z Tcl_CreateAliasObj.3$Z
+ ln $S CrtSlave.3$Z Tcl_GetAlias.3$Z
+ ln $S CrtSlave.3$Z Tcl_GetAliasObj.3$Z
+ ln $S CrtSlave.3$Z Tcl_ExposeCommand.3$Z
+ ln $S CrtSlave.3$Z Tcl_HideCommand.3$Z
fi
if test -r CrtTimerHdlr.3; then
- rm -f Tcl_CreateTimerHandler.3
- rm -f Tcl_DeleteTimerHandler.3
- cp CrtTimerHdlr.3 Tcl_CreateTimerHandler.3
- cp CrtTimerHdlr.3 Tcl_DeleteTimerHandler.3
+ rm -f CrtTimerHdlr.3.*
+ $ZIP CrtTimerHdlr.3
+ rm -f Tcl_CreateTimerHandler.3 Tcl_CreateTimerHandler.3.*
+ rm -f Tcl_DeleteTimerHandler.3 Tcl_DeleteTimerHandler.3.*
+ ln $S CrtTimerHdlr.3$Z Tcl_CreateTimerHandler.3$Z
+ ln $S CrtTimerHdlr.3$Z Tcl_DeleteTimerHandler.3$Z
fi
if test -r CrtTrace.3; then
- rm -f Tcl_CreateTrace.3
- rm -f Tcl_DeleteTrace.3
- cp CrtTrace.3 Tcl_CreateTrace.3
- cp CrtTrace.3 Tcl_DeleteTrace.3
+ rm -f CrtTrace.3.*
+ $ZIP CrtTrace.3
+ rm -f Tcl_CreateTrace.3 Tcl_CreateTrace.3.*
+ rm -f Tcl_CreateObjTrace.3 Tcl_CreateObjTrace.3.*
+ rm -f Tcl_DeleteTrace.3 Tcl_DeleteTrace.3.*
+ ln $S CrtTrace.3$Z Tcl_CreateTrace.3$Z
+ ln $S CrtTrace.3$Z Tcl_CreateObjTrace.3$Z
+ ln $S CrtTrace.3$Z Tcl_DeleteTrace.3$Z
fi
if test -r DString.3; then
- rm -f Tcl_DStringInit.3
- rm -f Tcl_DStringAppend.3
- rm -f Tcl_DStringAppendElement.3
- rm -f Tcl_DStringStartSublist.3
- rm -f Tcl_DStringEndSublist.3
- rm -f Tcl_DStringLength.3
- rm -f Tcl_DStringValue.3
- rm -f Tcl_DStringSetLength.3
- rm -f Tcl_DStringFree.3
- rm -f Tcl_DStringResult.3
- rm -f Tcl_DStringGetResult.3
- cp DString.3 Tcl_DStringInit.3
- cp DString.3 Tcl_DStringAppend.3
- cp DString.3 Tcl_DStringAppendElement.3
- cp DString.3 Tcl_DStringStartSublist.3
- cp DString.3 Tcl_DStringEndSublist.3
- cp DString.3 Tcl_DStringLength.3
- cp DString.3 Tcl_DStringValue.3
- cp DString.3 Tcl_DStringSetLength.3
- cp DString.3 Tcl_DStringFree.3
- cp DString.3 Tcl_DStringResult.3
- cp DString.3 Tcl_DStringGetResult.3
+ rm -f DString.3.*
+ $ZIP DString.3
+ rm -f Tcl_DStringInit.3 Tcl_DStringInit.3.*
+ rm -f Tcl_DStringAppend.3 Tcl_DStringAppend.3.*
+ rm -f Tcl_DStringAppendElement.3 Tcl_DStringAppendElement.3.*
+ rm -f Tcl_DStringStartSublist.3 Tcl_DStringStartSublist.3.*
+ rm -f Tcl_DStringEndSublist.3 Tcl_DStringEndSublist.3.*
+ rm -f Tcl_DStringLength.3 Tcl_DStringLength.3.*
+ rm -f Tcl_DStringValue.3 Tcl_DStringValue.3.*
+ rm -f Tcl_DStringSetLength.3 Tcl_DStringSetLength.3.*
+ rm -f Tcl_DStringTrunc.3 Tcl_DStringTrunc.3.*
+ rm -f Tcl_DStringFree.3 Tcl_DStringFree.3.*
+ rm -f Tcl_DStringResult.3 Tcl_DStringResult.3.*
+ rm -f Tcl_DStringGetResult.3 Tcl_DStringGetResult.3.*
+ ln $S DString.3$Z Tcl_DStringInit.3$Z
+ ln $S DString.3$Z Tcl_DStringAppend.3$Z
+ ln $S DString.3$Z Tcl_DStringAppendElement.3$Z
+ ln $S DString.3$Z Tcl_DStringStartSublist.3$Z
+ ln $S DString.3$Z Tcl_DStringEndSublist.3$Z
+ ln $S DString.3$Z Tcl_DStringLength.3$Z
+ ln $S DString.3$Z Tcl_DStringValue.3$Z
+ ln $S DString.3$Z Tcl_DStringSetLength.3$Z
+ ln $S DString.3$Z Tcl_DStringTrunc.3$Z
+ ln $S DString.3$Z Tcl_DStringFree.3$Z
+ ln $S DString.3$Z Tcl_DStringResult.3$Z
+ ln $S DString.3$Z Tcl_DStringGetResult.3$Z
fi
if test -r DetachPids.3; then
- rm -f Tcl_DetachPids.3
- rm -f Tcl_ReapDetachedProcs.3
- cp DetachPids.3 Tcl_DetachPids.3
- cp DetachPids.3 Tcl_ReapDetachedProcs.3
+ rm -f DetachPids.3.*
+ $ZIP DetachPids.3
+ rm -f Tcl_DetachPids.3 Tcl_DetachPids.3.*
+ rm -f Tcl_ReapDetachedProcs.3 Tcl_ReapDetachedProcs.3.*
+ rm -f Tcl_WaitPid.3 Tcl_WaitPid.3.*
+ ln $S DetachPids.3$Z Tcl_DetachPids.3$Z
+ ln $S DetachPids.3$Z Tcl_ReapDetachedProcs.3$Z
+ ln $S DetachPids.3$Z Tcl_WaitPid.3$Z
fi
if test -r DoOneEvent.3; then
- rm -f Tcl_DoOneEvent.3
- cp DoOneEvent.3 Tcl_DoOneEvent.3
+ rm -f DoOneEvent.3.*
+ $ZIP DoOneEvent.3
+ rm -f Tcl_DoOneEvent.3 Tcl_DoOneEvent.3.*
+ ln $S DoOneEvent.3$Z Tcl_DoOneEvent.3$Z
fi
if test -r DoWhenIdle.3; then
- rm -f Tcl_DoWhenIdle.3
- rm -f Tcl_CancelIdleCall.3
- cp DoWhenIdle.3 Tcl_DoWhenIdle.3
- cp DoWhenIdle.3 Tcl_CancelIdleCall.3
+ rm -f DoWhenIdle.3.*
+ $ZIP DoWhenIdle.3
+ rm -f Tcl_DoWhenIdle.3 Tcl_DoWhenIdle.3.*
+ rm -f Tcl_CancelIdleCall.3 Tcl_CancelIdleCall.3.*
+ ln $S DoWhenIdle.3$Z Tcl_DoWhenIdle.3$Z
+ ln $S DoWhenIdle.3$Z Tcl_CancelIdleCall.3$Z
fi
if test -r DoubleObj.3; then
- rm -f Tcl_NewDoubleObj.3
- rm -f Tcl_SetDoubleObj.3
- rm -f Tcl_GetDoubleFromObj.3
- cp DoubleObj.3 Tcl_NewDoubleObj.3
- cp DoubleObj.3 Tcl_SetDoubleObj.3
- cp DoubleObj.3 Tcl_GetDoubleFromObj.3
+ rm -f DoubleObj.3.*
+ $ZIP DoubleObj.3
+ rm -f Tcl_NewDoubleObj.3 Tcl_NewDoubleObj.3.*
+ rm -f Tcl_SetDoubleObj.3 Tcl_SetDoubleObj.3.*
+ rm -f Tcl_GetDoubleFromObj.3 Tcl_GetDoubleFromObj.3.*
+ ln $S DoubleObj.3$Z Tcl_NewDoubleObj.3$Z
+ ln $S DoubleObj.3$Z Tcl_SetDoubleObj.3$Z
+ ln $S DoubleObj.3$Z Tcl_GetDoubleFromObj.3$Z
fi
if test -r DumpActiveMemory.3; then
- rm -f Tcl_DumpActiveMemory.3
- rm -f Tcl_InitMemory.3
- rm -f Tcl_ValidateAllMemory.3
- cp DumpActiveMemory.3 Tcl_DumpActiveMemory.3
- cp DumpActiveMemory.3 Tcl_InitMemory.3
- cp DumpActiveMemory.3 Tcl_ValidateAllMemory.3
+ rm -f DumpActiveMemory.3.*
+ $ZIP DumpActiveMemory.3
+ rm -f Tcl_DumpActiveMemory.3 Tcl_DumpActiveMemory.3.*
+ rm -f Tcl_InitMemory.3 Tcl_InitMemory.3.*
+ rm -f Tcl_ValidateAllMemory.3 Tcl_ValidateAllMemory.3.*
+ ln $S DumpActiveMemory.3$Z Tcl_DumpActiveMemory.3$Z
+ ln $S DumpActiveMemory.3$Z Tcl_InitMemory.3$Z
+ ln $S DumpActiveMemory.3$Z Tcl_ValidateAllMemory.3$Z
fi
if test -r Encoding.3; then
- rm -f Tcl_GetEncoding.3
- rm -f Tcl_FreeEncoding.3
- rm -f Tcl_ExternalToUtfDString.3
- rm -f Tcl_ExternalToUtf.3
- rm -f Tcl_UtfToExternalDString.3
- rm -f Tcl_UtfToExternal.3
- rm -f Tcl_WinTCharToUtf.3
- rm -f Tcl_WinUtfToTChar.3
- rm -f Tcl_GetEncodingName.3
- rm -f Tcl_SetSystemEncoding.3
- rm -f Tcl_GetEncodingNames.3
- rm -f Tcl_CreateEncoding.3
- rm -f Tcl_GetDefaultEncodingDir.3
- rm -f Tcl_SetDefaultEncodingDir.3
- cp Encoding.3 Tcl_GetEncoding.3
- cp Encoding.3 Tcl_FreeEncoding.3
- cp Encoding.3 Tcl_ExternalToUtfDString.3
- cp Encoding.3 Tcl_ExternalToUtf.3
- cp Encoding.3 Tcl_UtfToExternalDString.3
- cp Encoding.3 Tcl_UtfToExternal.3
- cp Encoding.3 Tcl_WinTCharToUtf.3
- cp Encoding.3 Tcl_WinUtfToTChar.3
- cp Encoding.3 Tcl_GetEncodingName.3
- cp Encoding.3 Tcl_SetSystemEncoding.3
- cp Encoding.3 Tcl_GetEncodingNames.3
- cp Encoding.3 Tcl_CreateEncoding.3
- cp Encoding.3 Tcl_GetDefaultEncodingDir.3
- cp Encoding.3 Tcl_SetDefaultEncodingDir.3
+ rm -f Encoding.3.*
+ $ZIP Encoding.3
+ rm -f Tcl_GetEncoding.3 Tcl_GetEncoding.3.*
+ rm -f Tcl_FreeEncoding.3 Tcl_FreeEncoding.3.*
+ rm -f Tcl_ExternalToUtfDString.3 Tcl_ExternalToUtfDString.3.*
+ rm -f Tcl_ExternalToUtf.3 Tcl_ExternalToUtf.3.*
+ rm -f Tcl_UtfToExternalDString.3 Tcl_UtfToExternalDString.3.*
+ rm -f Tcl_UtfToExternal.3 Tcl_UtfToExternal.3.*
+ rm -f Tcl_WinTCharToUtf.3 Tcl_WinTCharToUtf.3.*
+ rm -f Tcl_WinUtfToTChar.3 Tcl_WinUtfToTChar.3.*
+ rm -f Tcl_GetEncodingName.3 Tcl_GetEncodingName.3.*
+ rm -f Tcl_SetSystemEncoding.3 Tcl_SetSystemEncoding.3.*
+ rm -f Tcl_GetEncodingNames.3 Tcl_GetEncodingNames.3.*
+ rm -f Tcl_CreateEncoding.3 Tcl_CreateEncoding.3.*
+ rm -f Tcl_GetDefaultEncodingDir.3 Tcl_GetDefaultEncodingDir.3.*
+ rm -f Tcl_SetDefaultEncodingDir.3 Tcl_SetDefaultEncodingDir.3.*
+ ln $S Encoding.3$Z Tcl_GetEncoding.3$Z
+ ln $S Encoding.3$Z Tcl_FreeEncoding.3$Z
+ ln $S Encoding.3$Z Tcl_ExternalToUtfDString.3$Z
+ ln $S Encoding.3$Z Tcl_ExternalToUtf.3$Z
+ ln $S Encoding.3$Z Tcl_UtfToExternalDString.3$Z
+ ln $S Encoding.3$Z Tcl_UtfToExternal.3$Z
+ ln $S Encoding.3$Z Tcl_WinTCharToUtf.3$Z
+ ln $S Encoding.3$Z Tcl_WinUtfToTChar.3$Z
+ ln $S Encoding.3$Z Tcl_GetEncodingName.3$Z
+ ln $S Encoding.3$Z Tcl_SetSystemEncoding.3$Z
+ ln $S Encoding.3$Z Tcl_GetEncodingNames.3$Z
+ ln $S Encoding.3$Z Tcl_CreateEncoding.3$Z
+ ln $S Encoding.3$Z Tcl_GetDefaultEncodingDir.3$Z
+ ln $S Encoding.3$Z Tcl_SetDefaultEncodingDir.3$Z
+fi
+if test -r Environment.3; then
+ rm -f Environment.3.*
+ $ZIP Environment.3
+ rm -f Tcl_PutEnv.3 Tcl_PutEnv.3.*
+ ln $S Environment.3$Z Tcl_PutEnv.3$Z
fi
if test -r Eval.3; then
- rm -f Tcl_EvalObjEx.3
- rm -f Tcl_EvalFile.3
- rm -f Tcl_EvalObjv.3
- rm -f Tcl_Eval.3
- rm -f Tcl_EvalEx.3
- rm -f Tcl_GlobalEval.3
- rm -f Tcl_GlobalEvalObj.3
- rm -f Tcl_VarEval.3
- rm -f Tcl_VarEvalVA.3
- cp Eval.3 Tcl_EvalObjEx.3
- cp Eval.3 Tcl_EvalFile.3
- cp Eval.3 Tcl_EvalObjv.3
- cp Eval.3 Tcl_Eval.3
- cp Eval.3 Tcl_EvalEx.3
- cp Eval.3 Tcl_GlobalEval.3
- cp Eval.3 Tcl_GlobalEvalObj.3
- cp Eval.3 Tcl_VarEval.3
- cp Eval.3 Tcl_VarEvalVA.3
+ rm -f Eval.3.*
+ $ZIP Eval.3
+ rm -f Tcl_EvalObjEx.3 Tcl_EvalObjEx.3.*
+ rm -f Tcl_EvalFile.3 Tcl_EvalFile.3.*
+ rm -f Tcl_EvalObjv.3 Tcl_EvalObjv.3.*
+ rm -f Tcl_Eval.3 Tcl_Eval.3.*
+ rm -f Tcl_EvalEx.3 Tcl_EvalEx.3.*
+ rm -f Tcl_GlobalEval.3 Tcl_GlobalEval.3.*
+ rm -f Tcl_GlobalEvalObj.3 Tcl_GlobalEvalObj.3.*
+ rm -f Tcl_VarEval.3 Tcl_VarEval.3.*
+ rm -f Tcl_VarEvalVA.3 Tcl_VarEvalVA.3.*
+ ln $S Eval.3$Z Tcl_EvalObjEx.3$Z
+ ln $S Eval.3$Z Tcl_EvalFile.3$Z
+ ln $S Eval.3$Z Tcl_EvalObjv.3$Z
+ ln $S Eval.3$Z Tcl_Eval.3$Z
+ ln $S Eval.3$Z Tcl_EvalEx.3$Z
+ ln $S Eval.3$Z Tcl_GlobalEval.3$Z
+ ln $S Eval.3$Z Tcl_GlobalEvalObj.3$Z
+ ln $S Eval.3$Z Tcl_VarEval.3$Z
+ ln $S Eval.3$Z Tcl_VarEvalVA.3$Z
fi
if test -r Exit.3; then
- rm -f Tcl_Exit.3
- rm -f Tcl_Finalize.3
- rm -f Tcl_CreateExitHandler.3
- rm -f Tcl_DeleteExitHandler.3
- rm -f Tcl_ExitThread.3
- rm -f Tcl_FinalizeThread.3
- rm -f Tcl_CreateThreadExitHandler.3
- rm -f Tcl_DeleteThreadExitHandler.3
- cp Exit.3 Tcl_Exit.3
- cp Exit.3 Tcl_Finalize.3
- cp Exit.3 Tcl_CreateExitHandler.3
- cp Exit.3 Tcl_DeleteExitHandler.3
- cp Exit.3 Tcl_ExitThread.3
- cp Exit.3 Tcl_FinalizeThread.3
- cp Exit.3 Tcl_CreateThreadExitHandler.3
- cp Exit.3 Tcl_DeleteThreadExitHandler.3
+ rm -f Exit.3.*
+ $ZIP Exit.3
+ rm -f Tcl_Exit.3 Tcl_Exit.3.*
+ rm -f Tcl_Finalize.3 Tcl_Finalize.3.*
+ rm -f Tcl_CreateExitHandler.3 Tcl_CreateExitHandler.3.*
+ rm -f Tcl_DeleteExitHandler.3 Tcl_DeleteExitHandler.3.*
+ rm -f Tcl_ExitThread.3 Tcl_ExitThread.3.*
+ rm -f Tcl_FinalizeThread.3 Tcl_FinalizeThread.3.*
+ rm -f Tcl_CreateThreadExitHandler.3 Tcl_CreateThreadExitHandler.3.*
+ rm -f Tcl_DeleteThreadExitHandler.3 Tcl_DeleteThreadExitHandler.3.*
+ ln $S Exit.3$Z Tcl_Exit.3$Z
+ ln $S Exit.3$Z Tcl_Finalize.3$Z
+ ln $S Exit.3$Z Tcl_CreateExitHandler.3$Z
+ ln $S Exit.3$Z Tcl_DeleteExitHandler.3$Z
+ ln $S Exit.3$Z Tcl_ExitThread.3$Z
+ ln $S Exit.3$Z Tcl_FinalizeThread.3$Z
+ ln $S Exit.3$Z Tcl_CreateThreadExitHandler.3$Z
+ ln $S Exit.3$Z Tcl_DeleteThreadExitHandler.3$Z
fi
if test -r ExprLong.3; then
- rm -f Tcl_ExprLong.3
- rm -f Tcl_ExprDouble.3
- rm -f Tcl_ExprBoolean.3
- rm -f Tcl_ExprString.3
- cp ExprLong.3 Tcl_ExprLong.3
- cp ExprLong.3 Tcl_ExprDouble.3
- cp ExprLong.3 Tcl_ExprBoolean.3
- cp ExprLong.3 Tcl_ExprString.3
+ rm -f ExprLong.3.*
+ $ZIP ExprLong.3
+ rm -f Tcl_ExprLong.3 Tcl_ExprLong.3.*
+ rm -f Tcl_ExprDouble.3 Tcl_ExprDouble.3.*
+ rm -f Tcl_ExprBoolean.3 Tcl_ExprBoolean.3.*
+ rm -f Tcl_ExprString.3 Tcl_ExprString.3.*
+ ln $S ExprLong.3$Z Tcl_ExprLong.3$Z
+ ln $S ExprLong.3$Z Tcl_ExprDouble.3$Z
+ ln $S ExprLong.3$Z Tcl_ExprBoolean.3$Z
+ ln $S ExprLong.3$Z Tcl_ExprString.3$Z
fi
if test -r ExprLongObj.3; then
- rm -f Tcl_ExprLongObj.3
- rm -f Tcl_ExprDoubleObj.3
- rm -f Tcl_ExprBooleanObj.3
- rm -f Tcl_ExprObj.3
- cp ExprLongObj.3 Tcl_ExprLongObj.3
- cp ExprLongObj.3 Tcl_ExprDoubleObj.3
- cp ExprLongObj.3 Tcl_ExprBooleanObj.3
- cp ExprLongObj.3 Tcl_ExprObj.3
+ rm -f ExprLongObj.3.*
+ $ZIP ExprLongObj.3
+ rm -f Tcl_ExprLongObj.3 Tcl_ExprLongObj.3.*
+ rm -f Tcl_ExprDoubleObj.3 Tcl_ExprDoubleObj.3.*
+ rm -f Tcl_ExprBooleanObj.3 Tcl_ExprBooleanObj.3.*
+ rm -f Tcl_ExprObj.3 Tcl_ExprObj.3.*
+ ln $S ExprLongObj.3$Z Tcl_ExprLongObj.3$Z
+ ln $S ExprLongObj.3$Z Tcl_ExprDoubleObj.3$Z
+ ln $S ExprLongObj.3$Z Tcl_ExprBooleanObj.3$Z
+ ln $S ExprLongObj.3$Z Tcl_ExprObj.3$Z
+fi
+if test -r FileSystem.3; then
+ rm -f FileSystem.3.*
+ $ZIP FileSystem.3
+ rm -f Tcl_FSRegister.3 Tcl_FSRegister.3.*
+ rm -f Tcl_FSUnregister.3 Tcl_FSUnregister.3.*
+ rm -f Tcl_FSData.3 Tcl_FSData.3.*
+ rm -f Tcl_FSMountsChanged.3 Tcl_FSMountsChanged.3.*
+ rm -f Tcl_FSGetFileSystemForPath.3 Tcl_FSGetFileSystemForPath.3.*
+ rm -f Tcl_FSGetPathType.3 Tcl_FSGetPathType.3.*
+ rm -f Tcl_FSCopyFile.3 Tcl_FSCopyFile.3.*
+ rm -f Tcl_FSCopyDirectory.3 Tcl_FSCopyDirectory.3.*
+ rm -f Tcl_FSCreateDirectory.3 Tcl_FSCreateDirectory.3.*
+ rm -f Tcl_FSDeleteFile.3 Tcl_FSDeleteFile.3.*
+ rm -f Tcl_FSRemoveDirectory.3 Tcl_FSRemoveDirectory.3.*
+ rm -f Tcl_FSRenameFile.3 Tcl_FSRenameFile.3.*
+ rm -f Tcl_FSListVolumes.3 Tcl_FSListVolumes.3.*
+ rm -f Tcl_FSEvalFile.3 Tcl_FSEvalFile.3.*
+ rm -f Tcl_FSLoadFile.3 Tcl_FSLoadFile.3.*
+ rm -f Tcl_FSMatchInDirectory.3 Tcl_FSMatchInDirectory.3.*
+ rm -f Tcl_FSLink.3 Tcl_FSLink.3.*
+ rm -f Tcl_FSLstat.3 Tcl_FSLstat.3.*
+ rm -f Tcl_FSUtime.3 Tcl_FSUtime.3.*
+ rm -f Tcl_FSFileAttrsGet.3 Tcl_FSFileAttrsGet.3.*
+ rm -f Tcl_FSFileAttrsSet.3 Tcl_FSFileAttrsSet.3.*
+ rm -f Tcl_FSFileAttrStrings.3 Tcl_FSFileAttrStrings.3.*
+ rm -f Tcl_FSStat.3 Tcl_FSStat.3.*
+ rm -f Tcl_FSAccess.3 Tcl_FSAccess.3.*
+ rm -f Tcl_FSOpenFileChannel.3 Tcl_FSOpenFileChannel.3.*
+ rm -f Tcl_FSGetCwd.3 Tcl_FSGetCwd.3.*
+ rm -f Tcl_FSChdir.3 Tcl_FSChdir.3.*
+ rm -f Tcl_FSPathSeparator.3 Tcl_FSPathSeparator.3.*
+ rm -f Tcl_FSJoinPath.3 Tcl_FSJoinPath.3.*
+ rm -f Tcl_FSSplitPath.3 Tcl_FSSplitPath.3.*
+ rm -f Tcl_FSEqualPaths.3 Tcl_FSEqualPaths.3.*
+ rm -f Tcl_FSGetNormalizedPath.3 Tcl_FSGetNormalizedPath.3.*
+ rm -f Tcl_FSJoinToPath.3 Tcl_FSJoinToPath.3.*
+ rm -f Tcl_FSConvertToPathType.3 Tcl_FSConvertToPathType.3.*
+ rm -f Tcl_FSGetInternalRep.3 Tcl_FSGetInternalRep.3.*
+ rm -f Tcl_FSGetTranslatedPath.3 Tcl_FSGetTranslatedPath.3.*
+ rm -f Tcl_FSGetTranslatedStringPath.3 Tcl_FSGetTranslatedStringPath.3.*
+ rm -f Tcl_FSNewNativePath.3 Tcl_FSNewNativePath.3.*
+ rm -f Tcl_FSGetNativePath.3 Tcl_FSGetNativePath.3.*
+ rm -f Tcl_FSFileSystemInfo.3 Tcl_FSFileSystemInfo.3.*
+ rm -f Tcl_AllocStatBuf.3 Tcl_AllocStatBuf.3.*
+ ln $S FileSystem.3$Z Tcl_FSRegister.3$Z
+ ln $S FileSystem.3$Z Tcl_FSUnregister.3$Z
+ ln $S FileSystem.3$Z Tcl_FSData.3$Z
+ ln $S FileSystem.3$Z Tcl_FSMountsChanged.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetFileSystemForPath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetPathType.3$Z
+ ln $S FileSystem.3$Z Tcl_FSCopyFile.3$Z
+ ln $S FileSystem.3$Z Tcl_FSCopyDirectory.3$Z
+ ln $S FileSystem.3$Z Tcl_FSCreateDirectory.3$Z
+ ln $S FileSystem.3$Z Tcl_FSDeleteFile.3$Z
+ ln $S FileSystem.3$Z Tcl_FSRemoveDirectory.3$Z
+ ln $S FileSystem.3$Z Tcl_FSRenameFile.3$Z
+ ln $S FileSystem.3$Z Tcl_FSListVolumes.3$Z
+ ln $S FileSystem.3$Z Tcl_FSEvalFile.3$Z
+ ln $S FileSystem.3$Z Tcl_FSLoadFile.3$Z
+ ln $S FileSystem.3$Z Tcl_FSMatchInDirectory.3$Z
+ ln $S FileSystem.3$Z Tcl_FSLink.3$Z
+ ln $S FileSystem.3$Z Tcl_FSLstat.3$Z
+ ln $S FileSystem.3$Z Tcl_FSUtime.3$Z
+ ln $S FileSystem.3$Z Tcl_FSFileAttrsGet.3$Z
+ ln $S FileSystem.3$Z Tcl_FSFileAttrsSet.3$Z
+ ln $S FileSystem.3$Z Tcl_FSFileAttrStrings.3$Z
+ ln $S FileSystem.3$Z Tcl_FSStat.3$Z
+ ln $S FileSystem.3$Z Tcl_FSAccess.3$Z
+ ln $S FileSystem.3$Z Tcl_FSOpenFileChannel.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetCwd.3$Z
+ ln $S FileSystem.3$Z Tcl_FSChdir.3$Z
+ ln $S FileSystem.3$Z Tcl_FSPathSeparator.3$Z
+ ln $S FileSystem.3$Z Tcl_FSJoinPath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSSplitPath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSEqualPaths.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetNormalizedPath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSJoinToPath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSConvertToPathType.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetInternalRep.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetTranslatedPath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetTranslatedStringPath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSNewNativePath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSGetNativePath.3$Z
+ ln $S FileSystem.3$Z Tcl_FSFileSystemInfo.3$Z
+ ln $S FileSystem.3$Z Tcl_AllocStatBuf.3$Z
fi
if test -r FindExec.3; then
- rm -f Tcl_FindExecutable.3
- rm -f Tcl_GetNameOfExecutable.3
- cp FindExec.3 Tcl_FindExecutable.3
- cp FindExec.3 Tcl_GetNameOfExecutable.3
+ rm -f FindExec.3.*
+ $ZIP FindExec.3
+ rm -f Tcl_FindExecutable.3 Tcl_FindExecutable.3.*
+ rm -f Tcl_GetNameOfExecutable.3 Tcl_GetNameOfExecutable.3.*
+ ln $S FindExec.3$Z Tcl_FindExecutable.3$Z
+ ln $S FindExec.3$Z Tcl_GetNameOfExecutable.3$Z
fi
if test -r GetCwd.3; then
- rm -f Tcl_GetCwd.3
- rm -f Tcl_Chdir.3
- cp GetCwd.3 Tcl_GetCwd.3
- cp GetCwd.3 Tcl_Chdir.3
+ rm -f GetCwd.3.*
+ $ZIP GetCwd.3
+ rm -f Tcl_GetCwd.3 Tcl_GetCwd.3.*
+ rm -f Tcl_Chdir.3 Tcl_Chdir.3.*
+ ln $S GetCwd.3$Z Tcl_GetCwd.3$Z
+ ln $S GetCwd.3$Z Tcl_Chdir.3$Z
fi
if test -r GetHostName.3; then
- rm -f Tcl_GetHostName.3
- cp GetHostName.3 Tcl_GetHostName.3
+ rm -f GetHostName.3.*
+ $ZIP GetHostName.3
+ rm -f Tcl_GetHostName.3 Tcl_GetHostName.3.*
+ ln $S GetHostName.3$Z Tcl_GetHostName.3$Z
fi
if test -r GetIndex.3; then
- rm -f Tcl_GetIndexFromObj.3
- rm -f Tcl_GetIndexFromObjStruct.3
- cp GetIndex.3 Tcl_GetIndexFromObj.3
- cp GetIndex.3 Tcl_GetIndexFromObjStruct.3
+ rm -f GetIndex.3.*
+ $ZIP GetIndex.3
+ rm -f Tcl_GetIndexFromObj.3 Tcl_GetIndexFromObj.3.*
+ rm -f Tcl_GetIndexFromObjStruct.3 Tcl_GetIndexFromObjStruct.3.*
+ ln $S GetIndex.3$Z Tcl_GetIndexFromObj.3$Z
+ ln $S GetIndex.3$Z Tcl_GetIndexFromObjStruct.3$Z
fi
if test -r GetInt.3; then
- rm -f Tcl_GetInt.3
- rm -f Tcl_GetDouble.3
- rm -f Tcl_GetBoolean.3
- cp GetInt.3 Tcl_GetInt.3
- cp GetInt.3 Tcl_GetDouble.3
- cp GetInt.3 Tcl_GetBoolean.3
+ rm -f GetInt.3.*
+ $ZIP GetInt.3
+ rm -f Tcl_GetInt.3 Tcl_GetInt.3.*
+ rm -f Tcl_GetDouble.3 Tcl_GetDouble.3.*
+ rm -f Tcl_GetBoolean.3 Tcl_GetBoolean.3.*
+ ln $S GetInt.3$Z Tcl_GetInt.3$Z
+ ln $S GetInt.3$Z Tcl_GetDouble.3$Z
+ ln $S GetInt.3$Z Tcl_GetBoolean.3$Z
fi
if test -r GetOpnFl.3; then
- rm -f Tcl_GetOpenFile.3
- cp GetOpnFl.3 Tcl_GetOpenFile.3
+ rm -f GetOpnFl.3.*
+ $ZIP GetOpnFl.3
+ rm -f Tcl_GetOpenFile.3 Tcl_GetOpenFile.3.*
+ ln $S GetOpnFl.3$Z Tcl_GetOpenFile.3$Z
fi
if test -r GetStdChan.3; then
- rm -f Tcl_GetStdChannel.3
- rm -f Tcl_SetStdChannel.3
- cp GetStdChan.3 Tcl_GetStdChannel.3
- cp GetStdChan.3 Tcl_SetStdChannel.3
+ rm -f GetStdChan.3.*
+ $ZIP GetStdChan.3
+ rm -f Tcl_GetStdChannel.3 Tcl_GetStdChannel.3.*
+ rm -f Tcl_SetStdChannel.3 Tcl_SetStdChannel.3.*
+ ln $S GetStdChan.3$Z Tcl_GetStdChannel.3$Z
+ ln $S GetStdChan.3$Z Tcl_SetStdChannel.3$Z
+fi
+if test -r GetTime.3; then
+ rm -f GetTime.3.*
+ $ZIP GetTime.3
+ rm -f Tcl_GetTime.3 Tcl_GetTime.3.*
+ ln $S GetTime.3$Z Tcl_GetTime.3$Z
fi
if test -r GetVersion.3; then
- rm -f Tcl_GetVersion.3
- cp GetVersion.3 Tcl_GetVersion.3
+ rm -f GetVersion.3.*
+ $ZIP GetVersion.3
+ rm -f Tcl_GetVersion.3 Tcl_GetVersion.3.*
+ ln $S GetVersion.3$Z Tcl_GetVersion.3$Z
fi
if test -r Hash.3; then
- rm -f Tcl_InitHashTable.3
- rm -f Tcl_DeleteHashTable.3
- rm -f Tcl_CreateHashEntry.3
- rm -f Tcl_DeleteHashEntry.3
- rm -f Tcl_FindHashEntry.3
- rm -f Tcl_GetHashValue.3
- rm -f Tcl_SetHashValue.3
- rm -f Tcl_GetHashKey.3
- rm -f Tcl_FirstHashEntry.3
- rm -f Tcl_NextHashEntry.3
- rm -f Tcl_HashStats.3
- cp Hash.3 Tcl_InitHashTable.3
- cp Hash.3 Tcl_DeleteHashTable.3
- cp Hash.3 Tcl_CreateHashEntry.3
- cp Hash.3 Tcl_DeleteHashEntry.3
- cp Hash.3 Tcl_FindHashEntry.3
- cp Hash.3 Tcl_GetHashValue.3
- cp Hash.3 Tcl_SetHashValue.3
- cp Hash.3 Tcl_GetHashKey.3
- cp Hash.3 Tcl_FirstHashEntry.3
- cp Hash.3 Tcl_NextHashEntry.3
- cp Hash.3 Tcl_HashStats.3
+ rm -f Hash.3.*
+ $ZIP Hash.3
+ rm -f Tcl_InitHashTable.3 Tcl_InitHashTable.3.*
+ rm -f Tcl_InitCustomHashTable.3 Tcl_InitCustomHashTable.3.*
+ rm -f Tcl_InitObjHashTable.3 Tcl_InitObjHashTable.3.*
+ rm -f Tcl_DeleteHashTable.3 Tcl_DeleteHashTable.3.*
+ rm -f Tcl_CreateHashEntry.3 Tcl_CreateHashEntry.3.*
+ rm -f Tcl_DeleteHashEntry.3 Tcl_DeleteHashEntry.3.*
+ rm -f Tcl_FindHashEntry.3 Tcl_FindHashEntry.3.*
+ rm -f Tcl_GetHashValue.3 Tcl_GetHashValue.3.*
+ rm -f Tcl_SetHashValue.3 Tcl_SetHashValue.3.*
+ rm -f Tcl_GetHashKey.3 Tcl_GetHashKey.3.*
+ rm -f Tcl_FirstHashEntry.3 Tcl_FirstHashEntry.3.*
+ rm -f Tcl_NextHashEntry.3 Tcl_NextHashEntry.3.*
+ rm -f Tcl_HashStats.3 Tcl_HashStats.3.*
+ ln $S Hash.3$Z Tcl_InitHashTable.3$Z
+ ln $S Hash.3$Z Tcl_InitCustomHashTable.3$Z
+ ln $S Hash.3$Z Tcl_InitObjHashTable.3$Z
+ ln $S Hash.3$Z Tcl_DeleteHashTable.3$Z
+ ln $S Hash.3$Z Tcl_CreateHashEntry.3$Z
+ ln $S Hash.3$Z Tcl_DeleteHashEntry.3$Z
+ ln $S Hash.3$Z Tcl_FindHashEntry.3$Z
+ ln $S Hash.3$Z Tcl_GetHashValue.3$Z
+ ln $S Hash.3$Z Tcl_SetHashValue.3$Z
+ ln $S Hash.3$Z Tcl_GetHashKey.3$Z
+ ln $S Hash.3$Z Tcl_FirstHashEntry.3$Z
+ ln $S Hash.3$Z Tcl_NextHashEntry.3$Z
+ ln $S Hash.3$Z Tcl_HashStats.3$Z
fi
if test -r Init.3; then
- rm -f Tcl_Init.3
- cp Init.3 Tcl_Init.3
+ rm -f Init.3.*
+ $ZIP Init.3
+ rm -f Tcl_Init.3 Tcl_Init.3.*
+ ln $S Init.3$Z Tcl_Init.3$Z
fi
if test -r InitStubs.3; then
- rm -f Tcl_InitStubs.3
- cp InitStubs.3 Tcl_InitStubs.3
+ rm -f InitStubs.3.*
+ $ZIP InitStubs.3
+ rm -f Tcl_InitStubs.3 Tcl_InitStubs.3.*
+ ln $S InitStubs.3$Z Tcl_InitStubs.3$Z
fi
if test -r IntObj.3; then
- rm -f Tcl_NewIntObj.3
- rm -f Tcl_NewLongObj.3
- rm -f Tcl_SetIntObj.3
- rm -f Tcl_SetLongObj.3
- rm -f Tcl_GetIntFromObj.3
- rm -f Tcl_GetLongFromObj.3
- cp IntObj.3 Tcl_NewIntObj.3
- cp IntObj.3 Tcl_NewLongObj.3
- cp IntObj.3 Tcl_SetIntObj.3
- cp IntObj.3 Tcl_SetLongObj.3
- cp IntObj.3 Tcl_GetIntFromObj.3
- cp IntObj.3 Tcl_GetLongFromObj.3
+ rm -f IntObj.3.*
+ $ZIP IntObj.3
+ rm -f Tcl_NewIntObj.3 Tcl_NewIntObj.3.*
+ rm -f Tcl_NewLongObj.3 Tcl_NewLongObj.3.*
+ rm -f Tcl_NewWideIntObj.3 Tcl_NewWideIntObj.3.*
+ rm -f Tcl_SetIntObj.3 Tcl_SetIntObj.3.*
+ rm -f Tcl_SetLongObj.3 Tcl_SetLongObj.3.*
+ rm -f Tcl_SetWideIntObj.3 Tcl_SetWideIntObj.3.*
+ rm -f Tcl_GetIntFromObj.3 Tcl_GetIntFromObj.3.*
+ rm -f Tcl_GetLongFromObj.3 Tcl_GetLongFromObj.3.*
+ rm -f Tcl_GetWideIntFromObj.3 Tcl_GetWideIntFromObj.3.*
+ ln $S IntObj.3$Z Tcl_NewIntObj.3$Z
+ ln $S IntObj.3$Z Tcl_NewLongObj.3$Z
+ ln $S IntObj.3$Z Tcl_NewWideIntObj.3$Z
+ ln $S IntObj.3$Z Tcl_SetIntObj.3$Z
+ ln $S IntObj.3$Z Tcl_SetLongObj.3$Z
+ ln $S IntObj.3$Z Tcl_SetWideIntObj.3$Z
+ ln $S IntObj.3$Z Tcl_GetIntFromObj.3$Z
+ ln $S IntObj.3$Z Tcl_GetLongFromObj.3$Z
+ ln $S IntObj.3$Z Tcl_GetWideIntFromObj.3$Z
fi
if test -r Interp.3; then
- rm -f Tcl_Interp.3
- cp Interp.3 Tcl_Interp.3
+ rm -f Interp.3.*
+ $ZIP Interp.3
+ rm -f Tcl_Interp.3 Tcl_Interp.3.*
+ ln $S Interp.3$Z Tcl_Interp.3$Z
fi
if test -r LinkVar.3; then
- rm -f Tcl_LinkVar.3
- rm -f Tcl_UnlinkVar.3
- rm -f Tcl_UpdateLinkedVar.3
- cp LinkVar.3 Tcl_LinkVar.3
- cp LinkVar.3 Tcl_UnlinkVar.3
- cp LinkVar.3 Tcl_UpdateLinkedVar.3
+ rm -f LinkVar.3.*
+ $ZIP LinkVar.3
+ rm -f Tcl_LinkVar.3 Tcl_LinkVar.3.*
+ rm -f Tcl_UnlinkVar.3 Tcl_UnlinkVar.3.*
+ rm -f Tcl_UpdateLinkedVar.3 Tcl_UpdateLinkedVar.3.*
+ ln $S LinkVar.3$Z Tcl_LinkVar.3$Z
+ ln $S LinkVar.3$Z Tcl_UnlinkVar.3$Z
+ ln $S LinkVar.3$Z Tcl_UpdateLinkedVar.3$Z
fi
if test -r ListObj.3; then
- rm -f Tcl_ListObjAppendList.3
- rm -f Tcl_ListObjAppendElement.3
- rm -f Tcl_NewListObj.3
- rm -f Tcl_SetListObj.3
- rm -f Tcl_ListObjGetElements.3
- rm -f Tcl_ListObjLength.3
- rm -f Tcl_ListObjIndex.3
- rm -f Tcl_ListObjReplace.3
- cp ListObj.3 Tcl_ListObjAppendList.3
- cp ListObj.3 Tcl_ListObjAppendElement.3
- cp ListObj.3 Tcl_NewListObj.3
- cp ListObj.3 Tcl_SetListObj.3
- cp ListObj.3 Tcl_ListObjGetElements.3
- cp ListObj.3 Tcl_ListObjLength.3
- cp ListObj.3 Tcl_ListObjIndex.3
- cp ListObj.3 Tcl_ListObjReplace.3
+ rm -f ListObj.3.*
+ $ZIP ListObj.3
+ rm -f Tcl_ListObjAppendList.3 Tcl_ListObjAppendList.3.*
+ rm -f Tcl_ListObjAppendElement.3 Tcl_ListObjAppendElement.3.*
+ rm -f Tcl_NewListObj.3 Tcl_NewListObj.3.*
+ rm -f Tcl_SetListObj.3 Tcl_SetListObj.3.*
+ rm -f Tcl_ListObjGetElements.3 Tcl_ListObjGetElements.3.*
+ rm -f Tcl_ListObjLength.3 Tcl_ListObjLength.3.*
+ rm -f Tcl_ListObjIndex.3 Tcl_ListObjIndex.3.*
+ rm -f Tcl_ListObjReplace.3 Tcl_ListObjReplace.3.*
+ ln $S ListObj.3$Z Tcl_ListObjAppendList.3$Z
+ ln $S ListObj.3$Z Tcl_ListObjAppendElement.3$Z
+ ln $S ListObj.3$Z Tcl_NewListObj.3$Z
+ ln $S ListObj.3$Z Tcl_SetListObj.3$Z
+ ln $S ListObj.3$Z Tcl_ListObjGetElements.3$Z
+ ln $S ListObj.3$Z Tcl_ListObjLength.3$Z
+ ln $S ListObj.3$Z Tcl_ListObjIndex.3$Z
+ ln $S ListObj.3$Z Tcl_ListObjReplace.3$Z
+fi
+if test -r Macintosh.3; then
+ rm -f Macintosh.3.*
+ $ZIP Macintosh.3
+ rm -f Tcl_MacSetEventProc.3 Tcl_MacSetEventProc.3.*
+ rm -f Tcl_MacConvertTextResource.3 Tcl_MacConvertTextResource.3.*
+ rm -f Tcl_MacEvalResource.3 Tcl_MacEvalResource.3.*
+ rm -f Tcl_MacFindResource.3 Tcl_MacFindResource.3.*
+ rm -f Tcl_GetOSTypeFromObj.3 Tcl_GetOSTypeFromObj.3.*
+ rm -f Tcl_SetOSTypeObj.3 Tcl_SetOSTypeObj.3.*
+ rm -f Tcl_NewOSTypeObj.3 Tcl_NewOSTypeObj.3.*
+ ln $S Macintosh.3$Z Tcl_MacSetEventProc.3$Z
+ ln $S Macintosh.3$Z Tcl_MacConvertTextResource.3$Z
+ ln $S Macintosh.3$Z Tcl_MacEvalResource.3$Z
+ ln $S Macintosh.3$Z Tcl_MacFindResource.3$Z
+ ln $S Macintosh.3$Z Tcl_GetOSTypeFromObj.3$Z
+ ln $S Macintosh.3$Z Tcl_SetOSTypeObj.3$Z
+ ln $S Macintosh.3$Z Tcl_NewOSTypeObj.3$Z
fi
if test -r Notifier.3; then
- rm -f Tcl_CreateEventSource.3
- rm -f Tcl_DeleteEventSource.3
- rm -f Tcl_SetMaxBlockTime.3
- rm -f Tcl_QueueEvent.3
- rm -f Tcl_ThreadQueueEvent.3
- rm -f Tcl_ThreadAlert.3
- rm -f Tcl_GetCurrentThread.3
- rm -f Tcl_DeleteEvents.3
- rm -f Tcl_InitNotifier.3
- rm -f Tcl_FinalizeNotifier.3
- rm -f Tcl_WaitForEvent.3
- rm -f Tcl_AlertNotifier.3
- rm -f Tcl_SetTimer.3
- rm -f Tcl_ServiceAll.3
- rm -f Tcl_ServiceEvent.3
- rm -f Tcl_GetServiceMode.3
- rm -f Tcl_SetServiceMode.3
- cp Notifier.3 Tcl_CreateEventSource.3
- cp Notifier.3 Tcl_DeleteEventSource.3
- cp Notifier.3 Tcl_SetMaxBlockTime.3
- cp Notifier.3 Tcl_QueueEvent.3
- cp Notifier.3 Tcl_ThreadQueueEvent.3
- cp Notifier.3 Tcl_ThreadAlert.3
- cp Notifier.3 Tcl_GetCurrentThread.3
- cp Notifier.3 Tcl_DeleteEvents.3
- cp Notifier.3 Tcl_InitNotifier.3
- cp Notifier.3 Tcl_FinalizeNotifier.3
- cp Notifier.3 Tcl_WaitForEvent.3
- cp Notifier.3 Tcl_AlertNotifier.3
- cp Notifier.3 Tcl_SetTimer.3
- cp Notifier.3 Tcl_ServiceAll.3
- cp Notifier.3 Tcl_ServiceEvent.3
- cp Notifier.3 Tcl_GetServiceMode.3
- cp Notifier.3 Tcl_SetServiceMode.3
+ rm -f Notifier.3.*
+ $ZIP Notifier.3
+ rm -f Tcl_CreateEventSource.3 Tcl_CreateEventSource.3.*
+ rm -f Tcl_DeleteEventSource.3 Tcl_DeleteEventSource.3.*
+ rm -f Tcl_SetMaxBlockTime.3 Tcl_SetMaxBlockTime.3.*
+ rm -f Tcl_QueueEvent.3 Tcl_QueueEvent.3.*
+ rm -f Tcl_ThreadQueueEvent.3 Tcl_ThreadQueueEvent.3.*
+ rm -f Tcl_ThreadAlert.3 Tcl_ThreadAlert.3.*
+ rm -f Tcl_GetCurrentThread.3 Tcl_GetCurrentThread.3.*
+ rm -f Tcl_DeleteEvents.3 Tcl_DeleteEvents.3.*
+ rm -f Tcl_InitNotifier.3 Tcl_InitNotifier.3.*
+ rm -f Tcl_FinalizeNotifier.3 Tcl_FinalizeNotifier.3.*
+ rm -f Tcl_WaitForEvent.3 Tcl_WaitForEvent.3.*
+ rm -f Tcl_AlertNotifier.3 Tcl_AlertNotifier.3.*
+ rm -f Tcl_SetTimer.3 Tcl_SetTimer.3.*
+ rm -f Tcl_ServiceAll.3 Tcl_ServiceAll.3.*
+ rm -f Tcl_ServiceEvent.3 Tcl_ServiceEvent.3.*
+ rm -f Tcl_GetServiceMode.3 Tcl_GetServiceMode.3.*
+ rm -f Tcl_SetServiceMode.3 Tcl_SetServiceMode.3.*
+ ln $S Notifier.3$Z Tcl_CreateEventSource.3$Z
+ ln $S Notifier.3$Z Tcl_DeleteEventSource.3$Z
+ ln $S Notifier.3$Z Tcl_SetMaxBlockTime.3$Z
+ ln $S Notifier.3$Z Tcl_QueueEvent.3$Z
+ ln $S Notifier.3$Z Tcl_ThreadQueueEvent.3$Z
+ ln $S Notifier.3$Z Tcl_ThreadAlert.3$Z
+ ln $S Notifier.3$Z Tcl_GetCurrentThread.3$Z
+ ln $S Notifier.3$Z Tcl_DeleteEvents.3$Z
+ ln $S Notifier.3$Z Tcl_InitNotifier.3$Z
+ ln $S Notifier.3$Z Tcl_FinalizeNotifier.3$Z
+ ln $S Notifier.3$Z Tcl_WaitForEvent.3$Z
+ ln $S Notifier.3$Z Tcl_AlertNotifier.3$Z
+ ln $S Notifier.3$Z Tcl_SetTimer.3$Z
+ ln $S Notifier.3$Z Tcl_ServiceAll.3$Z
+ ln $S Notifier.3$Z Tcl_ServiceEvent.3$Z
+ ln $S Notifier.3$Z Tcl_GetServiceMode.3$Z
+ ln $S Notifier.3$Z Tcl_SetServiceMode.3$Z
fi
if test -r Object.3; then
- rm -f Tcl_NewObj.3
- rm -f Tcl_DuplicateObj.3
- rm -f Tcl_IncrRefCount.3
- rm -f Tcl_DecrRefCount.3
- rm -f Tcl_IsShared.3
- rm -f Tcl_InvalidateStringRep.3
- cp Object.3 Tcl_NewObj.3
- cp Object.3 Tcl_DuplicateObj.3
- cp Object.3 Tcl_IncrRefCount.3
- cp Object.3 Tcl_DecrRefCount.3
- cp Object.3 Tcl_IsShared.3
- cp Object.3 Tcl_InvalidateStringRep.3
+ rm -f Object.3.*
+ $ZIP Object.3
+ rm -f Tcl_NewObj.3 Tcl_NewObj.3.*
+ rm -f Tcl_DuplicateObj.3 Tcl_DuplicateObj.3.*
+ rm -f Tcl_IncrRefCount.3 Tcl_IncrRefCount.3.*
+ rm -f Tcl_DecrRefCount.3 Tcl_DecrRefCount.3.*
+ rm -f Tcl_IsShared.3 Tcl_IsShared.3.*
+ rm -f Tcl_InvalidateStringRep.3 Tcl_InvalidateStringRep.3.*
+ ln $S Object.3$Z Tcl_NewObj.3$Z
+ ln $S Object.3$Z Tcl_DuplicateObj.3$Z
+ ln $S Object.3$Z Tcl_IncrRefCount.3$Z
+ ln $S Object.3$Z Tcl_DecrRefCount.3$Z
+ ln $S Object.3$Z Tcl_IsShared.3$Z
+ ln $S Object.3$Z Tcl_InvalidateStringRep.3$Z
fi
if test -r ObjectType.3; then
- rm -f Tcl_RegisterObjType.3
- rm -f Tcl_GetObjType.3
- rm -f Tcl_AppendAllObjTypes.3
- rm -f Tcl_ConvertToType.3
- cp ObjectType.3 Tcl_RegisterObjType.3
- cp ObjectType.3 Tcl_GetObjType.3
- cp ObjectType.3 Tcl_AppendAllObjTypes.3
- cp ObjectType.3 Tcl_ConvertToType.3
+ rm -f ObjectType.3.*
+ $ZIP ObjectType.3
+ rm -f Tcl_RegisterObjType.3 Tcl_RegisterObjType.3.*
+ rm -f Tcl_GetObjType.3 Tcl_GetObjType.3.*
+ rm -f Tcl_AppendAllObjTypes.3 Tcl_AppendAllObjTypes.3.*
+ rm -f Tcl_ConvertToType.3 Tcl_ConvertToType.3.*
+ ln $S ObjectType.3$Z Tcl_RegisterObjType.3$Z
+ ln $S ObjectType.3$Z Tcl_GetObjType.3$Z
+ ln $S ObjectType.3$Z Tcl_AppendAllObjTypes.3$Z
+ ln $S ObjectType.3$Z Tcl_ConvertToType.3$Z
fi
if test -r OpenFileChnl.3; then
- rm -f Tcl_OpenFileChannel.3
- rm -f Tcl_OpenCommandChannel.3
- rm -f Tcl_MakeFileChannel.3
- rm -f Tcl_GetChannel.3
- rm -f Tcl_GetChannelNames.3
- rm -f Tcl_GetChannelNamesEx.3
- rm -f Tcl_RegisterChannel.3
- rm -f Tcl_UnregisterChannel.3
- rm -f Tcl_Close.3
- rm -f Tcl_ReadChars.3
- rm -f Tcl_Read.3
- rm -f Tcl_GetsObj.3
- rm -f Tcl_Gets.3
- rm -f Tcl_WriteObj.3
- rm -f Tcl_WriteChars.3
- rm -f Tcl_Write.3
- rm -f Tcl_Flush.3
- rm -f Tcl_Seek.3
- rm -f Tcl_Tell.3
- rm -f Tcl_GetChannelOption.3
- rm -f Tcl_SetChannelOption.3
- rm -f Tcl_Eof.3
- rm -f Tcl_InputBlocked.3
- rm -f Tcl_InputBuffered.3
- rm -f Tcl_Ungets.3
- cp OpenFileChnl.3 Tcl_OpenFileChannel.3
- cp OpenFileChnl.3 Tcl_OpenCommandChannel.3
- cp OpenFileChnl.3 Tcl_MakeFileChannel.3
- cp OpenFileChnl.3 Tcl_GetChannel.3
- cp OpenFileChnl.3 Tcl_GetChannelNames.3
- cp OpenFileChnl.3 Tcl_GetChannelNamesEx.3
- cp OpenFileChnl.3 Tcl_RegisterChannel.3
- cp OpenFileChnl.3 Tcl_UnregisterChannel.3
- cp OpenFileChnl.3 Tcl_Close.3
- cp OpenFileChnl.3 Tcl_ReadChars.3
- cp OpenFileChnl.3 Tcl_Read.3
- cp OpenFileChnl.3 Tcl_GetsObj.3
- cp OpenFileChnl.3 Tcl_Gets.3
- cp OpenFileChnl.3 Tcl_WriteObj.3
- cp OpenFileChnl.3 Tcl_WriteChars.3
- cp OpenFileChnl.3 Tcl_Write.3
- cp OpenFileChnl.3 Tcl_Flush.3
- cp OpenFileChnl.3 Tcl_Seek.3
- cp OpenFileChnl.3 Tcl_Tell.3
- cp OpenFileChnl.3 Tcl_GetChannelOption.3
- cp OpenFileChnl.3 Tcl_SetChannelOption.3
- cp OpenFileChnl.3 Tcl_Eof.3
- cp OpenFileChnl.3 Tcl_InputBlocked.3
- cp OpenFileChnl.3 Tcl_InputBuffered.3
- cp OpenFileChnl.3 Tcl_Ungets.3
+ rm -f OpenFileChnl.3.*
+ $ZIP OpenFileChnl.3
+ rm -f Tcl_OpenFileChannel.3 Tcl_OpenFileChannel.3.*
+ rm -f Tcl_OpenCommandChannel.3 Tcl_OpenCommandChannel.3.*
+ rm -f Tcl_MakeFileChannel.3 Tcl_MakeFileChannel.3.*
+ rm -f Tcl_GetChannel.3 Tcl_GetChannel.3.*
+ rm -f Tcl_GetChannelNames.3 Tcl_GetChannelNames.3.*
+ rm -f Tcl_GetChannelNamesEx.3 Tcl_GetChannelNamesEx.3.*
+ rm -f Tcl_RegisterChannel.3 Tcl_RegisterChannel.3.*
+ rm -f Tcl_UnregisterChannel.3 Tcl_UnregisterChannel.3.*
+ rm -f Tcl_DetachChannel.3 Tcl_DetachChannel.3.*
+ rm -f Tcl_IsStandardChannel.3 Tcl_IsStandardChannel.3.*
+ rm -f Tcl_Close.3 Tcl_Close.3.*
+ rm -f Tcl_ReadChars.3 Tcl_ReadChars.3.*
+ rm -f Tcl_Read.3 Tcl_Read.3.*
+ rm -f Tcl_GetsObj.3 Tcl_GetsObj.3.*
+ rm -f Tcl_Gets.3 Tcl_Gets.3.*
+ rm -f Tcl_WriteObj.3 Tcl_WriteObj.3.*
+ rm -f Tcl_WriteChars.3 Tcl_WriteChars.3.*
+ rm -f Tcl_Write.3 Tcl_Write.3.*
+ rm -f Tcl_Flush.3 Tcl_Flush.3.*
+ rm -f Tcl_Seek.3 Tcl_Seek.3.*
+ rm -f Tcl_Tell.3 Tcl_Tell.3.*
+ rm -f Tcl_GetChannelOption.3 Tcl_GetChannelOption.3.*
+ rm -f Tcl_SetChannelOption.3 Tcl_SetChannelOption.3.*
+ rm -f Tcl_Eof.3 Tcl_Eof.3.*
+ rm -f Tcl_InputBlocked.3 Tcl_InputBlocked.3.*
+ rm -f Tcl_InputBuffered.3 Tcl_InputBuffered.3.*
+ rm -f Tcl_OutputBuffered.3 Tcl_OutputBuffered.3.*
+ rm -f Tcl_Ungets.3 Tcl_Ungets.3.*
+ rm -f Tcl_ReadRaw.3 Tcl_ReadRaw.3.*
+ rm -f Tcl_WriteRaw.3 Tcl_WriteRaw.3.*
+ ln $S OpenFileChnl.3$Z Tcl_OpenFileChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_OpenCommandChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_MakeFileChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_GetChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_GetChannelNames.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_GetChannelNamesEx.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_RegisterChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_UnregisterChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_DetachChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_IsStandardChannel.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Close.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_ReadChars.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Read.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_GetsObj.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Gets.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_WriteObj.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_WriteChars.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Write.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Flush.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Seek.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Tell.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_GetChannelOption.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_SetChannelOption.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Eof.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_InputBlocked.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_InputBuffered.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_OutputBuffered.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_Ungets.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_ReadRaw.3$Z
+ ln $S OpenFileChnl.3$Z Tcl_WriteRaw.3$Z
fi
if test -r OpenTcp.3; then
- rm -f Tcl_OpenTcpClient.3
- rm -f Tcl_MakeTcpClientChannel.3
- rm -f Tcl_OpenTcpServer.3
- cp OpenTcp.3 Tcl_OpenTcpClient.3
- cp OpenTcp.3 Tcl_MakeTcpClientChannel.3
- cp OpenTcp.3 Tcl_OpenTcpServer.3
+ rm -f OpenTcp.3.*
+ $ZIP OpenTcp.3
+ rm -f Tcl_OpenTcpClient.3 Tcl_OpenTcpClient.3.*
+ rm -f Tcl_MakeTcpClientChannel.3 Tcl_MakeTcpClientChannel.3.*
+ rm -f Tcl_OpenTcpServer.3 Tcl_OpenTcpServer.3.*
+ ln $S OpenTcp.3$Z Tcl_OpenTcpClient.3$Z
+ ln $S OpenTcp.3$Z Tcl_MakeTcpClientChannel.3$Z
+ ln $S OpenTcp.3$Z Tcl_OpenTcpServer.3$Z
+fi
+if test -r Panic.3; then
+ rm -f Panic.3.*
+ $ZIP Panic.3
+ rm -f Tcl_Panic.3 Tcl_Panic.3.*
+ rm -f Tcl_PanicVA.3 Tcl_PanicVA.3.*
+ rm -f Tcl_SetPanicProc.3 Tcl_SetPanicProc.3.*
+ if test "${CASEINSENSITIVEFS:-}" != "1"; then rm -f panic.3 panic.3.* ; fi
+ rm -f panicVA.3 panicVA.3.*
+ ln $S Panic.3$Z Tcl_Panic.3$Z
+ ln $S Panic.3$Z Tcl_PanicVA.3$Z
+ ln $S Panic.3$Z Tcl_SetPanicProc.3$Z
+ if test "${CASEINSENSITIVEFS:-}" != "1"; then ln $S Panic.3$Z panic.3$Z ; fi
+ ln $S Panic.3$Z panicVA.3$Z
fi
if test -r ParseCmd.3; then
- rm -f Tcl_ParseCommand.3
- rm -f Tcl_ParseExpr.3
- rm -f Tcl_ParseBraces.3
- rm -f Tcl_ParseQuotedString.3
- rm -f Tcl_ParseVarName.3
- rm -f Tcl_ParseVar.3
- rm -f Tcl_FreeParse.3
- rm -f Tcl_EvalTokens.3
- cp ParseCmd.3 Tcl_ParseCommand.3
- cp ParseCmd.3 Tcl_ParseExpr.3
- cp ParseCmd.3 Tcl_ParseBraces.3
- cp ParseCmd.3 Tcl_ParseQuotedString.3
- cp ParseCmd.3 Tcl_ParseVarName.3
- cp ParseCmd.3 Tcl_ParseVar.3
- cp ParseCmd.3 Tcl_FreeParse.3
- cp ParseCmd.3 Tcl_EvalTokens.3
+ rm -f ParseCmd.3.*
+ $ZIP ParseCmd.3
+ rm -f Tcl_ParseCommand.3 Tcl_ParseCommand.3.*
+ rm -f Tcl_ParseExpr.3 Tcl_ParseExpr.3.*
+ rm -f Tcl_ParseBraces.3 Tcl_ParseBraces.3.*
+ rm -f Tcl_ParseQuotedString.3 Tcl_ParseQuotedString.3.*
+ rm -f Tcl_ParseVarName.3 Tcl_ParseVarName.3.*
+ rm -f Tcl_ParseVar.3 Tcl_ParseVar.3.*
+ rm -f Tcl_FreeParse.3 Tcl_FreeParse.3.*
+ rm -f Tcl_EvalTokens.3 Tcl_EvalTokens.3.*
+ rm -f Tcl_EvalTokensStandard.3 Tcl_EvalTokensStandard.3.*
+ ln $S ParseCmd.3$Z Tcl_ParseCommand.3$Z
+ ln $S ParseCmd.3$Z Tcl_ParseExpr.3$Z
+ ln $S ParseCmd.3$Z Tcl_ParseBraces.3$Z
+ ln $S ParseCmd.3$Z Tcl_ParseQuotedString.3$Z
+ ln $S ParseCmd.3$Z Tcl_ParseVarName.3$Z
+ ln $S ParseCmd.3$Z Tcl_ParseVar.3$Z
+ ln $S ParseCmd.3$Z Tcl_FreeParse.3$Z
+ ln $S ParseCmd.3$Z Tcl_EvalTokens.3$Z
+ ln $S ParseCmd.3$Z Tcl_EvalTokensStandard.3$Z
fi
if test -r PkgRequire.3; then
- rm -f Tcl_PkgRequire.3
- rm -f Tcl_PkgRequireEx.3
- rm -f Tcl_PkgPresent.3
- rm -f Tcl_PkgPresentEx.3
- rm -f Tcl_PkgProvide.3
- rm -f Tcl_PkgProvideEx.3
- cp PkgRequire.3 Tcl_PkgRequire.3
- cp PkgRequire.3 Tcl_PkgRequireEx.3
- cp PkgRequire.3 Tcl_PkgPresent.3
- cp PkgRequire.3 Tcl_PkgPresentEx.3
- cp PkgRequire.3 Tcl_PkgProvide.3
- cp PkgRequire.3 Tcl_PkgProvideEx.3
+ rm -f PkgRequire.3.*
+ $ZIP PkgRequire.3
+ rm -f Tcl_PkgRequire.3 Tcl_PkgRequire.3.*
+ rm -f Tcl_PkgRequireEx.3 Tcl_PkgRequireEx.3.*
+ rm -f Tcl_PkgPresent.3 Tcl_PkgPresent.3.*
+ rm -f Tcl_PkgPresentEx.3 Tcl_PkgPresentEx.3.*
+ rm -f Tcl_PkgProvide.3 Tcl_PkgProvide.3.*
+ rm -f Tcl_PkgProvideEx.3 Tcl_PkgProvideEx.3.*
+ ln $S PkgRequire.3$Z Tcl_PkgRequire.3$Z
+ ln $S PkgRequire.3$Z Tcl_PkgRequireEx.3$Z
+ ln $S PkgRequire.3$Z Tcl_PkgPresent.3$Z
+ ln $S PkgRequire.3$Z Tcl_PkgPresentEx.3$Z
+ ln $S PkgRequire.3$Z Tcl_PkgProvide.3$Z
+ ln $S PkgRequire.3$Z Tcl_PkgProvideEx.3$Z
fi
if test -r Preserve.3; then
- rm -f Tcl_Preserve.3
- rm -f Tcl_Release.3
- rm -f Tcl_EventuallyFree.3
- cp Preserve.3 Tcl_Preserve.3
- cp Preserve.3 Tcl_Release.3
- cp Preserve.3 Tcl_EventuallyFree.3
+ rm -f Preserve.3.*
+ $ZIP Preserve.3
+ rm -f Tcl_Preserve.3 Tcl_Preserve.3.*
+ rm -f Tcl_Release.3 Tcl_Release.3.*
+ rm -f Tcl_EventuallyFree.3 Tcl_EventuallyFree.3.*
+ ln $S Preserve.3$Z Tcl_Preserve.3$Z
+ ln $S Preserve.3$Z Tcl_Release.3$Z
+ ln $S Preserve.3$Z Tcl_EventuallyFree.3$Z
fi
if test -r PrintDbl.3; then
- rm -f Tcl_PrintDouble.3
- cp PrintDbl.3 Tcl_PrintDouble.3
+ rm -f PrintDbl.3.*
+ $ZIP PrintDbl.3
+ rm -f Tcl_PrintDouble.3 Tcl_PrintDouble.3.*
+ ln $S PrintDbl.3$Z Tcl_PrintDouble.3$Z
fi
if test -r RecEvalObj.3; then
- rm -f Tcl_RecordAndEvalObj.3
- cp RecEvalObj.3 Tcl_RecordAndEvalObj.3
+ rm -f RecEvalObj.3.*
+ $ZIP RecEvalObj.3
+ rm -f Tcl_RecordAndEvalObj.3 Tcl_RecordAndEvalObj.3.*
+ ln $S RecEvalObj.3$Z Tcl_RecordAndEvalObj.3$Z
fi
if test -r RecordEval.3; then
- rm -f Tcl_RecordAndEval.3
- cp RecordEval.3 Tcl_RecordAndEval.3
+ rm -f RecordEval.3.*
+ $ZIP RecordEval.3
+ rm -f Tcl_RecordAndEval.3 Tcl_RecordAndEval.3.*
+ ln $S RecordEval.3$Z Tcl_RecordAndEval.3$Z
fi
if test -r RegExp.3; then
- rm -f Tcl_RegExpMatch.3
- rm -f Tcl_RegExpCompile.3
- rm -f Tcl_RegExpExec.3
- rm -f Tcl_RegExpRange.3
- rm -f Tcl_GetRegExpFromObj.3
- rm -f Tcl_RegExpMatchObj.3
- rm -f Tcl_RegExpExecObj.3
- rm -f Tcl_RegExpGetInfo.3
- cp RegExp.3 Tcl_RegExpMatch.3
- cp RegExp.3 Tcl_RegExpCompile.3
- cp RegExp.3 Tcl_RegExpExec.3
- cp RegExp.3 Tcl_RegExpRange.3
- cp RegExp.3 Tcl_GetRegExpFromObj.3
- cp RegExp.3 Tcl_RegExpMatchObj.3
- cp RegExp.3 Tcl_RegExpExecObj.3
- cp RegExp.3 Tcl_RegExpGetInfo.3
+ rm -f RegExp.3.*
+ $ZIP RegExp.3
+ rm -f Tcl_RegExpMatch.3 Tcl_RegExpMatch.3.*
+ rm -f Tcl_RegExpCompile.3 Tcl_RegExpCompile.3.*
+ rm -f Tcl_RegExpExec.3 Tcl_RegExpExec.3.*
+ rm -f Tcl_RegExpRange.3 Tcl_RegExpRange.3.*
+ rm -f Tcl_GetRegExpFromObj.3 Tcl_GetRegExpFromObj.3.*
+ rm -f Tcl_RegExpMatchObj.3 Tcl_RegExpMatchObj.3.*
+ rm -f Tcl_RegExpExecObj.3 Tcl_RegExpExecObj.3.*
+ rm -f Tcl_RegExpGetInfo.3 Tcl_RegExpGetInfo.3.*
+ ln $S RegExp.3$Z Tcl_RegExpMatch.3$Z
+ ln $S RegExp.3$Z Tcl_RegExpCompile.3$Z
+ ln $S RegExp.3$Z Tcl_RegExpExec.3$Z
+ ln $S RegExp.3$Z Tcl_RegExpRange.3$Z
+ ln $S RegExp.3$Z Tcl_GetRegExpFromObj.3$Z
+ ln $S RegExp.3$Z Tcl_RegExpMatchObj.3$Z
+ ln $S RegExp.3$Z Tcl_RegExpExecObj.3$Z
+ ln $S RegExp.3$Z Tcl_RegExpGetInfo.3$Z
fi
if test -r SaveResult.3; then
- rm -f Tcl_SaveResult.3
- rm -f Tcl_RestoreResult.3
- rm -f Tcl_DiscardResult.3
- cp SaveResult.3 Tcl_SaveResult.3
- cp SaveResult.3 Tcl_RestoreResult.3
- cp SaveResult.3 Tcl_DiscardResult.3
+ rm -f SaveResult.3.*
+ $ZIP SaveResult.3
+ rm -f Tcl_SaveResult.3 Tcl_SaveResult.3.*
+ rm -f Tcl_RestoreResult.3 Tcl_RestoreResult.3.*
+ rm -f Tcl_DiscardResult.3 Tcl_DiscardResult.3.*
+ ln $S SaveResult.3$Z Tcl_SaveResult.3$Z
+ ln $S SaveResult.3$Z Tcl_RestoreResult.3$Z
+ ln $S SaveResult.3$Z Tcl_DiscardResult.3$Z
fi
if test -r SetErrno.3; then
- rm -f Tcl_SetErrno.3
- rm -f Tcl_GetErrno.3
- rm -f Tcl_ErrnoId.3
- rm -f Tcl_ErrnoMsg.3
- cp SetErrno.3 Tcl_SetErrno.3
- cp SetErrno.3 Tcl_GetErrno.3
- cp SetErrno.3 Tcl_ErrnoId.3
- cp SetErrno.3 Tcl_ErrnoMsg.3
+ rm -f SetErrno.3.*
+ $ZIP SetErrno.3
+ rm -f Tcl_SetErrno.3 Tcl_SetErrno.3.*
+ rm -f Tcl_GetErrno.3 Tcl_GetErrno.3.*
+ rm -f Tcl_ErrnoId.3 Tcl_ErrnoId.3.*
+ rm -f Tcl_ErrnoMsg.3 Tcl_ErrnoMsg.3.*
+ ln $S SetErrno.3$Z Tcl_SetErrno.3$Z
+ ln $S SetErrno.3$Z Tcl_GetErrno.3$Z
+ ln $S SetErrno.3$Z Tcl_ErrnoId.3$Z
+ ln $S SetErrno.3$Z Tcl_ErrnoMsg.3$Z
fi
if test -r SetRecLmt.3; then
- rm -f Tcl_SetRecursionLimit.3
- cp SetRecLmt.3 Tcl_SetRecursionLimit.3
+ rm -f SetRecLmt.3.*
+ $ZIP SetRecLmt.3
+ rm -f Tcl_SetRecursionLimit.3 Tcl_SetRecursionLimit.3.*
+ ln $S SetRecLmt.3$Z Tcl_SetRecursionLimit.3$Z
fi
if test -r SetResult.3; then
- rm -f Tcl_SetObjResult.3
- rm -f Tcl_GetObjResult.3
- rm -f Tcl_SetResult.3
- rm -f Tcl_GetStringResult.3
- rm -f Tcl_AppendResult.3
- rm -f Tcl_AppendResultVA.3
- rm -f Tcl_AppendElement.3
- rm -f Tcl_ResetResult.3
- rm -f Tcl_FreeResult.3
- cp SetResult.3 Tcl_SetObjResult.3
- cp SetResult.3 Tcl_GetObjResult.3
- cp SetResult.3 Tcl_SetResult.3
- cp SetResult.3 Tcl_GetStringResult.3
- cp SetResult.3 Tcl_AppendResult.3
- cp SetResult.3 Tcl_AppendResultVA.3
- cp SetResult.3 Tcl_AppendElement.3
- cp SetResult.3 Tcl_ResetResult.3
- cp SetResult.3 Tcl_FreeResult.3
+ rm -f SetResult.3.*
+ $ZIP SetResult.3
+ rm -f Tcl_SetObjResult.3 Tcl_SetObjResult.3.*
+ rm -f Tcl_GetObjResult.3 Tcl_GetObjResult.3.*
+ rm -f Tcl_SetResult.3 Tcl_SetResult.3.*
+ rm -f Tcl_GetStringResult.3 Tcl_GetStringResult.3.*
+ rm -f Tcl_AppendResult.3 Tcl_AppendResult.3.*
+ rm -f Tcl_AppendResultVA.3 Tcl_AppendResultVA.3.*
+ rm -f Tcl_AppendElement.3 Tcl_AppendElement.3.*
+ rm -f Tcl_ResetResult.3 Tcl_ResetResult.3.*
+ rm -f Tcl_FreeResult.3 Tcl_FreeResult.3.*
+ ln $S SetResult.3$Z Tcl_SetObjResult.3$Z
+ ln $S SetResult.3$Z Tcl_GetObjResult.3$Z
+ ln $S SetResult.3$Z Tcl_SetResult.3$Z
+ ln $S SetResult.3$Z Tcl_GetStringResult.3$Z
+ ln $S SetResult.3$Z Tcl_AppendResult.3$Z
+ ln $S SetResult.3$Z Tcl_AppendResultVA.3$Z
+ ln $S SetResult.3$Z Tcl_AppendElement.3$Z
+ ln $S SetResult.3$Z Tcl_ResetResult.3$Z
+ ln $S SetResult.3$Z Tcl_FreeResult.3$Z
fi
if test -r SetVar.3; then
- rm -f Tcl_SetVar2Ex.3
- rm -f Tcl_SetVar.3
- rm -f Tcl_SetVar2.3
- rm -f Tcl_ObjSetVar2.3
- rm -f Tcl_GetVar2Ex.3
- rm -f Tcl_GetVar.3
- rm -f Tcl_GetVar2.3
- rm -f Tcl_ObjGetVar2.3
- rm -f Tcl_UnsetVar.3
- rm -f Tcl_UnsetVar2.3
- cp SetVar.3 Tcl_SetVar2Ex.3
- cp SetVar.3 Tcl_SetVar.3
- cp SetVar.3 Tcl_SetVar2.3
- cp SetVar.3 Tcl_ObjSetVar2.3
- cp SetVar.3 Tcl_GetVar2Ex.3
- cp SetVar.3 Tcl_GetVar.3
- cp SetVar.3 Tcl_GetVar2.3
- cp SetVar.3 Tcl_ObjGetVar2.3
- cp SetVar.3 Tcl_UnsetVar.3
- cp SetVar.3 Tcl_UnsetVar2.3
+ rm -f SetVar.3.*
+ $ZIP SetVar.3
+ rm -f Tcl_SetVar2Ex.3 Tcl_SetVar2Ex.3.*
+ rm -f Tcl_SetVar.3 Tcl_SetVar.3.*
+ rm -f Tcl_SetVar2.3 Tcl_SetVar2.3.*
+ rm -f Tcl_ObjSetVar2.3 Tcl_ObjSetVar2.3.*
+ rm -f Tcl_GetVar2Ex.3 Tcl_GetVar2Ex.3.*
+ rm -f Tcl_GetVar.3 Tcl_GetVar.3.*
+ rm -f Tcl_GetVar2.3 Tcl_GetVar2.3.*
+ rm -f Tcl_ObjGetVar2.3 Tcl_ObjGetVar2.3.*
+ rm -f Tcl_UnsetVar.3 Tcl_UnsetVar.3.*
+ rm -f Tcl_UnsetVar2.3 Tcl_UnsetVar2.3.*
+ ln $S SetVar.3$Z Tcl_SetVar2Ex.3$Z
+ ln $S SetVar.3$Z Tcl_SetVar.3$Z
+ ln $S SetVar.3$Z Tcl_SetVar2.3$Z
+ ln $S SetVar.3$Z Tcl_ObjSetVar2.3$Z
+ ln $S SetVar.3$Z Tcl_GetVar2Ex.3$Z
+ ln $S SetVar.3$Z Tcl_GetVar.3$Z
+ ln $S SetVar.3$Z Tcl_GetVar2.3$Z
+ ln $S SetVar.3$Z Tcl_ObjGetVar2.3$Z
+ ln $S SetVar.3$Z Tcl_UnsetVar.3$Z
+ ln $S SetVar.3$Z Tcl_UnsetVar2.3$Z
+fi
+if test -r Signal.3; then
+ rm -f Signal.3.*
+ $ZIP Signal.3
+ rm -f Tcl_SignalId.3 Tcl_SignalId.3.*
+ rm -f Tcl_SignalMsg.3 Tcl_SignalMsg.3.*
+ ln $S Signal.3$Z Tcl_SignalId.3$Z
+ ln $S Signal.3$Z Tcl_SignalMsg.3$Z
fi
if test -r Sleep.3; then
- rm -f Tcl_Sleep.3
- cp Sleep.3 Tcl_Sleep.3
+ rm -f Sleep.3.*
+ $ZIP Sleep.3
+ rm -f Tcl_Sleep.3 Tcl_Sleep.3.*
+ ln $S Sleep.3$Z Tcl_Sleep.3$Z
fi
if test -r SourceRCFile.3; then
- rm -f Tcl_SourceRCFile.3
- cp SourceRCFile.3 Tcl_SourceRCFile.3
+ rm -f SourceRCFile.3.*
+ $ZIP SourceRCFile.3
+ rm -f Tcl_SourceRCFile.3 Tcl_SourceRCFile.3.*
+ ln $S SourceRCFile.3$Z Tcl_SourceRCFile.3$Z
fi
if test -r SplitList.3; then
- rm -f Tcl_SplitList.3
- rm -f Tcl_Merge.3
- rm -f Tcl_ScanElement.3
- rm -f Tcl_ConvertElement.3
- rm -f Tcl_ScanCountedElement.3
- rm -f Tcl_ConvertCountedElement.3
- cp SplitList.3 Tcl_SplitList.3
- cp SplitList.3 Tcl_Merge.3
- cp SplitList.3 Tcl_ScanElement.3
- cp SplitList.3 Tcl_ConvertElement.3
- cp SplitList.3 Tcl_ScanCountedElement.3
- cp SplitList.3 Tcl_ConvertCountedElement.3
+ rm -f SplitList.3.*
+ $ZIP SplitList.3
+ rm -f Tcl_SplitList.3 Tcl_SplitList.3.*
+ rm -f Tcl_Merge.3 Tcl_Merge.3.*
+ rm -f Tcl_ScanElement.3 Tcl_ScanElement.3.*
+ rm -f Tcl_ConvertElement.3 Tcl_ConvertElement.3.*
+ rm -f Tcl_ScanCountedElement.3 Tcl_ScanCountedElement.3.*
+ rm -f Tcl_ConvertCountedElement.3 Tcl_ConvertCountedElement.3.*
+ ln $S SplitList.3$Z Tcl_SplitList.3$Z
+ ln $S SplitList.3$Z Tcl_Merge.3$Z
+ ln $S SplitList.3$Z Tcl_ScanElement.3$Z
+ ln $S SplitList.3$Z Tcl_ConvertElement.3$Z
+ ln $S SplitList.3$Z Tcl_ScanCountedElement.3$Z
+ ln $S SplitList.3$Z Tcl_ConvertCountedElement.3$Z
fi
if test -r SplitPath.3; then
- rm -f Tcl_SplitPath.3
- rm -f Tcl_JoinPath.3
- rm -f Tcl_GetPathType.3
- cp SplitPath.3 Tcl_SplitPath.3
- cp SplitPath.3 Tcl_JoinPath.3
- cp SplitPath.3 Tcl_GetPathType.3
+ rm -f SplitPath.3.*
+ $ZIP SplitPath.3
+ rm -f Tcl_SplitPath.3 Tcl_SplitPath.3.*
+ rm -f Tcl_JoinPath.3 Tcl_JoinPath.3.*
+ rm -f Tcl_GetPathType.3 Tcl_GetPathType.3.*
+ ln $S SplitPath.3$Z Tcl_SplitPath.3$Z
+ ln $S SplitPath.3$Z Tcl_JoinPath.3$Z
+ ln $S SplitPath.3$Z Tcl_GetPathType.3$Z
fi
if test -r StaticPkg.3; then
- rm -f Tcl_StaticPackage.3
- cp StaticPkg.3 Tcl_StaticPackage.3
+ rm -f StaticPkg.3.*
+ $ZIP StaticPkg.3
+ rm -f Tcl_StaticPackage.3 Tcl_StaticPackage.3.*
+ ln $S StaticPkg.3$Z Tcl_StaticPackage.3$Z
+fi
+if test -r StdChannels.3; then
+ rm -f StdChannels.3.*
+ $ZIP StdChannels.3
+ rm -f Tcl_StandardChannels.3 Tcl_StandardChannels.3.*
+ ln $S StdChannels.3$Z Tcl_StandardChannels.3$Z
fi
if test -r StrMatch.3; then
- rm -f Tcl_StringMatch.3
- rm -f Tcl_StringCaseMatch.3
- cp StrMatch.3 Tcl_StringMatch.3
- cp StrMatch.3 Tcl_StringCaseMatch.3
+ rm -f StrMatch.3.*
+ $ZIP StrMatch.3
+ rm -f Tcl_StringMatch.3 Tcl_StringMatch.3.*
+ rm -f Tcl_StringCaseMatch.3 Tcl_StringCaseMatch.3.*
+ ln $S StrMatch.3$Z Tcl_StringMatch.3$Z
+ ln $S StrMatch.3$Z Tcl_StringCaseMatch.3$Z
fi
if test -r StringObj.3; then
- rm -f Tcl_NewStringObj.3
- rm -f Tcl_NewUnicodeObj.3
- rm -f Tcl_SetStringObj.3
- rm -f Tcl_SetUnicodeObj.3
- rm -f Tcl_GetStringFromObj.3
- rm -f Tcl_GetString.3
- rm -f Tcl_GetUnicode.3
- rm -f Tcl_GetUniChar.3
- rm -f Tcl_GetCharLength.3
- rm -f Tcl_GetRange.3
- rm -f Tcl_AppendToObj.3
- rm -f Tcl_AppendUnicodeToObj.3
- rm -f Tcl_AppendStringsToObj.3
- rm -f Tcl_AppendStringsToObjVA.3
- rm -f Tcl_AppendObjToObj.3
- rm -f Tcl_SetObjLength.3
- rm -f Tcl_ConcatObj.3
- cp StringObj.3 Tcl_NewStringObj.3
- cp StringObj.3 Tcl_NewUnicodeObj.3
- cp StringObj.3 Tcl_SetStringObj.3
- cp StringObj.3 Tcl_SetUnicodeObj.3
- cp StringObj.3 Tcl_GetStringFromObj.3
- cp StringObj.3 Tcl_GetString.3
- cp StringObj.3 Tcl_GetUnicode.3
- cp StringObj.3 Tcl_GetUniChar.3
- cp StringObj.3 Tcl_GetCharLength.3
- cp StringObj.3 Tcl_GetRange.3
- cp StringObj.3 Tcl_AppendToObj.3
- cp StringObj.3 Tcl_AppendUnicodeToObj.3
- cp StringObj.3 Tcl_AppendStringsToObj.3
- cp StringObj.3 Tcl_AppendStringsToObjVA.3
- cp StringObj.3 Tcl_AppendObjToObj.3
- cp StringObj.3 Tcl_SetObjLength.3
- cp StringObj.3 Tcl_ConcatObj.3
+ rm -f StringObj.3.*
+ $ZIP StringObj.3
+ rm -f Tcl_NewStringObj.3 Tcl_NewStringObj.3.*
+ rm -f Tcl_NewUnicodeObj.3 Tcl_NewUnicodeObj.3.*
+ rm -f Tcl_SetStringObj.3 Tcl_SetStringObj.3.*
+ rm -f Tcl_SetUnicodeObj.3 Tcl_SetUnicodeObj.3.*
+ rm -f Tcl_GetStringFromObj.3 Tcl_GetStringFromObj.3.*
+ rm -f Tcl_GetString.3 Tcl_GetString.3.*
+ rm -f Tcl_GetUnicodeFromObj.3 Tcl_GetUnicodeFromObj.3.*
+ rm -f Tcl_GetUnicode.3 Tcl_GetUnicode.3.*
+ rm -f Tcl_GetUniChar.3 Tcl_GetUniChar.3.*
+ rm -f Tcl_GetCharLength.3 Tcl_GetCharLength.3.*
+ rm -f Tcl_GetRange.3 Tcl_GetRange.3.*
+ rm -f Tcl_AppendToObj.3 Tcl_AppendToObj.3.*
+ rm -f Tcl_AppendUnicodeToObj.3 Tcl_AppendUnicodeToObj.3.*
+ rm -f Tcl_AppendStringsToObj.3 Tcl_AppendStringsToObj.3.*
+ rm -f Tcl_AppendStringsToObjVA.3 Tcl_AppendStringsToObjVA.3.*
+ rm -f Tcl_AppendObjToObj.3 Tcl_AppendObjToObj.3.*
+ rm -f Tcl_SetObjLength.3 Tcl_SetObjLength.3.*
+ rm -f Tcl_ConcatObj.3 Tcl_ConcatObj.3.*
+ rm -f Tcl_AttemptSetObjLength.3 Tcl_AttemptSetObjLength.3.*
+ ln $S StringObj.3$Z Tcl_NewStringObj.3$Z
+ ln $S StringObj.3$Z Tcl_NewUnicodeObj.3$Z
+ ln $S StringObj.3$Z Tcl_SetStringObj.3$Z
+ ln $S StringObj.3$Z Tcl_SetUnicodeObj.3$Z
+ ln $S StringObj.3$Z Tcl_GetStringFromObj.3$Z
+ ln $S StringObj.3$Z Tcl_GetString.3$Z
+ ln $S StringObj.3$Z Tcl_GetUnicodeFromObj.3$Z
+ ln $S StringObj.3$Z Tcl_GetUnicode.3$Z
+ ln $S StringObj.3$Z Tcl_GetUniChar.3$Z
+ ln $S StringObj.3$Z Tcl_GetCharLength.3$Z
+ ln $S StringObj.3$Z Tcl_GetRange.3$Z
+ ln $S StringObj.3$Z Tcl_AppendToObj.3$Z
+ ln $S StringObj.3$Z Tcl_AppendUnicodeToObj.3$Z
+ ln $S StringObj.3$Z Tcl_AppendStringsToObj.3$Z
+ ln $S StringObj.3$Z Tcl_AppendStringsToObjVA.3$Z
+ ln $S StringObj.3$Z Tcl_AppendObjToObj.3$Z
+ ln $S StringObj.3$Z Tcl_SetObjLength.3$Z
+ ln $S StringObj.3$Z Tcl_ConcatObj.3$Z
+ ln $S StringObj.3$Z Tcl_AttemptSetObjLength.3$Z
+fi
+if test -r SubstObj.3; then
+ rm -f SubstObj.3.*
+ $ZIP SubstObj.3
+ rm -f Tcl_SubstObj.3 Tcl_SubstObj.3.*
+ ln $S SubstObj.3$Z Tcl_SubstObj.3$Z
+fi
+if test -r TCL_MEM_DEBUG.3; then
+ rm -f TCL_MEM_DEBUG.3.*
+ $ZIP TCL_MEM_DEBUG.3
+fi
+if test -r Tcl.n; then
+ rm -f Tcl.n.*
+ $ZIP Tcl.n
+fi
+if test -r Tcl_Main.3; then
+ rm -f Tcl_Main.3.*
+ $ZIP Tcl_Main.3
+ rm -f Tcl_SetMainLoop.3 Tcl_SetMainLoop.3.*
+ ln $S Tcl_Main.3$Z Tcl_SetMainLoop.3$Z
fi
if test -r Thread.3; then
- rm -f Tcl_ConditionNotify.3
- rm -f Tcl_ConditionWait.3
- rm -f Tcl_ConditionFinalize.3
- rm -f Tcl_GetThreadData.3
- rm -f Tcl_MutexLock.3
- rm -f Tcl_MutexUnlock.3
- rm -f Tcl_MutexFinalize.3
- rm -f Tcl_CreateThread.3
- cp Thread.3 Tcl_ConditionNotify.3
- cp Thread.3 Tcl_ConditionWait.3
- cp Thread.3 Tcl_ConditionFinalize.3
- cp Thread.3 Tcl_GetThreadData.3
- cp Thread.3 Tcl_MutexLock.3
- cp Thread.3 Tcl_MutexUnlock.3
- cp Thread.3 Tcl_MutexFinalize.3
- cp Thread.3 Tcl_CreateThread.3
+ rm -f Thread.3.*
+ $ZIP Thread.3
+ rm -f Tcl_ConditionNotify.3 Tcl_ConditionNotify.3.*
+ rm -f Tcl_ConditionWait.3 Tcl_ConditionWait.3.*
+ rm -f Tcl_ConditionFinalize.3 Tcl_ConditionFinalize.3.*
+ rm -f Tcl_GetThreadData.3 Tcl_GetThreadData.3.*
+ rm -f Tcl_MutexLock.3 Tcl_MutexLock.3.*
+ rm -f Tcl_MutexUnlock.3 Tcl_MutexUnlock.3.*
+ rm -f Tcl_MutexFinalize.3 Tcl_MutexFinalize.3.*
+ rm -f Tcl_CreateThread.3 Tcl_CreateThread.3.*
+ rm -f Tcl_JoinThread.3 Tcl_JoinThread.3.*
+ ln $S Thread.3$Z Tcl_ConditionNotify.3$Z
+ ln $S Thread.3$Z Tcl_ConditionWait.3$Z
+ ln $S Thread.3$Z Tcl_ConditionFinalize.3$Z
+ ln $S Thread.3$Z Tcl_GetThreadData.3$Z
+ ln $S Thread.3$Z Tcl_MutexLock.3$Z
+ ln $S Thread.3$Z Tcl_MutexUnlock.3$Z
+ ln $S Thread.3$Z Tcl_MutexFinalize.3$Z
+ ln $S Thread.3$Z Tcl_CreateThread.3$Z
+ ln $S Thread.3$Z Tcl_JoinThread.3$Z
fi
if test -r ToUpper.3; then
- rm -f Tcl_UniCharToUpper.3
- rm -f Tcl_UniCharToLower.3
- rm -f Tcl_UniCharToTitle.3
- rm -f Tcl_UtfToUpper.3
- rm -f Tcl_UtfToLower.3
- rm -f Tcl_UtfToTitle.3
- cp ToUpper.3 Tcl_UniCharToUpper.3
- cp ToUpper.3 Tcl_UniCharToLower.3
- cp ToUpper.3 Tcl_UniCharToTitle.3
- cp ToUpper.3 Tcl_UtfToUpper.3
- cp ToUpper.3 Tcl_UtfToLower.3
- cp ToUpper.3 Tcl_UtfToTitle.3
+ rm -f ToUpper.3.*
+ $ZIP ToUpper.3
+ rm -f Tcl_UniCharToUpper.3 Tcl_UniCharToUpper.3.*
+ rm -f Tcl_UniCharToLower.3 Tcl_UniCharToLower.3.*
+ rm -f Tcl_UniCharToTitle.3 Tcl_UniCharToTitle.3.*
+ rm -f Tcl_UtfToUpper.3 Tcl_UtfToUpper.3.*
+ rm -f Tcl_UtfToLower.3 Tcl_UtfToLower.3.*
+ rm -f Tcl_UtfToTitle.3 Tcl_UtfToTitle.3.*
+ ln $S ToUpper.3$Z Tcl_UniCharToUpper.3$Z
+ ln $S ToUpper.3$Z Tcl_UniCharToLower.3$Z
+ ln $S ToUpper.3$Z Tcl_UniCharToTitle.3$Z
+ ln $S ToUpper.3$Z Tcl_UtfToUpper.3$Z
+ ln $S ToUpper.3$Z Tcl_UtfToLower.3$Z
+ ln $S ToUpper.3$Z Tcl_UtfToTitle.3$Z
+fi
+if test -r TraceCmd.3; then
+ rm -f TraceCmd.3.*
+ $ZIP TraceCmd.3
+ rm -f Tcl_CommandTraceInfo.3 Tcl_CommandTraceInfo.3.*
+ rm -f Tcl_TraceCommand.3 Tcl_TraceCommand.3.*
+ rm -f Tcl_UntraceCommand.3 Tcl_UntraceCommand.3.*
+ ln $S TraceCmd.3$Z Tcl_CommandTraceInfo.3$Z
+ ln $S TraceCmd.3$Z Tcl_TraceCommand.3$Z
+ ln $S TraceCmd.3$Z Tcl_UntraceCommand.3$Z
fi
if test -r TraceVar.3; then
- rm -f Tcl_TraceVar.3
- rm -f Tcl_TraceVar2.3
- rm -f Tcl_UntraceVar.3
- rm -f Tcl_UntraceVar2.3
- rm -f Tcl_VarTraceInfo.3
- rm -f Tcl_VarTraceInfo2.3
- cp TraceVar.3 Tcl_TraceVar.3
- cp TraceVar.3 Tcl_TraceVar2.3
- cp TraceVar.3 Tcl_UntraceVar.3
- cp TraceVar.3 Tcl_UntraceVar2.3
- cp TraceVar.3 Tcl_VarTraceInfo.3
- cp TraceVar.3 Tcl_VarTraceInfo2.3
+ rm -f TraceVar.3.*
+ $ZIP TraceVar.3
+ rm -f Tcl_TraceVar.3 Tcl_TraceVar.3.*
+ rm -f Tcl_TraceVar2.3 Tcl_TraceVar2.3.*
+ rm -f Tcl_UntraceVar.3 Tcl_UntraceVar.3.*
+ rm -f Tcl_UntraceVar2.3 Tcl_UntraceVar2.3.*
+ rm -f Tcl_VarTraceInfo.3 Tcl_VarTraceInfo.3.*
+ rm -f Tcl_VarTraceInfo2.3 Tcl_VarTraceInfo2.3.*
+ ln $S TraceVar.3$Z Tcl_TraceVar.3$Z
+ ln $S TraceVar.3$Z Tcl_TraceVar2.3$Z
+ ln $S TraceVar.3$Z Tcl_UntraceVar.3$Z
+ ln $S TraceVar.3$Z Tcl_UntraceVar2.3$Z
+ ln $S TraceVar.3$Z Tcl_VarTraceInfo.3$Z
+ ln $S TraceVar.3$Z Tcl_VarTraceInfo2.3$Z
fi
if test -r Translate.3; then
- rm -f Tcl_TranslateFileName.3
- cp Translate.3 Tcl_TranslateFileName.3
+ rm -f Translate.3.*
+ $ZIP Translate.3
+ rm -f Tcl_TranslateFileName.3 Tcl_TranslateFileName.3.*
+ ln $S Translate.3$Z Tcl_TranslateFileName.3$Z
+fi
+if test -r UniCharIsAlpha.3; then
+ rm -f UniCharIsAlpha.3.*
+ $ZIP UniCharIsAlpha.3
+ rm -f Tcl_UniCharIsAlnum.3 Tcl_UniCharIsAlnum.3.*
+ rm -f Tcl_UniCharIsAlpha.3 Tcl_UniCharIsAlpha.3.*
+ rm -f Tcl_UniCharIsControl.3 Tcl_UniCharIsControl.3.*
+ rm -f Tcl_UniCharIsDigit.3 Tcl_UniCharIsDigit.3.*
+ rm -f Tcl_UniCharIsGraph.3 Tcl_UniCharIsGraph.3.*
+ rm -f Tcl_UniCharIsLower.3 Tcl_UniCharIsLower.3.*
+ rm -f Tcl_UniCharIsPrint.3 Tcl_UniCharIsPrint.3.*
+ rm -f Tcl_UniCharIsPunct.3 Tcl_UniCharIsPunct.3.*
+ rm -f Tcl_UniCharIsSpace.3 Tcl_UniCharIsSpace.3.*
+ rm -f Tcl_UniCharIsUpper.3 Tcl_UniCharIsUpper.3.*
+ rm -f Tcl_UniCharIsWordChar.3 Tcl_UniCharIsWordChar.3.*
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsAlnum.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsAlpha.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsControl.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsDigit.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsGraph.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsLower.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsPrint.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsPunct.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsSpace.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsUpper.3$Z
+ ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsWordChar.3$Z
fi
if test -r UpVar.3; then
- rm -f Tcl_UpVar.3
- rm -f Tcl_UpVar2.3
- cp UpVar.3 Tcl_UpVar.3
- cp UpVar.3 Tcl_UpVar2.3
+ rm -f UpVar.3.*
+ $ZIP UpVar.3
+ rm -f Tcl_UpVar.3 Tcl_UpVar.3.*
+ rm -f Tcl_UpVar2.3 Tcl_UpVar2.3.*
+ ln $S UpVar.3$Z Tcl_UpVar.3$Z
+ ln $S UpVar.3$Z Tcl_UpVar2.3$Z
fi
if test -r Utf.3; then
- rm -f Tcl_UniChar.3
- rm -f Tcl_UniCharToUtf.3
- rm -f Tcl_UtfToUniChar.3
- rm -f Tcl_UniCharToUtfDString.3
- rm -f Tcl_UtfToUniCharDString.3
- rm -f Tcl_UniCharLen.3
- rm -f Tcl_UniCharNcmp.3
- rm -f Tcl_UtfCharComplete.3
- rm -f Tcl_NumUtfChars.3
- rm -f Tcl_UtfFindFirst.3
- rm -f Tcl_UtfFindLast.3
- rm -f Tcl_UtfNext.3
- rm -f Tcl_UtfPrev.3
- rm -f Tcl_UniCharAtIndex.3
- rm -f Tcl_UtfAtIndex.3
- rm -f Tcl_UtfBackslash.3
- cp Utf.3 Tcl_UniChar.3
- cp Utf.3 Tcl_UniCharToUtf.3
- cp Utf.3 Tcl_UtfToUniChar.3
- cp Utf.3 Tcl_UniCharToUtfDString.3
- cp Utf.3 Tcl_UtfToUniCharDString.3
- cp Utf.3 Tcl_UniCharLen.3
- cp Utf.3 Tcl_UniCharNcmp.3
- cp Utf.3 Tcl_UtfCharComplete.3
- cp Utf.3 Tcl_NumUtfChars.3
- cp Utf.3 Tcl_UtfFindFirst.3
- cp Utf.3 Tcl_UtfFindLast.3
- cp Utf.3 Tcl_UtfNext.3
- cp Utf.3 Tcl_UtfPrev.3
- cp Utf.3 Tcl_UniCharAtIndex.3
- cp Utf.3 Tcl_UtfAtIndex.3
- cp Utf.3 Tcl_UtfBackslash.3
+ rm -f Utf.3.*
+ $ZIP Utf.3
+ rm -f Tcl_UniChar.3 Tcl_UniChar.3.*
+ rm -f Tcl_UniCharCaseMatch.3 Tcl_UniCharCaseMatch.3.*
+ rm -f Tcl_UniCharNcasecmp.3 Tcl_UniCharNcasecmp.3.*
+ rm -f Tcl_UniCharToUtf.3 Tcl_UniCharToUtf.3.*
+ rm -f Tcl_UtfToUniChar.3 Tcl_UtfToUniChar.3.*
+ rm -f Tcl_UniCharToUtfDString.3 Tcl_UniCharToUtfDString.3.*
+ rm -f Tcl_UtfToUniCharDString.3 Tcl_UtfToUniCharDString.3.*
+ rm -f Tcl_UniCharLen.3 Tcl_UniCharLen.3.*
+ rm -f Tcl_UniCharNcmp.3 Tcl_UniCharNcmp.3.*
+ rm -f Tcl_UtfCharComplete.3 Tcl_UtfCharComplete.3.*
+ rm -f Tcl_NumUtfChars.3 Tcl_NumUtfChars.3.*
+ rm -f Tcl_UtfFindFirst.3 Tcl_UtfFindFirst.3.*
+ rm -f Tcl_UtfFindLast.3 Tcl_UtfFindLast.3.*
+ rm -f Tcl_UtfNext.3 Tcl_UtfNext.3.*
+ rm -f Tcl_UtfPrev.3 Tcl_UtfPrev.3.*
+ rm -f Tcl_UniCharAtIndex.3 Tcl_UniCharAtIndex.3.*
+ rm -f Tcl_UtfAtIndex.3 Tcl_UtfAtIndex.3.*
+ rm -f Tcl_UtfBackslash.3 Tcl_UtfBackslash.3.*
+ ln $S Utf.3$Z Tcl_UniChar.3$Z
+ ln $S Utf.3$Z Tcl_UniCharCaseMatch.3$Z
+ ln $S Utf.3$Z Tcl_UniCharNcasecmp.3$Z
+ ln $S Utf.3$Z Tcl_UniCharToUtf.3$Z
+ ln $S Utf.3$Z Tcl_UtfToUniChar.3$Z
+ ln $S Utf.3$Z Tcl_UniCharToUtfDString.3$Z
+ ln $S Utf.3$Z Tcl_UtfToUniCharDString.3$Z
+ ln $S Utf.3$Z Tcl_UniCharLen.3$Z
+ ln $S Utf.3$Z Tcl_UniCharNcmp.3$Z
+ ln $S Utf.3$Z Tcl_UtfCharComplete.3$Z
+ ln $S Utf.3$Z Tcl_NumUtfChars.3$Z
+ ln $S Utf.3$Z Tcl_UtfFindFirst.3$Z
+ ln $S Utf.3$Z Tcl_UtfFindLast.3$Z
+ ln $S Utf.3$Z Tcl_UtfNext.3$Z
+ ln $S Utf.3$Z Tcl_UtfPrev.3$Z
+ ln $S Utf.3$Z Tcl_UniCharAtIndex.3$Z
+ ln $S Utf.3$Z Tcl_UtfAtIndex.3$Z
+ ln $S Utf.3$Z Tcl_UtfBackslash.3$Z
fi
if test -r WrongNumArgs.3; then
- rm -f Tcl_WrongNumArgs.3
- cp WrongNumArgs.3 Tcl_WrongNumArgs.3
+ rm -f WrongNumArgs.3.*
+ $ZIP WrongNumArgs.3
+ rm -f Tcl_WrongNumArgs.3 Tcl_WrongNumArgs.3.*
+ ln $S WrongNumArgs.3$Z Tcl_WrongNumArgs.3$Z
+fi
+if test -r after.n; then
+ rm -f after.n.*
+ $ZIP after.n
+fi
+if test -r append.n; then
+ rm -f append.n.*
+ $ZIP append.n
+fi
+if test -r array.n; then
+ rm -f array.n.*
+ $ZIP array.n
+fi
+if test -r bgerror.n; then
+ rm -f bgerror.n.*
+ $ZIP bgerror.n
+fi
+if test -r binary.n; then
+ rm -f binary.n.*
+ $ZIP binary.n
+fi
+if test -r break.n; then
+ rm -f break.n.*
+ $ZIP break.n
+fi
+if test -r case.n; then
+ rm -f case.n.*
+ $ZIP case.n
+fi
+if test -r catch.n; then
+ rm -f catch.n.*
+ $ZIP catch.n
+fi
+if test -r cd.n; then
+ rm -f cd.n.*
+ $ZIP cd.n
+fi
+if test -r clock.n; then
+ rm -f clock.n.*
+ $ZIP clock.n
+fi
+if test -r close.n; then
+ rm -f close.n.*
+ $ZIP close.n
+fi
+if test -r concat.n; then
+ rm -f concat.n.*
+ $ZIP concat.n
+fi
+if test -r continue.n; then
+ rm -f continue.n.*
+ $ZIP continue.n
+fi
+if test -r dde.n; then
+ rm -f dde.n.*
+ $ZIP dde.n
+fi
+if test -r encoding.n; then
+ rm -f encoding.n.*
+ $ZIP encoding.n
+fi
+if test -r eof.n; then
+ rm -f eof.n.*
+ $ZIP eof.n
+fi
+if test -r error.n; then
+ rm -f error.n.*
+ $ZIP error.n
+fi
+if test -r eval.n; then
+ rm -f eval.n.*
+ $ZIP eval.n
+fi
+if test -r exec.n; then
+ rm -f exec.n.*
+ $ZIP exec.n
+fi
+if test -r exit.n; then
+ rm -f exit.n.*
+ $ZIP exit.n
+fi
+if test -r expr.n; then
+ rm -f expr.n.*
+ $ZIP expr.n
+fi
+if test -r fblocked.n; then
+ rm -f fblocked.n.*
+ $ZIP fblocked.n
+fi
+if test -r fconfigure.n; then
+ rm -f fconfigure.n.*
+ $ZIP fconfigure.n
+fi
+if test -r fcopy.n; then
+ rm -f fcopy.n.*
+ $ZIP fcopy.n
+fi
+if test -r file.n; then
+ rm -f file.n.*
+ $ZIP file.n
+fi
+if test -r fileevent.n; then
+ rm -f fileevent.n.*
+ $ZIP fileevent.n
+fi
+if test -r filename.n; then
+ rm -f filename.n.*
+ $ZIP filename.n
+fi
+if test -r flush.n; then
+ rm -f flush.n.*
+ $ZIP flush.n
+fi
+if test -r for.n; then
+ rm -f for.n.*
+ $ZIP for.n
+fi
+if test -r foreach.n; then
+ rm -f foreach.n.*
+ $ZIP foreach.n
+fi
+if test -r format.n; then
+ rm -f format.n.*
+ $ZIP format.n
+fi
+if test -r gets.n; then
+ rm -f gets.n.*
+ $ZIP gets.n
+fi
+if test -r glob.n; then
+ rm -f glob.n.*
+ $ZIP glob.n
+fi
+if test -r global.n; then
+ rm -f global.n.*
+ $ZIP global.n
+fi
+if test -r history.n; then
+ rm -f history.n.*
+ $ZIP history.n
fi
if test -r http.n; then
- rm -f Http.n
- cp http.n Http.n
+ rm -f http.n.*
+ $ZIP http.n
+fi
+if test -r if.n; then
+ rm -f if.n.*
+ $ZIP if.n
+fi
+if test -r incr.n; then
+ rm -f incr.n.*
+ $ZIP incr.n
+fi
+if test -r info.n; then
+ rm -f info.n.*
+ $ZIP info.n
+fi
+if test -r interp.n; then
+ rm -f interp.n.*
+ $ZIP interp.n
+fi
+if test -r join.n; then
+ rm -f join.n.*
+ $ZIP join.n
+fi
+if test -r lappend.n; then
+ rm -f lappend.n.*
+ $ZIP lappend.n
fi
if test -r library.n; then
- rm -f auto_execok.n
- rm -f auto_import.n
- rm -f auto_load.n
- rm -f auto_mkindex.n
- rm -f auto_mkindex_old.n
- rm -f auto_qualify.n
- rm -f auto_reset.n
- rm -f tcl_findLibrary.n
- rm -f parray.n
- rm -f tcl_endOfWord.n
- rm -f tcl_startOfNextWord.n
- rm -f tcl_startOfPreviousWord.n
- rm -f tcl_wordBreakAfter.n
- rm -f tcl_wordBreakBefore.n
- cp library.n auto_execok.n
- cp library.n auto_import.n
- cp library.n auto_load.n
- cp library.n auto_mkindex.n
- cp library.n auto_mkindex_old.n
- cp library.n auto_qualify.n
- cp library.n auto_reset.n
- cp library.n tcl_findLibrary.n
- cp library.n parray.n
- cp library.n tcl_endOfWord.n
- cp library.n tcl_startOfNextWord.n
- cp library.n tcl_startOfPreviousWord.n
- cp library.n tcl_wordBreakAfter.n
- cp library.n tcl_wordBreakBefore.n
+ rm -f library.n.*
+ $ZIP library.n
+ rm -f auto_execok.n auto_execok.n.*
+ rm -f auto_import.n auto_import.n.*
+ rm -f auto_load.n auto_load.n.*
+ rm -f auto_mkindex.n auto_mkindex.n.*
+ rm -f auto_mkindex_old.n auto_mkindex_old.n.*
+ rm -f auto_qualify.n auto_qualify.n.*
+ rm -f auto_reset.n auto_reset.n.*
+ rm -f tcl_findLibrary.n tcl_findLibrary.n.*
+ rm -f parray.n parray.n.*
+ rm -f tcl_endOfWord.n tcl_endOfWord.n.*
+ rm -f tcl_startOfNextWord.n tcl_startOfNextWord.n.*
+ rm -f tcl_startOfPreviousWord.n tcl_startOfPreviousWord.n.*
+ rm -f tcl_wordBreakAfter.n tcl_wordBreakAfter.n.*
+ rm -f tcl_wordBreakBefore.n tcl_wordBreakBefore.n.*
+ ln $S library.n$Z auto_execok.n$Z
+ ln $S library.n$Z auto_import.n$Z
+ ln $S library.n$Z auto_load.n$Z
+ ln $S library.n$Z auto_mkindex.n$Z
+ ln $S library.n$Z auto_mkindex_old.n$Z
+ ln $S library.n$Z auto_qualify.n$Z
+ ln $S library.n$Z auto_reset.n$Z
+ ln $S library.n$Z tcl_findLibrary.n$Z
+ ln $S library.n$Z parray.n$Z
+ ln $S library.n$Z tcl_endOfWord.n$Z
+ ln $S library.n$Z tcl_startOfNextWord.n$Z
+ ln $S library.n$Z tcl_startOfPreviousWord.n$Z
+ ln $S library.n$Z tcl_wordBreakAfter.n$Z
+ ln $S library.n$Z tcl_wordBreakBefore.n$Z
+fi
+if test -r lindex.n; then
+ rm -f lindex.n.*
+ $ZIP lindex.n
+fi
+if test -r linsert.n; then
+ rm -f linsert.n.*
+ $ZIP linsert.n
+fi
+if test -r list.n; then
+ rm -f list.n.*
+ $ZIP list.n
+fi
+if test -r llength.n; then
+ rm -f llength.n.*
+ $ZIP llength.n
+fi
+if test -r load.n; then
+ rm -f load.n.*
+ $ZIP load.n
+fi
+if test -r lrange.n; then
+ rm -f lrange.n.*
+ $ZIP lrange.n
+fi
+if test -r lreplace.n; then
+ rm -f lreplace.n.*
+ $ZIP lreplace.n
+fi
+if test -r lsearch.n; then
+ rm -f lsearch.n.*
+ $ZIP lsearch.n
+fi
+if test -r lset.n; then
+ rm -f lset.n.*
+ $ZIP lset.n
+fi
+if test -r lsort.n; then
+ rm -f lsort.n.*
+ $ZIP lsort.n
+fi
+if test -r memory.n; then
+ rm -f memory.n.*
+ $ZIP memory.n
+fi
+if test -r msgcat.n; then
+ rm -f msgcat.n.*
+ $ZIP msgcat.n
+fi
+if test -r namespace.n; then
+ rm -f namespace.n.*
+ $ZIP namespace.n
+fi
+if test -r open.n; then
+ rm -f open.n.*
+ $ZIP open.n
+fi
+if test -r package.n; then
+ rm -f package.n.*
+ $ZIP package.n
fi
if test -r packagens.n; then
- rm -f pkg::create.n
- cp packagens.n pkg::create.n
+ rm -f packagens.n.*
+ $ZIP packagens.n
+ rm -f pkg::create.n pkg::create.n.*
+ ln $S packagens.n$Z pkg::create.n$Z
+fi
+if test -r pid.n; then
+ rm -f pid.n.*
+ $ZIP pid.n
fi
if test -r pkgMkIndex.n; then
- rm -f pkg_mkIndex.n
- cp pkgMkIndex.n pkg_mkIndex.n
+ rm -f pkgMkIndex.n.*
+ $ZIP pkgMkIndex.n
+ rm -f pkg_mkIndex.n pkg_mkIndex.n.*
+ ln $S pkgMkIndex.n$Z pkg_mkIndex.n$Z
+fi
+if test -r proc.n; then
+ rm -f proc.n.*
+ $ZIP proc.n
+fi
+if test -r puts.n; then
+ rm -f puts.n.*
+ $ZIP puts.n
+fi
+if test -r pwd.n; then
+ rm -f pwd.n.*
+ $ZIP pwd.n
+fi
+if test -r re_syntax.n; then
+ rm -f re_syntax.n.*
+ $ZIP re_syntax.n
+fi
+if test -r read.n; then
+ rm -f read.n.*
+ $ZIP read.n
+fi
+if test -r regexp.n; then
+ rm -f regexp.n.*
+ $ZIP regexp.n
+fi
+if test -r registry.n; then
+ rm -f registry.n.*
+ $ZIP registry.n
+fi
+if test -r regsub.n; then
+ rm -f regsub.n.*
+ $ZIP regsub.n
+fi
+if test -r rename.n; then
+ rm -f rename.n.*
+ $ZIP rename.n
+fi
+if test -r resource.n; then
+ rm -f resource.n.*
+ $ZIP resource.n
+fi
+if test -r return.n; then
+ rm -f return.n.*
+ $ZIP return.n
fi
if test -r safe.n; then
- rm -f SafeBase.n
- cp safe.n SafeBase.n
+ rm -f safe.n.*
+ $ZIP safe.n
+ rm -f SafeBase.n SafeBase.n.*
+ ln $S safe.n$Z SafeBase.n$Z
+fi
+if test -r scan.n; then
+ rm -f scan.n.*
+ $ZIP scan.n
+fi
+if test -r seek.n; then
+ rm -f seek.n.*
+ $ZIP seek.n
+fi
+if test -r set.n; then
+ rm -f set.n.*
+ $ZIP set.n
+fi
+if test -r socket.n; then
+ rm -f socket.n.*
+ $ZIP socket.n
+fi
+if test -r source.n; then
+ rm -f source.n.*
+ $ZIP source.n
+fi
+if test -r split.n; then
+ rm -f split.n.*
+ $ZIP split.n
+fi
+if test -r string.n; then
+ rm -f string.n.*
+ $ZIP string.n
+fi
+if test -r subst.n; then
+ rm -f subst.n.*
+ $ZIP subst.n
+fi
+if test -r switch.n; then
+ rm -f switch.n.*
+ $ZIP switch.n
+fi
+if test -r tclsh.1; then
+ rm -f tclsh.1.*
+ $ZIP tclsh.1
fi
if test -r tcltest.n; then
- rm -f Tcltest.n
- cp tcltest.n Tcltest.n
+ rm -f tcltest.n.*
+ $ZIP tcltest.n
+fi
+if test -r tclvars.n; then
+ rm -f tclvars.n.*
+ $ZIP tclvars.n
+fi
+if test -r tell.n; then
+ rm -f tell.n.*
+ $ZIP tell.n
+fi
+if test -r time.n; then
+ rm -f time.n.*
+ $ZIP time.n
+fi
+if test -r trace.n; then
+ rm -f trace.n.*
+ $ZIP trace.n
+fi
+if test -r unknown.n; then
+ rm -f unknown.n.*
+ $ZIP unknown.n
+fi
+if test -r unset.n; then
+ rm -f unset.n.*
+ $ZIP unset.n
+fi
+if test -r update.n; then
+ rm -f update.n.*
+ $ZIP update.n
+fi
+if test -r uplevel.n; then
+ rm -f uplevel.n.*
+ $ZIP uplevel.n
+fi
+if test -r upvar.n; then
+ rm -f upvar.n.*
+ $ZIP upvar.n
+fi
+if test -r variable.n; then
+ rm -f variable.n.*
+ $ZIP variable.n
+fi
+if test -r vwait.n; then
+ rm -f vwait.n.*
+ $ZIP vwait.n
+fi
+if test -r while.n; then
+ rm -f while.n.*
+ $ZIP while.n
fi
exit 0
+++ /dev/null
-This file contains a collection of notes that various people have
-provided about porting Tcl to various machines and operating systems.
-I don't have personal access to any of these machines, so I make
-no guarantees that the notes are correct, complete, or up-to-date.
-If you see the word "I" in any explanations, it refers to the person
-who contributed the information, not to me; this means that I
-probably can't answer any questions about any of this stuff. In
-some cases, a person has volunteered to act as a contact point for
-questions about porting Tcl to a particular machine; in these
-cases the person's name and e-mail address are listed. I'm
-interested in getting new porting information to add to the file;
-please mail updates to "john.ousterhout@eng.sun.com".
-
-This file reflects information provided for Tcl 7.4 and later releases (8.x).
-If there is no information for your configuration in this file, check
-the file "porting.old" too; it contains information that was
-submitted for Tcl 7.3 and earlier releases, and some of that information
-may still be valid.
-
-A new porting database has recently become available on the Web at
-the following URL:
- http://www.sunlabs.com/cgi-bin/tcl/info.8.0
-This page provides information about the platforms on which Tcl and
-and Tk 8.0 have been compiled and what changes were needed to get Tcl
-and Tk to compile. You can also add new entries to that database
-when you install Tcl and Tk on a new platform. The Web database is
-likely to be more up-to-date than this file.
-
-sccsid = RCS: @(#) $Id$
-
---------------------------------------------
-Solaris, various versions
---------------------------------------------
-
-1. If typing "make test" results in an error message saying that
-there are no "*.test" files, or you get lots of globbing errors,
-it's probably because your system doesn't have cc installed and
-you used gcc. In order for this to work, you have to set your
-CC environment variable to gcc and your CPP environment variable
-to "gcc -E" before running the configure script.
-
-2. Make sure that /usr/ucb is not in your PATH or LD_LIBRARY_PATH
-environment variables; this will cause confusion between the new
-Solaris libraries and older UCB versions (Tcl will expect one version
-and get another).
-
-3. There have been several reports of problems with the "glob" command.
-So far these reports have all been for older versions of Tcl, but
-if you run into problems, edit the Makefile after "configure" is
-run and add "-DNO_DIRENT_H=1" to the definitions of DEFS. Do this
-before compiling.
-
---------------------------------------------
-SunOS 4 and potentially other OSes
---------------------------------------------
-
-On systems where both getcwd(3) and getwd(3) exist, check the man
-page and if getcwd, like on SunOS 4, uses popen to pwd(1)
-add -DUSEGETWD to the flags CFLAGS so getwd will be used instead.
-
-That is, change the CFLAGS = -O line so it reads
-CFLAGS = -O -DUSEGETWD
-
---------------------------------------------
-Linux, ELF, various versions/distributions
---------------------------------------------
-
-If ./configure --enable-shared complains it can not do a shared
-library you might have to make the following symbolic link:
-ln -s /lib/libdl.so.1 /lib/libdl.so
-then remove config.cache and re run configure.
-
---------------------------------------------
-Pyramid DC/OSx SVr4, DC/OSx version 94c079
---------------------------------------------
-
-Tcl seems to dump core in cmdinfo.test when compiled with the
-optimiser turned on in TclEval which calls 'free'. To get around
-this, turn the optimiser off.
-
---------------------------------------------
-SGI machines, IRIX 5.2, 5.3, IRIX64 6.0.1
---------------------------------------------
-
-1. If you compile with gcc-2.6.3 under some versions of IRIX (e.g.
- 4.0.5), DBL_MAX is defined too large for gcc and Tcl complains
- about all floating-point values being too large to represent.
- If this happens, redefining DBL_MAX to 9.99e299.
-
-2. Add "-D_BSD_TIME" to CFLAGS in Makefile. This avoids type conflicts
-in the prototype for the gettimeofday procedure.
-
-2. If you're running under Irix 6.x and tclsh dumps core, try
-removing -O from the CFLAGS in Makefile and recompiling; compiler
-optimizations seem to cause problems on some machines.
-
---------------------------------------------
-IBM RTs, AOS
---------------------------------------------
-
-1. Steal fmod from 4.4BSD
-2. Add a #define to tclExpr such that:
-extern double fmod();
-is defined conditionally on ibm032
-
---------------------------------------------
-QNX 4.22
---------------------------------------------
-
-tclPort.h
- - commented out 2 lines containing #include <sys/param.h>
-
-tcl.h
- - changed #define VARARGS ()
- - to #ifndef __QNX__
- #define VARARGS ()
- #else
- #define VARARGS (void *, ...)
- #endif
-
---------------------------------------------
-Interactive UNIX
---------------------------------------------
-
-Add the switch -Xp to LIBS in Makefile; otherwise strftime will not
-be found when linking.
-
---------------------------------------------
-Motorola SVR4 V4.2 (m88k)
---------------------------------------------
-
-For Motorola Unix R40V4.2 (m88k architechure), use /usr/ucb/cc instead of
-/usr/bin/cc. Otherwise, the compile will fail because of conflicts over
-the gettimeofday() call.
-
-Also, -DNO_DIRENT_H=1 is required for the "glob" command to work.
-
---------------------------------------------
-NeXTSTEP 3.x
---------------------------------------------
-
-Here's the set of changes I made to make 7.5b3 compile cleanly on
-NeXTSTEP3.x.
-
-Here are a couple lines from unix/Makefile:
-
-# Added utsname.o, which implements a uname() emulation for NeXTSTEP.
-COMPAT_OBJS = getcwd.o strtod.o tmpnam.o utsname.o
-
-TCL_NAMES=\
- -Dstrtod=tcl_strtod -Dtmpnam=tcl_tmpnam -Dgetcwd=tcl_getcwd \
- -Dpanic=tcl_panic -Dmatherr=tcl_matherr \
- -Duname=tcl_uname -Dutsname=tcl_utsname
-
-# Added mode_t, pid_t, and O_NONBLOCK definitions.
-AC_FLAGS = -DNO_DIRENT_H=1 -DHAVE_UNISTD_H=1 -DHAVE_SYS_TIME_H=1
--DTIME_WITH_SYS_TIME=1 -DHAVE_TM_ZONE=1 -DHAVE_TM_GMTOFF=1 -DHAVE_TIMEZONE_VAR=1
--DSTDC_HEADERS=1 -Dmode_t=int -Dpid_t=int -DO_NONBLOCK=O_NDELAY ${TCL_NAMES}
-
-
-Here are diffs for other files. utsname.[hc] are a couple files I added
-to compat/ I'm not clear whether that's where they legitimately belong
-- I considered stashing them in tclLoadNext.c instead. The tclIO.c
-change was a bug, I believe, which I reported on comp.lang.tcl and
-has apparently been noted and fixed. The objc_loadModules() change
-allows "load" to load object code containing Objective-C code in
-addition to plain C code.
-
----
-scott hess <shess@winternet.com> (WWW to "http://www.winternet.com/~shess/")
-Work: 12550 Portland Avenue South #121, Burnsville, MN 55337 (612)895-1208
-
-
-diff -rc tcl7.5b3.orig/compat/utsname.c tcl7.5b3/compat/utsname.c
-*** tcl7.5b3.orig/compat/utsname.c Tue Apr 2 13:57:23 1996
---- tcl7.5b3/compat/utsname.c Mon Mar 18 11:05:54 1996
-***************
-*** 0 ****
---- 1,27 ----
-+ /*
-+ * utsname.c --
-+ *
-+ * This file is an emulation of the POSIX uname() function
-+ * under NeXTSTEP 3.x.
-+ *
-+ */
-+
-
-+ #include "utsname.h"
-+ #include <mach-o/arch.h>
-+ #include <stdio.h>
-+
-
-+ int uname( struct utsname *name)
-+ {
-+ const NXArchInfo *arch;
-+ if( gethostname( name->nodename, sizeof( name->nodename))==-1) {
-+ return -1;
-+ }
-+ if( (arch=NXGetLocalArchInfo())==NULL) {
-+ return -1;
-+ }
-+ strncpy( name->machine, arch->description, sizeof( name->machine));
-+ strcpy( name->sysname, "NEXTSTEP");
-+ strcpy( name->release, "0");
-+ strcpy( name->version, "3");
-+ return 0;
-+ }
-diff -rc tcl7.5b3.orig/compat/utsname.h tcl7.5b3/compat/utsname.h
-*** tcl7.5b3.orig/compat/utsname.h Tue Apr 2 13:57:26 1996
---- tcl7.5b3/compat/utsname.h Mon Mar 18 10:34:05 1996
-***************
-*** 0 ****
---- 1,22 ----
-+ /*
-+ * utsname.h --
-+ *
-+ * This file is an emulation of the POSIX uname() function
-+ * under NeXTSTEP.
-+ *
-+ */
-+
-
-+ #ifndef _UTSNAME
-+ #define _UTSNAME
-+
-
-+ struct utsname {
-+ char sysname[ 32];
-+ char nodename[ 32];
-+ char release[ 32];
-+ char version[ 32];
-+ char machine[ 32];
-+ };
-+
-
-+ extern int uname( struct utsname *name);
-+
-
-+ #endif /* _UTSNAME */
-diff -rc tcl7.5b3.orig/generic/tclIO.c tcl7.5b3/generic/tclIO.c
-*** tcl7.5b3.orig/generic/tclIO.c Fri Mar 8 12:59:53 1996
---- tcl7.5b3/generic/tclIO.c Mon Mar 18 11:38:57 1996
-***************
-*** 2542,2548 ****
- }
- result = GetInput(chanPtr);
- if (result != 0) {
-! if (result == EWOULDBLOCK) {
- chanPtr->flags |= CHANNEL_BLOCKED;
- return copied;
- }
---- 2542,2548 ----
- }
- result = GetInput(chanPtr);
- if (result != 0) {
-! if (result == EAGAIN) {
- chanPtr->flags |= CHANNEL_BLOCKED;
- return copied;
- }
-diff -rc tcl7.5b3.orig/unix/tclLoadNext.c tcl7.5b3/unix/tclLoadNext.c
-*** tcl7.5b3.orig/unix/tclLoadNext.c Sat Feb 17 16:16:42 1996
---- tcl7.5b3/unix/tclLoadNext.c Mon Mar 18 10:02:36 1996
-***************
-*** 55,61 ****
- char *files[]={fileName,NULL};
- NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE);
-
-
-! if(!rld_load(errorStream,&header,files,NULL)) {
- NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
- Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL);
- NXCloseMemory(errorStream,NX_FREEBUFFER);
---- 55,61 ----
- char *files[]={fileName,NULL};
- NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE);
-
-
-! if(objc_loadModules(files,errorStream,NULL,&header,NULL)) {
- NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
- Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL);
- NXCloseMemory(errorStream,NX_FREEBUFFER);
-diff -rc tcl7.5b3.orig/unix/tclUnixFile.c tcl7.5b3/unix/tclUnixFile.c
-*** tcl7.5b3.orig/unix/tclUnixFile.c Thu Mar 7 18:16:34 1996
---- tcl7.5b3/unix/tclUnixFile.c Mon Mar 18 11:10:03 1996
-***************
-*** 31,37 ****
---- 31,41 ----
-
-
- static int executableNameExitHandlerSet = 0;
-
-
-+ #if NeXT
-+ #define waitpid( p, s, o) wait4( p, s, o, NULL)
-+ #else
- extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options));
-+ #endif
-
-
- /*
- * Static routines for this file:
-diff -rc tcl7.5b3.orig/unix/tclUnixInit.c tcl7.5b3/unix/tclUnixInit.c
-*** tcl7.5b3.orig/unix/tclUnixInit.c Sat Feb 17 16:16:39 1996
---- tcl7.5b3/unix/tclUnixInit.c Mon Mar 18 11:50:28 1996
-***************
-*** 14,20 ****
- #include "tclInt.h"
- #include "tclPort.h"
- #ifndef NO_UNAME
-! # include <sys/utsname.h>
- #endif
- #if defined(__FreeBSD__)
- #include <floatingpoint.h>
---- 14,24 ----
- #include "tclInt.h"
- #include "tclPort.h"
- #ifndef NO_UNAME
-! # if NeXT
-! # include "../compat/utsname.h"
-! # else
-! # include <sys/utsname.h>
-! # endif
- #endif
- #if defined(__FreeBSD__)
- #include <floatingpoint.h>
-diff -rc tcl7.5b3.orig/unix/tclUnixPort.h tcl7.5b3/unix/tclUnixPort.h
-*** tcl7.5b3.orig/unix/tclUnixPort.h Thu Mar 7 18:16:31 1996
---- tcl7.5b3/unix/tclUnixPort.h Mon Mar 18 11:53:14 1996
-***************
-*** 76,82 ****
- */
-
-
- #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */
-! #include <sys/utsname.h> /* uname system call. */
- #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */
- #include <arpa/inet.h> /* inet_ntoa() */
- #include <netdb.h> /* gethostbyname() */
---- 76,88 ----
- */
-
-
- #include <sys/socket.h> /* struct sockaddr, SOCK_STREAM, ... */
-! #ifndef NO_UNAME
-! # if NeXT
-! # include "../compat/utsname.h"
-! # else
-! # include <sys/utsname.h> /* uname system call. */
-! # endif
-! #endif
- #include <netinet/in.h> /* struct in_addr, struct sockaddr_in */
- #include <arpa/inet.h> /* inet_ntoa() */
- #include <netdb.h> /* gethostbyname() */
-
---------------------------------------------
-SCO Unix 3.2.4 (ODT 3.0)
---------------------------------------------
-
-The macro va_start in /usr/include/stdarg.h is incorrectly terminated by
-a semi-colon. This causes compile of generic/tclBasic.c to fail. The
-best solution is to edit the definition of va_start to remove the `;'.
-This will fix this file for anything you want to compile. If you don't have
-permission to edit /usr/include/stdarg.h in place, copy it to the tcl unix
-directory and change it there.
-
-Contact me directly if you have problems on SCO systems.
-Mark Diekhans <markd@grizzly.com>
-
---------------------------------------------
-SCO Unix 3.2.5 (ODT 5.0)
---------------------------------------------
-
-Expect failures from socket tests 2.9 and 3.1.
-
-Contact me directly if you have problems on SCO systems.
-Mark Diekhans <markd@grizzly.com>
-
---------------------------------------------
-Linux 1.2.13 (gcc 2.7.0, libc.so.5.0.9)
---------------------------------------------
-
-Symptoms:
-
-* Some extensions could not be loaded dynamically, most
- prominently Blt 2.0
-
- The given error message essentially said:
- Could not resolve symbol '__eprintf'.
-
- (This procedure is used by the macro 'assert')
-
-Cause
-
-* '__eprintf' is defined in 'libgcc.a', not 'libc.so.x.y'.
- It is therefore impossible to load it dynamically.
-
-* Neither tcl nor tk make use of 'assert', thereby
- preventing a static linkage.
-
-Workaround
-
-* I included <assert.h> in 'tclAppInit.c' / 'tkAppInit.c'
- and then executed 'assert (argc)' just before the call
- to Tcl_Main / Tk_Main.
-
- This forced the static linkage of '__eprintf' and
- everything went fine from then on.
-
- (Something like 'assert (1)', 'assert (a==a)' is not
- sufficient, it will be optimized away).
-
+++ /dev/null
-This is an old version of the file "porting.notes". It contains
-porting information that people submitted for Tcl releases numbered
-7.3 and earlier. You may find information in this file useful if
-there is no information available for your machine in the current
-version of "porting.notes".
-
-I don't have personal access to any of these machines, so I make
-no guarantees that the notes are correct, complete, or up-to-date.
-If you see the word "I" in any explanations, it refers to the person
-who contributed the information, not to me; this means that I
-probably can't answer any questions about any of this stuff. In
-some cases, a person has volunteered to act as a contact point for
-questions about porting Tcl to a particular machine; in these
-cases the person's name and e-mail address are listed.
-
-sccsid = SCCS: @(#) porting.old 1.3 96/02/16 08:56:07
-
----------------------------------------------
-Cray machines running UNICOS:
-Contact: John Freeman (jlf@cray.com)
----------------------------------------------
-
-1. There is an error in the strstr function in UNICOS such that if the
-string to be searched is empty (""), the search will continue past the
-end of the string. Because of this, the history substitution loop
-will sometimes run past the end of its target string and trash
-malloc's free list, resulting in a core dump some time later. (As you
-can probably guess, this took a while to diagnose.) I've submitted a
-problem report to the C library maintainers, but in the meantime here
-is a workaround.
-
------------------------------------------------------------------
-diff -c1 -r1.1 tclHistory.c
-*** 1.1 1991/11/12 16:01:58
---- tclHistory.c 1991/11/12 16:14:22
-***************
-*** 23,24 ****
---- 23,29 ----
- #include "tclInt.h"
-+
-+ #ifdef _CRAY
-+ /* There is a bug in strstr in UNICOS; this works around it. */
-+ #define strstr(s1,s2) ((s1)?(*(s1)?strstr((s1),(s2)):0):0)
-+ #endif _CRAY
-
----------------------------------------------
-MIPS systems runing EP/IX:
----------------------------------------------
-
-1. Need to add a line "#include <bsd/sys/time.h>" in tclUnix.h.
-
-2. Need to add "-lbsd" into the line that makes tclTest:
-
- ${CC} ${CFLAGS} tclTest.o libtcl.a -lbsd -o tclTest
-
----------------------------------------------
-IBM RS/6000 systems running AIX:
----------------------------------------------
-
-1. The system version of strtoul is buggy, at least under some
-versions of AIX. If the expression tests fail, try forcing Tcl
-to use its own version of strtoul instead of the system version.
-To do this, first copy strtoul.c from the compat subdirectory up
-to the main Tcl directory. Then modify the Makefile so that
-the definition for COMPAT_OBJS includes "strtoul.o". Note: the
-"config" script should now detect the buggy strtoul and substitute
-Tcl's version automatically.
-
-2. You may have to comment out the declaration of open in tclUnix.h.
-
-3. You may need to add "-D_BSD -lbsd" to the CFLAGS definition. This
-causes the system include files to look like BSD include files and
-causes C library routines to act like bsd library routines. Without
-this, the system may choke on "struct wait".
-
----------------------------------------------
-AT&T 4.03 OS:
----------------------------------------------
-
-Machine: i386/33Mhz i387 32k Cache 16MByte
-OS: AT&T SYSV Release 4 Version 3
-X: X11R5 fixlevel 9
-Xserver: X386 1.2
-
-1. Change the Tk Makefile as follows:
-XLIB = -lX11
- should be changed to:
-XLIB = -lX11 -lsocket -lnsl
-
--------------------------------------------------------
-Silicon Graphics systems:
--------------------------------------------------------
-
-1. Change the CC variable in the Makefile to:
-
-CC = cc -xansi -D__STDC__ -signed
-
-2. In Irix releases 4.0.1 or earlier the C compiler has a buggy optimizer.
- If Tcl fails its test suite or generates inexplicable errors,
- compile tclVar.c with -O0 instead of -O.
-
-3. For IRIX 5.1 or later, comments 1 and 2 are no longer relevant,
-but you must add -D_BSD_SIGNALS to CFLAGS to get the proper signal
-routines.
-
-4. Add a "-lsun" switch in the targets for tclsh and tcltest,
-just before ${MATH_LIBS}.
-
-5. Rumor has it that you also need to add the "-lmalloc" library switch
-in the targets for tclsh and tcltest.
-
-6. In IRIX 5.2 you'll have to modify Makefile to fix the following problems:
- - The "-c" option is illegal with this version of install, but
- the "-F" switch is needed instead. Change this in the "INSTALL ="
- definition line.
- - The order of file and directory have to be changed in all the
- invocations of INSTALL_DATA or INSTALL_PROGRAM.
-
----------------------------------------------
-NeXT machines running NeXTStep 3.1:
----------------------------------------------
-
-1. Run configure with predefined CPP:
- CPP='cc -E' ./configure
- (If your shell is [t]csh, do a "setenv CPP 'cc -E' ")
-
-2. Edit Makefile:
- -add tmpnam.o to COMPAT_OBJS:
- COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o
- -add the following to AC_FLAGS:
- -Dstrtod=tcl_strtod
-
-3. Edit compat/tmpnam.c and replace "/usr/tmp" with "/tmp"
-
-After this, tcl7.0 will be build fine on NeXT (ignore linker warning)
-and run all the tests. There are some formatting problems in printf() or
-scanf() which come from NeXT's lacking POSIX conformance. Ignore those
-errors, they don't matter much.
-
-4. Additional information that may apply to NeXTStep 3.2 only:
-
- The problem on NEXTSTEP 3.2 is that the configure script makes some
- bad assumptions about the uid_t and gid_t types. Actually, the may
- have been valid for NEXTSTEP 3.0, or it may be NEXTSTEP's rudimentary
- attempt at POSIX support under 3.2, but no matter what the reason, the
- configure script sets up the Makefile with CFLAGS '-Duid_t=int' and
- '-Dgid_t=int', which are, unfortunately, incorrect, since they shoudl
- actually be (I think) unsigned shorts. This causes problems when the
- 'stat' structure is included, since it throws off the field offsets
- from what the 'fstat' function thinks they should be.
-
- Anyway, the quick fix is to run configure and then edit the Makefile
- to remove the uid_t and gid_t defines. This will allow tcl and Tk to
- compile and run. There are some other problems on NEXTSTEP,
- specifically with %g in the printf family of functions, but making the
- uid_t and gid_t change will get it up and running.
-
----------------------------------------------
-NeXT machines running NeXTStep 3.2:
----------------------------------------------
-
-1. Run configure with predefined CPP:
- CPP='cc -E' ./configure
- (If your shell is [t]csh, do a "setenv CPP 'cc -E' ")
-
-2. Edit Makefile:
- -add tmpnam.o to COMPAT_OBJS:
- COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o
- -add the following to AC_FLAGS:
- -Dstrtod=tcl_strtod
- -add '-m' to MATH_LIBS:
- MATH_LIBS = -m -lm
- -add '-O2 -arch m68k -arch i386' to CFLAGS:
- CFLAGS = -O2 -arch m68k -arch i386
-
--------------------------------------------------
-ISC 2.2 UNIX (using standard ATT SYSV compiler):
--------------------------------------------------
-
-In Makefile, change
-
-CFLAGS = -g -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\"
-
-to
-
-CFLAGS = -g -I. -DPOSIX_JC -DTCL_LIBRARY=\"${TCL_LIBRARY}\"
-
-This brings in the typedef for pid_t, which is needed for
-/usr/include/sys/wait.h in tclUnix.h.
-
----------------------------------------------
-DEC Alphas:
----------------------------------------------
-
-1. There appears to be a compiler/library bug that causes core-dumps
-unless you compile tclVar.c without optimization (remove the -O compiler
-switch). The problem appears to have been fixed in the 1.3-4 version
-of the compiler.
-
----------------------------------------------
-CDC 4680MP, EP/IX 1.4.3:
----------------------------------------------
-
-The installation was done in the System V environment (-systype sysv)
-with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was
-built with the 2.20 level C compiler. The 2.11 level should not be used
-because it has a problem with detecting NaN values in lines like:
- if (x != x) ...
-which appear in the TCL code.
-
-To make the configure script find the BSD extensions, I set environment
-variable DEFS to "-I/usr/include/bsd" and LIBS to "-lbsd" before
-running it. I would have also set CC to "cc2.20", but that compiler
-driver has a bug that loader errors (e.g. not finding a library routine,
-which the script uses to tell what is available) do not cause an error
-status to be returned to the shell (but see the comments about "-non_shared"
-below in the 2.1.1 notes).
-
-There is a bug in the <sys/wait.h> include file that mis-defines the
-structure fields and causes WIFEXITED and WIFSIGNALED to return incorrect
-values. My solution was to create a subdirectory "sys" of the main TCL
-source directory and put a corrected wait.h in it. The "-I." already on
-all the compile lines causes it to be used instead of the system version.
-To fix this, compare the structure definition in /usr/include/bsd/sys/wait.h
-with /bsd43/include/sys/wait.h (or mail to John Jackson, jrj@cc.purdue.edu,
-and he'll send you a context diff).
-
-After running configure, I made the following changes to Makefile:
-
- 1) In AC_FLAGS, change:
- -DNO_WAIT3=1
- to
- -DNO_WAIT3=0 -Dwait3=wait2
- EP/IX (in the System V environment) provides a wait2() system
- call with what TCL needs (the WNOHANG flag). The extra parameter
- TCL passes to what it thinks is wait3() (the resources used by
- the child process) is always zero and will be safely ignored.
-
- 2) Change:
- CC=cc
- to
- CC=cc2.20
- because of the NaN problem mentioned earlier. Skip this if the
- default compiler is already 2.20 (or later).
-
- 3) Add "-lbsd" to the commands that create tclsh and tcltest
- (look for "-o").
-
----------------------------------------------
-CDC 4680MP, EP/IX 2.1.1:
----------------------------------------------
-
-The installation was done in the System V environment (-systype sysv)
-with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was
-built with the 3.11 level C compiler. The 2.11 level should not be used
-because it has a problem with detecting NaN values in lines like:
- if (x != x) ...
-which appear in the TCL code. The 2.20 compiler does not have this
-problem.
-
-To make the configure script find the BSD extensions, I set environment
-variable DEFS to:
-
- "-I/usr/include/bsd -D__STDC__=0 -non_shared"
-
-and LIBS to:
-
- "-lbsd"
-
-before running it. The "-non_shared" is needed because with shared
-libraries, the compiler (actually, the loader) does not report an
-error for "missing" routines. The configuration script depends on this
-error to know what routines are available. This is the real problem
-I reported above for EP/IX 1.4.3 that I incorrectly attributed to a
-compiler driver bug. I don't have 1.4.3 available any more, but it's
-possible using "-non_shared" on it would have solved the problem.
-
-The same <sys/wait.h> bug exists at 2.1.1 (yes, I have reported it to
-CDC), and the same fix as described in the 1.4.3 porting notes works.
-
-In addition to the three Makefile changes described in the 1.4.3 notes,
-you can remove the "-non_shared" flag from AC_FLAGS. It is only needed
-for the configuration step, not the build.
-
-You will get duplicate definition compilation warnings of:
-
- DBL_MIN
- DBL_MAX
- FLT_MIN
- FLT_MAX
-
-during tclExpr.c. These can be ignored.
-
-During expr.test, you will get a failure for one of the "fmod" tests
-unless you have CDC patch CC40038311 installed.
-
----------------------------------------------
-Convex systems, OS 10.1 and 10.2:
-Contact: Lennart Sorth (ls@dmi.min.dk)
----------------------------------------------
-
-1. tcl7.0b2 compiles on Convex systems (OS 10.1 and 10.2) by just running
- configure, typing make, except tclUnixUtil.c needs to be compiled
- with option "-pcc" (portable cc, =!ANSI) due to:
- cc: Error on line 1111 of tclUnixUtil.c: 'waitpid' redeclared:
- incompatible types.
-
--------------------------------------------------
-Pyramid, OSx 5.1a (UCB universe, GCC installed):
--------------------------------------------------
-
-1. The procedures memcpy, strchr, fmod, and strrchr are all missing,
-so you'll need to provide substitutes for them. After you do that
-everything should compile fine. There will be one error in a scan
-test, but it's an obscure one because of a non-ANSI implementation
-of sscanf on the machine; you can ignore it.
-
-2. You may also have to add "tmpnam.o" to COMPAT_OBJS in Makefile:
-the system version appears to be bad.
-
--------------------------------------------------
-Encore 91, UMAX V 3.0.9.3:
--------------------------------------------------
-
-1. Modify the CFLAGS assignment in file Makefile.in to include the
--DENCORE flag in Makefile:
-
- CFLAGS = -O -DENCORE
-
-2. "mkdir" does not by default create the parent directories. The mkdir
-directives should be modified to "midir -p".
-
--------------------------------------------------
-Sequent machines running Dynix:
-Contact: Andrew Swan (aswan@soda.berkeley.edu)
--------------------------------------------------
-
-1. Use gcc instead of the cc distributed by Sequent
-
-2. The distributed math library does not include the fmod
- function. Source for fmod can be retrieved from a BSD
- source archive (such as ftp.uu.net) and included in the
- compat directory. Add fmod.o to the COMPAT_OBJS variable
- in the Makefile. You may need to comment out references
- to 'isnan' and 'finite' in fmod.c
-
-3. If the linker complains that there are two copies of the
- 'tanh' function, use the ar command to extract the objects
- from the math library and build a new one without tanh.o
-
-4. The *scanf functions in the Sequent libraries are apparently
- broken, which will cause the scanning tests to fail. The
- cases that fail are fairly obscure. Using GNU libc apparently
- solves this problem.
-
--------------------------------------------------
-Systems running Interactive 4.0:
--------------------------------------------------
-
-1. Add "-posix -D_SYSV3" to CFLAGS in Makefile (or Makefile.in).
-
--------------------------------------------------
-Systems running FreeBSD 1.1.5.1:
--------------------------------------------------
-
-The following changes comprise the entire porting effort of tcl7.3 to
-FreeBSD (i.e. these were the changes to tclTest.c) and should probably
-be made part of the tcl distribution. The changes only effect the way that
-floating point exceptions are reported. I've choosen to move the changes
-out of tclTest.c and into tclBasic.c.
-
-in tclBasic.c at top-of-file:
-
-#ifdef BSD_NET2
-#include <floatingpoint.h>
-#endif
-
-in tclBasic.c in Tcl_Init():
-
-#ifdef BSD_NET2
- fpsetround(FP_RN);
- fpsetmask(0L);
-#endif
-
AC_MSG_CHECKING([for Tcl configuration])
AC_CACHE_VAL(ac_cv_c_tclconfig,[
- # First check to see if --with-tclconfig was specified.
+ # First check to see if --with-tcl was specified.
if test x"${with_tclconfig}" != x ; then
if test -f "${with_tclconfig}/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)`
ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
break
fi
- if test -f "$i/win/tclConfig.sh" ; then
- ac_cv_c_tclconfig=`(cd $i/win; pwd)`
- break
- fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
- for i in `ls -d ${prefix}/lib 2>/dev/null` \
- `ls -d /usr/local/lib 2>/dev/null` ; do
+ for i in `ls -d ${libdir} 2>/dev/null` \
+ `ls -d /usr/local/lib 2>/dev/null` \
+ `ls -d /usr/contrib/lib 2>/dev/null` \
+ `ls -d /usr/lib 2>/dev/null` \
+ ; do
if test -f "$i/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i; pwd)`
break
if test -f "$i/unix/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
break
- fi
- if test -f "$i/win/tclConfig.sh" ; then
- ac_cv_c_tclconfig=`(cd $i/win; pwd)`
- break
- fi
+ fi
done
fi
])
if test x"${ac_cv_c_tclconfig}" = x ; then
TCL_BIN_DIR="# no Tcl configs found"
- AC_MSG_ERROR(Can't find Tcl configuration definitions)
+ AC_MSG_WARN(Can't find Tcl configuration definitions)
exit 0
else
no_tcl=
ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
break
fi
- if test -f "$i/win/tkConfig.sh" ; then
- ac_cv_c_tkconfig=`(cd $i/win; pwd)`
- break
- fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tkconfig}" = x ; then
- for i in `ls -d ${prefix}/lib 2>/dev/null` \
- `ls -d /usr/local/lib 2>/dev/null` ; do
+ for i in `ls -d ${libdir} 2>/dev/null` \
+ `ls -d /usr/local/lib 2>/dev/null` \
+ `ls -d /usr/contrib/lib 2>/dev/null` \
+ `ls -d /usr/lib 2>/dev/null` \
+ ; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i; pwd)`
break
ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
break
fi
- if test -f "$i/win/tkConfig.sh" ; then
- ac_cv_c_tkconfig=`(cd $i/win; pwd)`
- break
- fi
done
fi
])
if test x"${ac_cv_c_tkconfig}" = x ; then
TK_BIN_DIR="# no Tk configs found"
- AC_MSG_ERROR(Can't find Tk configuration definitions)
+ AC_MSG_WARN(Can't find Tk configuration definitions)
exit 0
else
no_tk=
fi
#
- # The eval is required to do the TCL_DBGX substitution in the
- # TCL_LIB_FILE variable
+ # If the TCL_BIN_DIR is the build directory (not the install directory),
+ # then set the common variable name to the value of the build variables.
+ # For example, the variable TCL_LIB_SPEC will be set to the value
+ # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC
+ # instead of TCL_BUILD_LIB_SPEC since it will work with both an
+ # installed and uninstalled version of Tcl.
#
- eval TCL_LIB_FILE=${TCL_LIB_FILE}
- eval TCL_LIB_FLAG=${TCL_LIB_FLAG}
+ if test -f $TCL_BIN_DIR/Makefile ; then
+ TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
+ TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
+ TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
+ fi
+ #
+ # eval is required to do the TCL_DBGX substitution
+ #
+
+ eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
+ eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
+ eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""
+
+ eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
+ eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
+ eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
+
+ AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
+
AC_SUBST(TCL_LIB_FILE)
+ AC_SUBST(TCL_LIB_FLAG)
+ AC_SUBST(TCL_LIB_SPEC)
+
+ AC_SUBST(TCL_STUB_LIB_FILE)
+ AC_SUBST(TCL_STUB_LIB_FLAG)
+ AC_SUBST(TCL_STUB_LIB_SPEC)
])
#------------------------------------------------------------------------
#------------------------------------------------------------------------
AC_DEFUN(SC_LOAD_TKCONFIG, [
- AC_MSG_CHECKING([for existence of $TCLCONFIG])
+ AC_MSG_CHECKING([for existence of $TK_BIN_DIR/tkConfig.sh])
if test -f "$TK_BIN_DIR/tkConfig.sh" ; then
- AC_MSG_CHECKING([loading $TK_BIN_DIR/tkConfig.sh])
+ AC_MSG_RESULT([loading])
. $TK_BIN_DIR/tkConfig.sh
else
AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh])
fi
+ AC_SUBST(TK_VERSION)
AC_SUBST(TK_BIN_DIR)
AC_SUBST(TK_SRC_DIR)
AC_SUBST(TK_LIB_FILE)
])
#------------------------------------------------------------------------
+# SC_ENABLE_FRAMEWORK --
+#
+# Allows the building of shared libraries into frameworks
+#
+# Arguments:
+# none
+#
+# Results:
+#
+# Adds the following arguments to configure:
+# --enable-framework=yes|no
+#
+# Sets the following vars:
+# FRAMEWORK_BUILD Value of 1 or 0
+#------------------------------------------------------------------------
+
+AC_DEFUN(SC_ENABLE_FRAMEWORK, [
+ AC_MSG_CHECKING([how to package libraries])
+ AC_ARG_ENABLE(framework,
+ [ --enable-framework package shared libraries in frameworks [--disable-framework]],
+ [tcl_ok=$enableval], [tcl_ok=no])
+
+ if test "${enable_framework+set}" = set; then
+ enableval="$enable_framework"
+ tcl_ok=$enableval
+ else
+ tcl_ok=no
+ fi
+
+ if test "$tcl_ok" = "yes" ; then
+ AC_MSG_RESULT([framework])
+ FRAMEWORK_BUILD=1
+ if test "${SHARED_BUILD}" = "0" ; then
+ AC_MSG_WARN("Frameworks can only be built if --enable-shared is yes")
+ FRAMEWORK_BUILD=0
+ fi
+ else
+ AC_MSG_RESULT([standard shared library])
+ FRAMEWORK_BUILD=0
+ fi
+])
+
+#------------------------------------------------------------------------
# SC_ENABLE_THREADS --
#
# Specify if thread support should be enabled
# Defines the following vars:
# TCL_THREADS
# _REENTRANT
+# _THREAD_SAFE
#
#------------------------------------------------------------------------
AC_MSG_RESULT(yes)
TCL_THREADS=1
AC_DEFINE(TCL_THREADS)
+ # USE_THREAD_ALLOC tells us to try the special thread-based
+ # allocator that significantly reduces lock contention
+ AC_DEFINE(USE_THREAD_ALLOC)
AC_DEFINE(_REENTRANT)
AC_DEFINE(_THREAD_SAFE)
AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
else
AC_CHECK_LIB(c,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
if test "$tcl_ok" = "no"; then
- TCL_THREADS=0
- AC_MSG_WARN("Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...")
+ AC_CHECK_LIB(c_r,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
+ if test "$tcl_ok" = "yes"; then
+ # The space is needed
+ THREADS_LIBS=" -pthread"
+ else
+ TCL_THREADS=0
+ AC_MSG_WARN("Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...")
+ fi
fi
fi
fi
# 'pthread_attr_setstacksize' ?
AC_CHECK_FUNCS(pthread_attr_setstacksize)
+ AC_CHECK_FUNCS(readdir_r)
else
TCL_THREADS=0
- AC_MSG_RESULT(no (default))
+ AC_MSG_RESULT([no (default)])
fi
+ AC_SUBST(TCL_THREADS)
])
#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
-# Specify if debugging symbols should be used
+# Specify if debugging symbols should be used.
+# Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging
+# can also be enabled.
#
# Arguments:
# none
AC_DEFUN(SC_ENABLE_SYMBOLS, [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
- if test "$tcl_ok" = "yes"; then
- CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
- LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
- DBGX=g
- AC_MSG_RESULT([yes])
- else
+# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
+ if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
AC_MSG_RESULT([no])
+ else
+ CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
+ LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
+ DBGX=g
+ if test "$tcl_ok" = "yes"; then
+ AC_MSG_RESULT([yes (standard debugging)])
+ fi
+ fi
+ AC_SUBST(CFLAGS_DEFAULT)
+ AC_SUBST(LDFLAGS_DEFAULT)
+
+ if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
+ AC_DEFINE(TCL_MEM_DEBUG)
+ fi
+
+ if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
+ AC_DEFINE(TCL_COMPILE_DEBUG)
+ AC_DEFINE(TCL_COMPILE_STATS)
+ fi
+
+ if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
+ if test "$tcl_ok" = "all"; then
+ AC_MSG_RESULT([enabled symbols mem compile debugging])
+ else
+ AC_MSG_RESULT([enabled $tcl_ok debugging])
+ fi
fi
])
+#------------------------------------------------------------------------
+# SC_ENABLE_LANGINFO --
+#
+# Allows use of modern nl_langinfo check for better l10n.
+# This is only relevant for Unix.
+#
+# Arguments:
+# none
+#
+# Results:
+#
+# Adds the following arguments to configure:
+# --enable-langinfo=yes|no (default is yes)
+#
+# Defines the following vars:
+# HAVE_LANGINFO Triggers use of nl_langinfo if defined.
+#
+#------------------------------------------------------------------------
+
+AC_DEFUN(SC_ENABLE_LANGINFO, [
+ AC_ARG_ENABLE(langinfo,
+ [ --enable-langinfo use nl_langinfo if possible to determine
+ encoding at startup, otherwise use old heuristic],
+ [langinfo_ok=$enableval], [langinfo_ok=yes])
+
+ HAVE_LANGINFO=0
+ if test "$langinfo_ok" = "yes"; then
+ if test "$langinfo_ok" = "yes"; then
+ AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no])
+ fi
+ fi
+ AC_MSG_CHECKING([whether to use nl_langinfo])
+ if test "$langinfo_ok" = "yes"; then
+ AC_TRY_COMPILE([#include <langinfo.h>],
+ [nl_langinfo(CODESET);],[langinfo_ok=yes],[langinfo_ok=no])
+ if test "$langinfo_ok" = "no"; then
+ langinfo_ok="no (could not compile with nl_langinfo)";
+ fi
+ if test "$langinfo_ok" = "yes"; then
+ AC_DEFINE(HAVE_LANGINFO)
+ fi
+ fi
+ AC_MSG_RESULT([$langinfo_ok])
+])
+
+#--------------------------------------------------------------------
+# SC_CONFIG_MANPAGES
+#
+# Decide whether to use symlinks for linking the manpages and
+# whether to compress the manpages after installation.
+#
+# Arguments:
+# none
+#
+# Results:
+#
+# Adds the following arguments to configure:
+# --enable-man-symlinks
+# --enable-man-compression=PROG
+#
+# Defines the following variable:
+#
+# MKLINKS_FLAGS - The apropriate flags for mkLinks
+# according to the user's selection.
+#
+#--------------------------------------------------------------------
+AC_DEFUN(SC_CONFIG_MANPAGES, [
+
+ AC_MSG_CHECKING([whether to use symlinks for manpages])
+ AC_ARG_ENABLE(man-symlinks,
+ [ --enable-man-symlinks use symlinks for the manpages],
+ test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --symlinks",
+ enableval="no")
+ AC_MSG_RESULT([$enableval])
+
+ AC_MSG_CHECKING([compression for manpages])
+ AC_ARG_ENABLE(man-compression,
+ [ --enable-man-compression=PROG
+ compress the manpages with PROG],
+ test "$enableval" = "yes" && echo && AC_MSG_ERROR([missing argument to --enable-man-compression])
+ test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --compress $enableval",
+ enableval="no")
+ AC_MSG_RESULT([$enableval])
+
+ AC_SUBST(MKLINKS_FLAGS)
+])
+
#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
#
# Results:
#
-# Defines the following vars:
+# Defines and substitutes the following vars:
#
# DL_OBJS - Name of the object file that implements dynamic
# loading for Tcl on this system.
# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib",
# that tell the run-time dynamic linker where to look
# for shared libraries such as libtcl.so. Depends on
+# the variable LIB_RUNTIME_DIR in the Makefile. Could
+# be the same as CC_SEARCH_FLAGS if ${CC} is used to link.
+# CC_SEARCH_FLAGS-Flags to pass to ${CC}, such as "-Wl,-rpath,/usr/local/tcl/lib",
+# that tell the run-time dynamic linker where to look
+# for shared libraries such as libtcl.so. Depends on
# the variable LIB_RUNTIME_DIR in the Makefile.
-# MAKE_LIB - Command to execute to build the Tcl library;
-# differs depending on whether or not Tcl is being
-# compiled as a shared library.
+# MAKE_LIB - Command to execute to build the a library;
+# differs when building shared or static.
+# MAKE_STUB_LIB -
+# Command to execute to build a stub library.
+# INSTALL_LIB - Command to execute to install a library;
+# differs when building shared or static.
+# INSTALL_STUB_LIB -
+# Command to execute to install a stub library.
# STLIB_LD - Base command to use for combining object files
# into a static library.
# SHLIB_CFLAGS - Flags to pass to cc when compiling the components
# code, among other things).
# SHLIB_LD - Base command to use for combining object files
# into a shared library.
+# SHLIB_LD_FLAGS -Flags to pass when building a shared library. This
+# differes from the SHLIB_CFLAGS as it is not used
+# when building object files or executables.
# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when
# creating shared libraries. This symbol typically
# goes at the end of the "ld" commands that build
# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable
# extensions. An empty string means we don't know how
# to use shared libraries on this platform.
-# TCL_LIB_FILE - Name of the file that contains the Tcl library, such
-# as libtcl7.8.so or libtcl7.8.a.
-# TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl"
-# in the shared library name, using the $VERSION variable
+# TCL_SHLIB_LD_EXTRAS - Additional element which are added to SHLIB_LD_LIBS
+# TK_SHLIB_LD_EXTRAS for the build of Tcl and Tk, but not recorded in the
+# tclConfig.sh, since they are only used for the build
+# of Tcl and Tk.
+# Examples: MacOS X records the library version and
+# compatibility version in the shared library. But
+# of course the Tcl version of this is only used for Tcl.
+# LIB_SUFFIX - Specifies everything that comes after the "libfoo"
+# in a static or shared library name, using the $VERSION variable
# to put the version in the right place. This is used
# by platforms that need non-standard library names.
# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs
# to have a version after the .so, and ${VERSION}.a
-# on AIX, since the Tcl shared library needs to have
+# on AIX, since a shared library needs to have
# a .a extension whereas shared objects for loadable
# extensions have a .so extension. Defaults to
# ${VERSION}${SHLIB_SUFFIX}.
# Flags used when running the compiler in debug mode
# CFLAGS_OPTIMIZE -
# Flags used when running the compiler in optimize mode
-#
# EXTRA_CFLAGS
#
-# Subst's the following vars:
-# DL_LIBS
-# CFLAGS_DEBUG
-# CFLAGS_OPTIMIZE
#--------------------------------------------------------------------
AC_DEFUN(SC_CONFIG_CFLAGS, [
fi
fi
- AC_MSG_CHECKING([if gcc is being used])
- if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then
- using_gcc="yes"
- else
- using_gcc="no"
- fi
-
- AC_MSG_RESULT([$using_gcc ($CC)])
-
# Step 2: check for existence of -ldl library. This is needed because
# Linux can use either -ldl or -ldld for dynamic loading.
AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no)
+ # Require ranlib early so we can override it in special cases below.
+
+ AC_REQUIRE([AC_PROG_RANLIB])
+
# Step 3: set configuration options based on system name and version.
do64bit_ok=no
- fullSrcDir=`cd $srcdir; pwd`
EXTRA_CFLAGS=""
TCL_EXPORT_FILE_SUFFIX=""
UNSHARED_LIB_SUFFIX=""
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE=-O
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
CFLAGS_WARNING="-Wall -Wconversion -Wno-implicit-int"
else
CFLAGS_WARNING=""
dnl AC_CHECK_TOOL(AR, ar, :)
AC_CHECK_PROG(AR, ar, ar)
STLIB_LD='${AR} cr'
+ LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
+ PLAT_OBJS=""
case $system in
- AIX-4.[[2-9]])
- if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then
+ AIX-5.*)
+ if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
# AIX requires the _r compiler when gcc isn't being used
if test "${CC}" != "cc_r" ; then
CC=${CC}_r
fi
AC_MSG_RESULT(Using $CC for compiling with threads)
fi
+ LIBS="$LIBS -lc"
+ # AIX-5 uses ELF style dynamic libraries
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
+ if test "`uname -m`" = "ia64" ; then
+ # AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC
+ SHLIB_LD="/usr/ccs/bin/ld -G -z text"
+ # AIX-5 has dl* in libc.so
+ DL_LIBS=""
+ if test "$GCC" = "yes" ; then
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ else
+ CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
+ fi
+ LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
+ else
+ SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
+ DL_LIBS="-ldl"
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ TCL_NEEDS_EXP_FILE=1
+ TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
+ fi
+
+ # Note: need the LIBS below, otherwise Tk won't find Tcl's
+ # symbols when dynamically loaded into tclsh.
+
DL_OBJS="tclLoadDl.o"
- DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
- TCL_NEEDS_EXP_FILE=1
- TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
+
+ LD_LIBRARY_PATH_VAR="LIBPATH"
+
+ # Check to enable 64-bit flags for compiler/linker
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ AC_MSG_WARN("64bit mode not supported with GCC on $system")
+ else
+ do64bit_ok=yes
+ EXTRA_CFLAGS="-q64"
+ LDFLAGS="-q64"
+ RANLIB="${RANLIB} -X64"
+ AR="${AR} -X64"
+ SHLIB_LD_FLAGS="-b64"
+ fi
+ fi
;;
AIX-*)
- if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then
+ if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
# AIX requires the _r compiler when gcc isn't being used
if test "${CC}" != "cc_r" ; then
CC=${CC}_r
fi
AC_MSG_RESULT(Using $CC for compiling with threads)
fi
+ LIBS="$LIBS -lc"
SHLIB_CFLAGS=""
- SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
+ SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
- LIBOBJS="$LIBOBJS tclLoadAix.o"
- DL_LIBS="-lld"
+ DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ LD_LIBRARY_PATH_VAR="LIBPATH"
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
+
+ # AIX v<=4.1 has some different flags than 4.2+
+ if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
+ LIBOBJS="$LIBOBJS tclLoadAix.o"
+ DL_LIBS="-lld"
+ fi
+
+ # On AIX <=v4 systems, libbsd.a has to be linked in to support
+ # non-blocking file IO. This library has to be linked in after
+ # the MATH_LIBS or it breaks the pow() function. The way to
+ # insure proper sequencing, is to add it to the tail of MATH_LIBS.
+ # This library also supplies gettimeofday.
+ #
+ # AIX does not have a timezone field in struct tm. When the AIX
+ # bsd library is used, the timezone global and the gettimeofday
+ # methods are to be avoided for timezone deduction instead, we
+ # deduce the timezone by comparing the localtime result on a
+ # known GMT value.
+
+ AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes, libbsd=no)
+ if test $libbsd = yes; then
+ MATH_LIBS="$MATH_LIBS -lbsd"
+ AC_DEFINE(USE_DELTA_FOR_TZ)
+ fi
+
+ # Check to enable 64-bit flags for compiler/linker
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ AC_MSG_WARN("64bit mode not supported with GCC on $system")
+ else
+ do64bit_ok=yes
+ EXTRA_CFLAGS="-q64"
+ LDFLAGS="-q64"
+ RANLIB="${RANLIB} -X64"
+ AR="${AR} -X64"
+ SHLIB_LD_FLAGS="-b64"
+ fi
+ fi
;;
BSD/OS-2.1*|BSD/OS-3*)
SHLIB_CFLAGS=""
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
BSD/OS-4.*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="-export-dynamic"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
dgux*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
- HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*|HP-UX-*.11.*)
+ HP-UX-*.11.*)
+ # Use updated header definitions where possible
+ AC_DEFINE(_XOPEN_SOURCE_EXTENDED)
+
+ SHLIB_SUFFIX=".sl"
+ AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no)
+ if test "$tcl_ok" = yes; then
+ SHLIB_CFLAGS="+z"
+ SHLIB_LD="ld -b"
+ SHLIB_LD_LIBS='${LIBS}'
+ DL_OBJS="tclLoadShl.o"
+ DL_LIBS="-ldld"
+ LDFLAGS="-Wl,-E"
+ CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
+ LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
+ LD_LIBRARY_PATH_VAR="SHLIB_PATH"
+ fi
+
+ # Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
+ #EXTRA_CFLAGS="+DAportable"
+
+ # Check to enable 64-bit flags for compiler/linker
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ hpux_arch=`gcc -dumpmachine`
+ case $hpux_arch in
+ hppa64*)
+ # 64-bit gcc in use. Fix flags for GNU ld.
+ do64bit_ok=yes
+ SHLIB_LD="gcc -shared"
+ SHLIB_LD_LIBS=""
+ LD_SEARCH_FLAGS=''
+ CC_SEARCH_FLAGS=''
+ ;;
+ *)
+ AC_MSG_WARN("64bit mode not supported with GCC on $system")
+ ;;
+ esac
+ else
+ do64bit_ok=yes
+ EXTRA_CFLAGS="+DA2.0W"
+ LDFLAGS="+DA2.0W $LDFLAGS"
+ fi
+ fi
+ ;;
+ HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
SHLIB_SUFFIX=".sl"
AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = yes; then
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="-Wl,-E"
- LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
+ CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
+ LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
+ LD_LIBRARY_PATH_VAR="SHLIB_PATH"
fi
;;
IRIX-4.*)
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="-Wl,-D,08000000"
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
;;
- IRIX-5.*|IRIX-6.*|IRIX64-6.5*)
+ IRIX-5.*)
+ SHLIB_CFLAGS=""
+ SHLIB_LD="ld -shared -rdata_shared"
+ SHLIB_LD_LIBS='${LIBS}'
+ SHLIB_SUFFIX=".so"
+ DL_OBJS="tclLoadDl.o"
+ DL_LIBS=""
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ EXTRA_CFLAGS=""
+ LDFLAGS=""
+ ;;
+ IRIX-6.*|IRIX64-6.5*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
- if test "$using_gcc" = "yes" ; then
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ if test "$GCC" = "yes" ; then
EXTRA_CFLAGS="-mabi=n32"
LDFLAGS="-mabi=n32"
else
;;
IRIX64-6.*)
SHLIB_CFLAGS=""
- SHLIB_LD="ld -32 -shared -rdata_shared"
+ SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+
+ # Check to enable 64-bit flags for compiler/linker
+
+ if test "$do64bit" = "yes" ; then
+ if test "$GCC" = "yes" ; then
+ AC_MSG_WARN([64bit mode not supported by gcc])
+ else
+ do64bit_ok=yes
+ SHLIB_LD="ld -64 -shared -rdata_shared"
+ EXTRA_CFLAGS="-64"
+ LDFLAGS="-64"
+ fi
+ fi
;;
Linux*)
SHLIB_CFLAGS="-fPIC"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else
AC_CHECK_HEADER(dld.h, [
SHLIB_LD="ld -shared"
DL_OBJS="tclLoadDld.o"
DL_LIBS="-ldld"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
+ LD_SEARCH_FLAGS=""])
+ fi
+ if test "`uname -m`" = "alpha" ; then
+ EXTRA_CFLAGS="-mieee"
+ fi
+
+ # The combo of gcc + glibc has a bug related
+ # to inlining of functions like strtod(). The
+ # -fno-builtin flag should address this problem
+ # but it does not work. The -fno-inline flag
+ # is kind of overkill but it works.
+ # Disable inlining only when one of the
+ # files in compat/*.c is being linked in.
+ if test x"${LIBOBJS}" != x ; then
+ EXTRA_CFLAGS="${EXTRA_CFLAGS} -fno-inline"
+ fi
+
+ # XIM peeking works under XFree86.
+ AC_DEFINE(PEEK_XCLOSEIM)
+
+ ;;
+ GNU*)
+ SHLIB_CFLAGS="-fPIC"
+ SHLIB_LD_LIBS='${LIBS}'
+ SHLIB_SUFFIX=".so"
+
+ if test "$have_dl" = yes; then
+ SHLIB_LD="${CC} -shared"
+ DL_OBJS=""
+ DL_LIBS="-ldl"
+ LDFLAGS="-rdynamic"
+ CC_SEARCH_FLAGS=""
+ LD_SEARCH_FLAGS=""
+ else
+ AC_CHECK_HEADER(dld.h, [
+ SHLIB_LD="ld -shared"
+ DL_OBJS=""
+ DL_LIBS="-ldld"
+ LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""])
fi
if test "`uname -m`" = "alpha" ; then
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
MP-RAS-*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="-Wl,-Bexport"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*)
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
AC_MSG_CHECKING(for ELF)
AC_EGREP_CPP(yes, [
#ifdef __ELF__
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
])
# FreeBSD 3.* and greater have ELF.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
- SHLIB_LD_LIBS=""
+ SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="-export-dynamic"
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ if test "${TCL_THREADS}" = "1" ; then
+ # The -pthread needs to go in the CFLAGS, not LIBS
+ LIBS=`echo $LIBS | sed s/-pthread//`
+ EXTRA_CFLAGS="-pthread"
+ LDFLAGS="$LDFLAGS -pthread"
+ fi
+ case $system in
+ FreeBSD-3.*)
+ # FreeBSD-3 doesn't handle version numbers with dots.
+ UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
+ SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
+ TCL_LIB_VERSIONS_OK=nodots
+ ;;
+ esac
+ ;;
+ Rhapsody-*|Darwin-*)
+ SHLIB_CFLAGS="-fno-common"
+ SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
+ TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"
+ TK_SHLIB_LD_EXTRAS="-compatibility_version ${TK_VERSION} -current_version \${VERSION} -install_name \${DYLIB_INSTALL_DIR}/\${TK_LIB_FILE} -prebind -seg1addr 0xb000000"
+ SHLIB_LD_LIBS='${LIBS}'
+ SHLIB_SUFFIX=".dylib"
+ DL_OBJS="tclLoadDyld.o"
+ PLAT_OBJS="tclMacOSXBundle.o"
+ DL_LIBS=""
+ LDFLAGS="-prebind"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
+ CFLAGS_OPTIMIZE="-Os"
+ LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
+ # for compatibility with autoconf vers 2.13 :
+ HACK=""
+ EXTRA_CFLAGS="-DMA${HACK}C_OSX_TCL -DHAVE_CFBUNDLE -DTCL_DEFAULT_ENCODING=\\\"utf-8\\\""
+ LIBS="$LIBS -framework CoreFoundation"
;;
NEXTSTEP-*)
SHLIB_CFLAGS=""
DL_OBJS="tclLoadNext.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OS/390-*)
DL_OBJS="tclLoadOSF.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OSF1-1.*)
# OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
SHLIB_CFLAGS="-fPIC"
- SHLIB_LD="ld -shared"
+ if test "$SHARED_BUILD" = "1" ; then
+ SHLIB_LD="ld -shared"
+ else
+ SHLIB_LD="ld -non_shared"
+ fi
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OSF1-V*)
# Digital OSF/1
SHLIB_CFLAGS=""
- SHLIB_LD='ld -shared -expect_unresolved "*"'
+ if test "$SHARED_BUILD" = "1" ; then
+ SHLIB_LD='ld -shared -expect_unresolved "*"'
+ else
+ SHLIB_LD='ld -non_shared -expect_unresolved "*"'
+ fi
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
- if test "$using_gcc" = "no" ; then
+ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
+ if test "$GCC" != "yes" ; then
EXTRA_CFLAGS="-DHAVE_TZSET -std1"
fi
# see pthread_intro(3) for pthread support on osf1, k.furukawa
if test "${TCL_THREADS}" = "1" ; then
+ EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
- if test "$using_gcc" = "no" ; then
+ LIBS=`echo $LIBS | sed s/-lpthreads//`
+ if test "$GCC" = "yes" ; then
+ LIBS="$LIBS -lpthread -lmach -lexc"
+ else
EXTRA_CFLAGS="${EXTRA_CFLAGS} -pthread"
LDFLAGS="-pthread"
- else
- LIBS=`echo $LIBS | sed s/-lpthreads//`
- LIBS="$LIBS -lpthread -lmach -lexc"
fi
fi
;;
+ QNX-6*)
+ # QNX RTP
+ # This may work for all QNX, but it was only reported for v6.
+ SHLIB_CFLAGS="-fPIC"
+ SHLIB_LD="ld -Bshareable -x"
+ SHLIB_LD_LIBS=""
+ SHLIB_SUFFIX=".so"
+ DL_OBJS="tclLoadDl.o"
+ # dlopen is in -lc on QNX
+ DL_LIBS=""
+ LDFLAGS=""
+ CC_SEARCH_FLAGS=""
+ LD_SEARCH_FLAGS=""
+ ;;
RISCos-*)
SHLIB_CFLAGS="-G 0"
SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="-Wl,-D,08000000"
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
SCO_SV-3.2*)
# Note, dlopen is available only on SCO 3.2.5 and greater. However,
# this test works, since "uname -s" was non-standard in 3.2.4 and
# below.
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
SHLIB_CFLAGS="-fPIC -melf"
LDFLAGS="-melf -Wl,-Bexport"
else
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
- LDFLAGS="-belf -Wl,-Bexport"
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SINIX*5.4*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SunOS-4*)
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# SunOS can't handle version numbers with dots in them in library
# specs, like -ltcl7.5, so use -ltcl75 instead. Also, it
TCL_LIB_VERSIONS_OK=nodots
;;
SunOS-5.[[0-6]]*)
+
+ # Note: If _REENTRANT isn't defined, then Solaris
+ # won't define thread-safe library routines.
+
+ AC_DEFINE(_REENTRANT)
+ AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)
+
SHLIB_CFLAGS="-KPIC"
- SHLIB_LD="/usr/ccs/bin/ld -G -z text"
# Note: need the LIBS below, otherwise Tk won't find Tcl's
# symbols when dynamically loaded into tclsh.
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
- LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ if test "$GCC" = "yes" ; then
+ SHLIB_LD="$CC -shared"
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ else
+ SHLIB_LD="/usr/ccs/bin/ld -G -z text"
+ CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ fi
;;
SunOS-5*)
+
+ # Note: If _REENTRANT isn't defined, then Solaris
+ # won't define thread-safe library routines.
+
+ AC_DEFINE(_REENTRANT)
+ AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)
+
SHLIB_CFLAGS="-KPIC"
- SHLIB_LD="/usr/ccs/bin/ld -G -z text"
LDFLAGS=""
- do64bit_ok=no
+ # Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes" ; then
arch=`isainfo`
if test "$arch" = "sparcv9 sparc" ; then
- if test "$using_gcc" = "no" ; then
+ if test "$GCC" = "yes" ; then
+ AC_MSG_WARN("64bit mode not supported with GCC on $system")
+ else
do64bit_ok=yes
if test "$do64bitVIS" = "yes" ; then
EXTRA_CFLAGS="-xarch=v9a"
EXTRA_CFLAGS="-xarch=v9"
LDFLAGS="-xarch=v9"
fi
- else
- AC_MSG_WARN("64bit mode not supported with GCC on $system")
fi
else
AC_MSG_WARN("64bit mode only supported sparcv9 system")
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
- if test "$using_gcc" = "yes" ; then
- LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ if test "$GCC" = "yes" ; then
+ SHLIB_LD="$CC -shared"
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else
+ SHLIB_LD="/usr/ccs/bin/ld -G -z text"
+ CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
fi
;;
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="-Wl,-D,08000000"
- LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
- if test "$using_gcc" = "no" ; then
+ CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
+ LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
+ if test "$GCC" != "yes" ; then
EXTRA_CFLAGS="-DHAVE_TZSET -std1"
fi
;;
else
LDFLAGS=""
fi
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
esac
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS=""
+ CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
BUILD_DLTEST=""
fi
# standard manufacturer compiler.
if test "$DL_OBJS" != "tclLoadNone.o" ; then
- if test "$using_gcc" = "yes" ; then
+ if test "$GCC" = "yes" ; then
case $system in
AIX-*)
;;
;;
NetBSD-*|FreeBSD-*|OpenBSD-*)
;;
+ Rhapsody-*|Darwin-*)
+ ;;
RISCos-*)
;;
SCO_SV-3.2*)
UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
fi
-# CYGNUS LOCAL
- TCL_LIB_SUFFIX=.a
- AC_SUBST(TCL_LIB_SUFFIX)
-# END CYGNUS LOCAL
+ if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
+ LIB_SUFFIX=${SHARED_LIB_SUFFIX}
+ MAKE_LIB='${SHLIB_LD} -o [$]@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
+ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
+ else
+ LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
+
+ if test "$RANLIB" = "" ; then
+ MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}'
+ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
+ else
+ MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@'
+ INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))'
+ fi
+
+dnl Not at all clear what this was doing in Tcl's configure.in
+dnl or why it was needed was needed. In any event, this sort of
+dnl things needs to be done in the big loop above.
+dnl REMOVE THIS BLOCK LATER! (mdejong)
+dnl case $system in
+dnl BSD/OS*)
+dnl ;;
+dnl AIX-[[1-4]].*)
+dnl ;;
+dnl *)
+dnl SHLIB_LD_LIBS=""
+dnl ;;
+dnl esac
+ fi
+
+
+ # Stub lib does not depend on shared/static configuration
+ if test "$RANLIB" = "" ; then
+ MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}'
+ INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)'
+ else
+ MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@'
+ INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))'
+ fi
+
AC_SUBST(DL_LIBS)
+
+ AC_SUBST(DL_OBJS)
+ AC_SUBST(PLAT_OBJS)
+ AC_SUBST(CFLAGS)
AC_SUBST(CFLAGS_DEBUG)
AC_SUBST(CFLAGS_OPTIMIZE)
AC_SUBST(CFLAGS_WARNING)
+ AC_SUBST(EXTRA_CFLAGS)
+
+ AC_SUBST(LDFLAGS)
+ AC_SUBST(LDFLAGS_DEBUG)
+ AC_SUBST(LDFLAGS_OPTIMIZE)
+ AC_SUBST(CC_SEARCH_FLAGS)
+ AC_SUBST(LD_SEARCH_FLAGS)
+
+ AC_SUBST(STLIB_LD)
+ AC_SUBST(SHLIB_LD)
+ AC_SUBST(TCL_SHLIB_LD_EXTRAS)
+ AC_SUBST(TK_SHLIB_LD_EXTRAS)
+ AC_SUBST(SHLIB_LD_FLAGS)
+ AC_SUBST(SHLIB_LD_LIBS)
+ AC_SUBST(SHLIB_CFLAGS)
+ AC_SUBST(SHLIB_SUFFIX)
+
+ AC_SUBST(MAKE_LIB)
+ AC_SUBST(MAKE_STUB_LIB)
+ AC_SUBST(INSTALL_LIB)
+ AC_SUBST(INSTALL_STUB_LIB)
+ AC_SUBST(RANLIB)
])
#--------------------------------------------------------------------
#
# Determine which interface to use to talk to the serial port.
# Note that #include lines must begin in leftmost column for
-# some compilers to recognize them as preprocessor directives.
+# some compilers to recognize them as preprocessor directives,
+# and some build environments have stdin not pointing at a
+# pseudo-terminal (usually /dev/null instead.)
#
# Arguments:
# none
# Results:
#
# Defines only one of the following vars:
+# HAVE_SYS_MODEM_H
# USE_TERMIOS
# USE_TERMIO
# USE_SGTTY
#--------------------------------------------------------------------
AC_DEFUN(SC_SERIAL_PORT, [
+ AC_CHECK_HEADERS(sys/modem.h)
AC_MSG_CHECKING([termios vs. termio vs. sgtty])
-
+ AC_CACHE_VAL(tcl_cv_api_serial, [
AC_TRY_RUN([
#include <termios.h>
-main()
-{
+int main() {
struct termios t;
if (tcgetattr(0, &t) == 0) {
cfsetospeed(&t, 0);
return 0;
}
return 1;
-}], tk_ok=termios, tk_ok=no, tk_ok=no)
-
- if test $tk_ok = termios; then
- AC_DEFINE(USE_TERMIOS)
- else
+}], tcl_cv_api_serial=termios, tcl_cv_api_serial=no, tcl_cv_api_serial=no)
+ if test $tcl_cv_api_serial = no ; then
AC_TRY_RUN([
#include <termio.h>
-main()
-{
+int main() {
struct termio t;
if (ioctl(0, TCGETA, &t) == 0) {
t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
return 0;
}
return 1;
- }], tk_ok=termio, tk_ok=no, tk_ok=no)
-
- if test $tk_ok = termio; then
- AC_DEFINE(USE_TERMIO)
- else
+}], tcl_cv_api_serial=termio, tcl_cv_api_serial=no, tcl_cv_api_serial=no)
+ fi
+ if test $tcl_cv_api_serial = no ; then
AC_TRY_RUN([
#include <sgtty.h>
-main()
-{
+int main() {
struct sgttyb t;
if (ioctl(0, TIOCGETP, &t) == 0) {
t.sg_ospeed = 0;
return 0;
}
return 1;
-}], tk_ok=sgtty, tk_ok=none, tk_ok=none)
- if test $tk_ok = sgtty; then
- AC_DEFINE(USE_SGTTY)
+}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=no, tcl_cv_api_serial=no)
fi
+ if test $tcl_cv_api_serial = no ; then
+ AC_TRY_RUN([
+#include <termios.h>
+#include <errno.h>
+
+int main() {
+ struct termios t;
+ if (tcgetattr(0, &t) == 0
+ || errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
+ cfsetospeed(&t, 0);
+ t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
+ return 0;
+ }
+ return 1;
+}], tcl_cv_api_serial=termios, tcl_cv_api_serial=no, tcl_cv_api_serial=no)
fi
+ if test $tcl_cv_api_serial = no; then
+ AC_TRY_RUN([
+#include <termio.h>
+#include <errno.h>
+
+int main() {
+ struct termio t;
+ if (ioctl(0, TCGETA, &t) == 0
+ || errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
+ t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
+ return 0;
+ }
+ return 1;
+ }], tcl_cv_api_serial=termio, tcl_cv_api_serial=no, tcl_cv_api_serial=no)
fi
- AC_MSG_RESULT($tk_ok)
+ if test $tcl_cv_api_serial = no; then
+ AC_TRY_RUN([
+#include <sgtty.h>
+#include <errno.h>
+
+int main() {
+ struct sgttyb t;
+ if (ioctl(0, TIOCGETP, &t) == 0
+ || errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
+ t.sg_ospeed = 0;
+ t.sg_flags |= ODDP | EVENP | RAW;
+ return 0;
+ }
+ return 1;
+}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=none, tcl_cv_api_serial=none)
+ fi])
+ case $tcl_cv_api_serial in
+ termios) AC_DEFINE(USE_TERMIOS);;
+ termio) AC_DEFINE(USE_TERMIO);;
+ sgtty) AC_DEFINE(USE_SGTTY);;
+ esac
+ AC_MSG_RESULT($tcl_cv_api_serial)
])
#--------------------------------------------------------------------
#--------------------------------------------------------------------
AC_DEFUN(SC_MISSING_POSIX_HEADERS, [
-
AC_MSG_CHECKING(dirent.h)
AC_TRY_LINK([#include <sys/types.h>
#include <dirent.h>], [
fi
AC_MSG_RESULT($tcl_ok)
- AC_CHECK_HEADER(errno.h, , AC_DEFINE(NO_ERRNO_H))
- AC_CHECK_HEADER(float.h, , AC_DEFINE(NO_FLOAT_H))
- AC_CHECK_HEADER(values.h, , AC_DEFINE(NO_VALUES_H))
- AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H))
+ AC_CHECK_HEADER(errno.h, , [AC_DEFINE(NO_ERRNO_H)])
+ AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H)])
+ AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H)])
+ AC_CHECK_HEADER(limits.h, , [AC_DEFINE(NO_LIMITS_H)])
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
AC_DEFINE(NO_STRING_H)
fi
- AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H))
- AC_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H))
+ AC_CHECK_HEADER(sys/wait.h, , [AC_DEFINE(NO_SYS_WAIT_H)])
+ AC_CHECK_HEADER(dlfcn.h, , [AC_DEFINE(NO_DLFCN_H)])
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
fi
if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then
AC_MSG_CHECKING(for X11 header files)
- XINCLUDES="# no special path needed"
- AC_TRY_CPP([#include <X11/Intrinsic.h>], , XINCLUDES="nope")
- if test "$XINCLUDES" = nope; then
+ found_xincludes="no"
+ AC_TRY_CPP([#include <X11/Intrinsic.h>], found_xincludes="yes", found_xincludes="no")
+ if test "$found_xincludes" = "no"; then
dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include"
for i in $dirs ; do
if test -r $i/X11/Intrinsic.h; then
AC_MSG_RESULT($i)
XINCLUDES=" -I$i"
+ found_xincludes="yes"
break
fi
done
fi
else
if test "$x_includes" != ""; then
- XINCLUDES=-I$x_includes
- else
- XINCLUDES="# no special path needed"
+ XINCLUDES="-I$x_includes"
+ found_xincludes="yes"
fi
fi
- if test "$XINCLUDES" = nope; then
+ if test found_xincludes = "no"; then
AC_MSG_RESULT(couldn't find any!)
- XINCLUDES="# no include files found"
fi
if test "$no_x" = yes; then
])
#--------------------------------------------------------------------
-# SC_HAVE_VFORK
-#
-# Check to see whether the system provides a vfork kernel call.
-# If not, then use fork instead. Also, check for a problem with
-# vforks and signals that can cause core dumps if a vforked child
-# resets a signal handler. If the problem exists, then use fork
-# instead of vfork.
-#
-# Arguments:
-# none
-#
-# Results:
-#
-# Defines some of the following vars:
-# vfork (=fork)
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(SC_HAVE_VFORK, [
- AC_TYPE_SIGNAL()
- AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0)
- if test "$tcl_ok" = 1; then
- AC_MSG_CHECKING([vfork/signal bug]);
- AC_TRY_RUN([
-#include <stdio.h>
-#include <signal.h>
-#include <sys/wait.h>
-int gotSignal = 0;
-sigProc(sig)
- int sig;
-{
- gotSignal = 1;
-}
-main()
-{
- int pid, sts;
- (void) signal(SIGCHLD, sigProc);
- pid = vfork();
- if (pid < 0) {
- exit(1);
- } else if (pid == 0) {
- (void) signal(SIGCHLD, SIG_DFL);
- _exit(0);
- } else {
- (void) wait(&sts);
- }
- exit((gotSignal) ? 0 : 1);
-}], tcl_ok=1, tcl_ok=0, tcl_ok=0)
-
- if test "$tcl_ok" = 1; then
- AC_MSG_RESULT(ok)
- else
- AC_MSG_RESULT([buggy, using fork instead])
- fi
- fi
- rm -f core
- if test "$tcl_ok" = 0; then
- AC_DEFINE(vfork, fork)
- fi
-])
-
-#--------------------------------------------------------------------
# SC_TIME_HANLDER
#
# Checks how the system deals with time.h, what time structures
AC_HEADER_TIME
AC_STRUCT_TIMEZONE
+ AC_CHECK_FUNCS(gmtime_r localtime_r)
+
AC_MSG_CHECKING([tm_tzadj in struct tm])
- AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;],
- [AC_DEFINE(HAVE_TM_TZADJ)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
+ AC_CACHE_VAL(tcl_cv_member_tm_tzadj,
+ AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;],
+ tcl_cv_member_tm_tzadj=yes, tcl_cv_member_tm_tzadj=no))
+ AC_MSG_RESULT($tcl_cv_member_tm_tzadj)
+ if test $tcl_cv_member_tm_tzadj = yes ; then
+ AC_DEFINE(HAVE_TM_TZADJ)
+ fi
AC_MSG_CHECKING([tm_gmtoff in struct tm])
- AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;],
- [AC_DEFINE(HAVE_TM_GMTOFF)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
+ AC_CACHE_VAL(tcl_cv_member_tm_gmtoff,
+ AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;],
+ tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no))
+ AC_MSG_RESULT($tcl_cv_member_tm_gmtoff)
+ if test $tcl_cv_member_tm_gmtoff = yes ; then
+ AC_DEFINE(HAVE_TM_GMTOFF)
+ fi
#
# Its important to include time.h in this check, as some systems
# (like convex) have timezone functions, etc.
#
- have_timezone=no
AC_MSG_CHECKING([long timezone variable])
- AC_TRY_COMPILE([#include <time.h>],
+ AC_CACHE_VAL(tcl_cv_var_timezone,
+ AC_TRY_COMPILE([#include <time.h>],
[extern long timezone;
timezone += 1;
exit (0);],
- [have_timezone=yes
+ tcl_cv_timezone_long=yes, tcl_cv_timezone_long=no))
+ AC_MSG_RESULT($tcl_cv_timezone_long)
+ if test $tcl_cv_timezone_long = yes ; then
+ AC_DEFINE(HAVE_TIMEZONE_VAR)
+ else
+ #
+ # On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
+ #
+ AC_MSG_CHECKING([time_t timezone variable])
+ AC_CACHE_VAL(tcl_cv_timezone_time,
+ AC_TRY_COMPILE([#include <time.h>],
+ [extern time_t timezone;
+ timezone += 1;
+ exit (0);],
+ tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no))
+ AC_MSG_RESULT($tcl_cv_timezone_time)
+ if test $tcl_cv_timezone_time = yes ; then
AC_DEFINE(HAVE_TIMEZONE_VAR)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
-
- #
- # On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
- #
- if test "$have_timezone" = no; then
- AC_MSG_CHECKING([time_t timezone variable])
- AC_TRY_COMPILE([#include <time.h>],
- [extern time_t timezone;
- timezone += 1;
- exit (0);],
- [AC_DEFINE(HAVE_TIMEZONE_VAR)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
- fi
-
- #
- # On some systems (eg Solaris 2.5.1), timezone is not declared in
- # time.h unless you jump through hoops. Instead of that, we just
- # declare it ourselves when necessary.
- #
- if test "$have_timezone" = yes; then
- AC_MSG_CHECKING(for timezone declaration)
- changequote(<<,>>)
- tzrx='^[ ]*extern.*timezone'
- changequote([,])
- AC_EGREP_HEADER($tzrx, time.h, [
- AC_DEFINE(HAVE_TIMEZONE_DECL)
- AC_MSG_RESULT(found)], AC_MSG_RESULT(missing))
- fi
-
- #
- # AIX does not have a timezone field in struct tm. When the AIX bsd
- # library is used, the timezone global and the gettimeofday methods are
- # to be avoided for timezone deduction instead, we deduce the timezone
- # by comparing the localtime result on a known GMT value.
- #
-
- if test "`uname -s`" = "AIX" ; then
- AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes)
- if test $libbsd = yes; then
- AC_DEFINE(USE_DELTA_FOR_TZ)
fi
fi
])
AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
if test "$tcl_strtod" = 1; then
AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs])
- AC_TRY_RUN([
- extern double strtod();
- int main()
- {
- char *string = "NaN", *spaceString = " ";
- char *term;
- double value;
- value = strtod(string, &term);
- if ((term != string) && (term[-1] == 0)) {
- exit(1);
- }
- value = strtod(spaceString, &term);
- if (term == (spaceString+1)) {
- exit(1);
- }
- exit(0);
- }], tcl_ok=1, tcl_ok=0, tcl_ok=0)
- if test "$tcl_ok" = 1; then
+ AC_CACHE_VAL(tcl_cv_strtod_buggy,[
+ AC_TRY_RUN([
+ extern double strtod();
+ int main() {
+ char *infString="Inf", *nanString="NaN", *spaceString=" ";
+ char *term;
+ double value;
+ value = strtod(infString, &term);
+ if ((term != infString) && (term[-1] == 0)) {
+ exit(1);
+ }
+ value = strtod(nanString, &term);
+ if ((term != nanString) && (term[-1] == 0)) {
+ exit(1);
+ }
+ value = strtod(spaceString, &term);
+ if (term == (spaceString+1)) {
+ exit(1);
+ }
+ exit(0);
+ }], tcl_cv_strtod_buggy=1, tcl_cv_strtod_buggy=0, tcl_cv_strtod_buggy=0)])
+ if test "$tcl_cv_strtod_buggy" = 1; then
AC_MSG_RESULT(ok)
else
AC_MSG_RESULT(buggy)
AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"])
#--------------------------------------------------------------------
- # On AIX systems, libbsd.a has to be linked in to support
- # non-blocking file IO. This library has to be linked in after
- # the MATH_LIBS or it breaks the pow() function. The way to
- # insure proper sequencing, is to add it to the tail of MATH_LIBS.
- # This library also supplies gettimeofday.
- #--------------------------------------------------------------------
-
- libbsd=no
- if test "`uname -s`" = "AIX" ; then
- AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes)
- if test $libbsd = yes; then
- MATH_LIBS="$MATH_LIBS -lbsd"
- fi
- fi
-
-
- #--------------------------------------------------------------------
# Interactive UNIX requires -linet instead of -lsocket, plus it
# needs net/errno.h to define the socket-related error codes.
#--------------------------------------------------------------------
AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"])
- AC_CHECK_HEADER(net/errno.h, AC_DEFINE(HAVE_NET_ERRNO_H))
+ AC_CHECK_HEADER(net/errno.h, [AC_DEFINE(HAVE_NET_ERRNO_H)])
#--------------------------------------------------------------------
# Check for the existence of the -lsocket and -lnsl libraries.
# if -lsocket doesn't work by itself.
#--------------------------------------------------------------------
- # CYGNUS LOCAL: Store any socket library(ies) in the cache, and don't
- # mess up the cache values of the functions we check for.
- AC_CACHE_CHECK([for socket libraries], tcl_cv_lib_sockets,
- [tcl_cv_lib_sockets=
- tcl_checkBoth=0
- unset ac_cv_func_connect
- AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1)
- if test "$tcl_checkSocket" = 1; then
- unset ac_cv_func_connect
- AC_CHECK_LIB(socket, main, tcl_cv_lib_sockets="-lsocket",
- tcl_checkBoth=1)
- fi
- if test "$tcl_checkBoth" = 1; then
- tcl_oldLibs=$LIBS
- LIBS="$LIBS -lsocket -lnsl"
- unset ac_cv_func_accept
- AC_CHECK_FUNC(accept,
- [tcl_checkNsl=0
- tcl_cv_lib_sockets="-lsocket -lnsl"])
- unset ac_cv_func_accept
- LIBS=$tcl_oldLibs
- fi
- unset ac_cv_func_gethostbyname
- tcl_oldLibs=$LIBS
- LIBS="$LIBS $tcl_cv_lib_sockets"
- AC_CHECK_FUNC(gethostbyname, ,
- [AC_CHECK_LIB(nsl, main,
- [tcl_cv_lib_sockets="$tcl_cv_lib_sockets -lnsl"])])
- unset ac_cv_func_gethostbyname
- LIBS=$tcl_oldLIBS
- ])
- test -z "$tcl_cv_lib_sockets" || LIBS="$LIBS $tcl_cv_lib_sockets"
+ tcl_checkBoth=0
+ AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1)
+ if test "$tcl_checkSocket" = 1; then
+ AC_CHECK_FUNC(setsockopt, , [AC_CHECK_LIB(socket, setsockopt,
+ LIBS="$LIBS -lsocket", tcl_checkBoth=1)])
+ fi
+ if test "$tcl_checkBoth" = 1; then
+ tk_oldLibs=$LIBS
+ LIBS="$LIBS -lsocket -lnsl"
+ AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs])
+ fi
+ AC_CHECK_FUNC(gethostbyname, , [AC_CHECK_LIB(nsl, gethostbyname,
+ [LIBS="$LIBS -lnsl"])])
# Don't perform the eval of the libraries here because DL_LIBS
# won't be set until we call SC_CONFIG_CFLAGS
AC_SUBST(MATH_LIBS)
])
-dnl CYGNUS LOCAL: This gets the right posix flag for gcc
-
-AC_DEFUN(CY_AC_TCL_LYNX_POSIX,
-[AC_REQUIRE([AC_PROG_CC])AC_REQUIRE([AC_PROG_CPP])
-AC_MSG_CHECKING([to see if this is LynxOS])
-AC_CACHE_VAL(ac_cv_os_lynx,
-[AC_EGREP_CPP(yes,
-[/*
- * The old Lynx "cc" only defines "Lynx", but the newer one uses "__Lynx__"
- */
-#if defined(__Lynx__) || defined(Lynx)
-yes
-#endif
-], ac_cv_os_lynx=yes, ac_cv_os_lynx=no)])
-#
-if test "$ac_cv_os_lynx" = "yes" ; then
- AC_MSG_RESULT(yes)
- AC_DEFINE(LYNX)
- AC_MSG_CHECKING([whether -mposix or -X is available])
- AC_CACHE_VAL(ac_cv_c_posix_flag,
- [AC_TRY_COMPILE(,[
- /*
- * This flag varies depending on how old the compiler is.
- * -X is for the old "cc" and "gcc" (based on 1.42).
- * -mposix is for the new gcc (at least 2.5.8).
- */
- #if defined(__GNUC__) && __GNUC__ >= 2
- choke me
- #endif
- ], ac_cv_c_posix_flag=" -mposix", ac_cv_c_posix_flag=" -X")])
- CC="$CC $ac_cv_c_posix_flag"
- AC_MSG_RESULT($ac_cv_c_posix_flag)
- else
- AC_MSG_RESULT(no)
-fi
-])
+#--------------------------------------------------------------------
+# SC_TCL_EARLY_FLAGS
+#
+# Check for what flags are needed to be passed so the correct OS
+# features are available.
+#
+# Arguments:
+# None
+#
+# Results:
+#
+# Might define the following vars:
+# _ISOC99_SOURCE
+# _LARGEFILE64_SOURCE
+#
+#--------------------------------------------------------------------
+
+AC_DEFUN(SC_TCL_EARLY_FLAG,[
+ AC_CACHE_VAL([tcl_cv_flag_]translit($1,[A-Z],[a-z]),
+ AC_TRY_COMPILE([$2], $3, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no,
+ AC_TRY_COMPILE([[#define ]$1[ 1
+]$2], $3,
+ [tcl_cv_flag_]translit($1,[A-Z],[a-z])=yes,
+ [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no)))
+ if test ["x${tcl_cv_flag_]translit($1,[A-Z],[a-z])[}" = "xyes"] ; then
+ AC_DEFINE($1)
+ tcl_flags="$tcl_flags $1"
+ fi])
+
+AC_DEFUN(SC_TCL_EARLY_FLAGS,[
+ AC_MSG_CHECKING([for required early compiler flags])
+ tcl_flags=""
+ SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
+ [char *p = (char *)strtoll; char *q = (char *)strtoull;])
+ SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
+ [struct stat64 buf; int i = stat64("/", &buf);])
+ if test "x${tcl_flags}" = "x" ; then
+ AC_MSG_RESULT(none)
+ else
+ AC_MSG_RESULT(${tcl_flags})
+ fi])
+
+#--------------------------------------------------------------------
+# SC_TCL_64BIT_FLAGS
+#
+# Check for what is defined in the way of 64-bit features.
+#
+# Arguments:
+# None
+#
+# Results:
+#
+# Might define the following vars:
+# TCL_WIDE_INT_IS_LONG
+# TCL_WIDE_INT_TYPE
+# HAVE_STRUCT_DIRENT64
+# HAVE_STRUCT_STAT64
+# HAVE_TYPE_OFF64_T
+#
+#--------------------------------------------------------------------
+
+AC_DEFUN(SC_TCL_64BIT_FLAGS, [
+ AC_MSG_CHECKING([for 64-bit integer type])
+ AC_CACHE_VAL(tcl_cv_type_64bit,[
+ tcl_cv_type_64bit=none
+ # See if the compiler knows natively about __int64
+ AC_TRY_COMPILE(,[__int64 value = (__int64) 0;],
+ tcl_type_64bit=__int64, tcl_type_64bit="long long")
+ # See if we should use long anyway Note that we substitute in the
+ # type that is our current guess for a 64-bit type inside this check
+ # program, so it should be modified only carefully...
+ AC_TRY_RUN([#include <unistd.h>
+ int main() {exit(!(sizeof(]${tcl_type_64bit}[) > sizeof(long)));}
+ ], tcl_cv_type_64bit=${tcl_type_64bit},:,:)])
+ if test "${tcl_cv_type_64bit}" = none ; then
+ AC_DEFINE(TCL_WIDE_INT_IS_LONG)
+ AC_MSG_RESULT(using long)
+ else
+ AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit})
+ AC_MSG_RESULT(${tcl_cv_type_64bit})
+
+ # Now check for auxiliary declarations
+ AC_MSG_CHECKING([for struct dirent64])
+ AC_CACHE_VAL(tcl_cv_struct_dirent64,[
+ AC_TRY_COMPILE([#include <sys/types.h>
+#include <sys/dirent.h>],[struct dirent64 p;],
+ tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)])
+ if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
+ AC_DEFINE(HAVE_STRUCT_DIRENT64)
+ fi
+ AC_MSG_RESULT(${tcl_cv_struct_dirent64})
+
+ AC_MSG_CHECKING([for struct stat64])
+ AC_CACHE_VAL(tcl_cv_struct_stat64,[
+ AC_TRY_COMPILE([#include <sys/stat.h>],[struct stat64 p;
+],
+ tcl_cv_struct_stat64=yes,tcl_cv_struct_stat64=no)])
+ if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
+ AC_DEFINE(HAVE_STRUCT_STAT64)
+ fi
+ AC_MSG_RESULT(${tcl_cv_struct_stat64})
+
+ AC_MSG_CHECKING([for off64_t])
+ AC_CACHE_VAL(tcl_cv_type_off64_t,[
+ AC_TRY_COMPILE([#include <sys/types.h>],[off64_t offset;
+],
+ tcl_cv_type_off64_t=yes,tcl_cv_type_off64_t=no)])
+ if test "x${tcl_cv_type_off64_t}" = "xyes" ; then
+ AC_DEFINE(HAVE_TYPE_OFF64_T)
+ fi
+ AC_MSG_RESULT(${tcl_cv_type_off64_t})
+ fi])
# $Id$
# This file is the basis for a binary Tcl RPM for Linux.
-%define version 8.3.2
+%define version 8.4.1
%define directory /usr/local
Summary: Tcl scripting language development environment
Release: 1
Copyright: BSD
Group: Development/Languages
-Source: ftp://ftp.scriptics.com/pub/tcl/tcl8_3/tcl%{version}.tar.gz
-URL: http://dev.scriptics.com/
-Packager: Scriptics Corporation
+Source: http://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz
+URL: http://www.tcl.tk/
+Packager: Carina
Buildroot: /var/tmp/%{name}%{version}
%description
#include "tcl.h"
-/*
- * The following variable is a special hack that is needed in order for
- * Sun shared libraries to be used for Tcl.
- */
-
-extern int matherr();
-int *tclDummyMathPtr = (int *) matherr;
-
-
#ifdef TCL_TEST
#include "tclInt.h"
* then no user-specific startup file will be run under any conditions.
*/
+#ifdef DJGPP
+ Tcl_SetVar(interp, "tcl_rcFileName", "~/tclsh.rc", TCL_GLOBAL_ONLY);
+#else
Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclshrc", TCL_GLOBAL_ONLY);
+#endif
return TCL_OK;
}
-
-
# -D flags for use with the C compiler.
TCL_DEFS='@DEFS@'
-# Extensions written in gcc need -fwritable-strings. Use TCL_CFLAGS for
-# any other flags required for extensions.
-TCL_CFLAGS='@CFLAGS@'
-
# If TCL was built with debugging symbols, generated libraries contain
# this string at the end of the library name (before the extension).
TCL_DBGX=@TCL_DBGX@
# The name of the Tcl library (may be either a .a file or a shared library):
TCL_LIB_FILE='@TCL_LIB_FILE@'
-# The fullpath of the Tcl library (used for dependency checking)
-TCL_LIB_FULL_PATH='@TCL_LIB_FULL_PATH@'
-
# Flag to indicate whether shared libraries need export files.
TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@
# Base command to use for combining object files into a shared library:
TCL_SHLIB_LD='@SHLIB_LD@'
-# Base command to use for combining object files into a shared library:
+# Base command to use for combining object files into a static library:
TCL_STLIB_LD='@STLIB_LD@'
# Either '$LIBS' (if dependent libraries should be included when linking
# Suffix to use for the name of a shared library.
TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@'
-# Suffix to use in the name of an unshared library.
-# FIXME: Comments in tcl.m4 about this var are incorrect!
-TCL_LIB_SUFFIX='@TCL_LIB_SUFFIX@'
-
# Library file(s) to include in tclsh and other base applications
# in order to provide facilities needed by DLOBJ above.
TCL_DL_LIBS='@DL_LIBS@'
# run-time dynamic linker where to look for shared libraries such as
# libtcl.so. Used when linking applications. Only works if there
# is a variable "LIB_RUNTIME_DIR" defined in the Makefile.
-TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@'
+TCL_CC_SEARCH_FLAGS='@CC_SEARCH_FLAGS@'
+TCL_LD_SEARCH_FLAGS='@LD_SEARCH_FLAGS@'
# Additional object files linked with Tcl to provide compatibility
# with standard facilities from ANSI C or POSIX.
# installed directory.
TCL_LIB_SPEC='@TCL_LIB_SPEC@'
+# String to pass to the compiler so that an extension can
+# find installed Tcl headers.
+TCL_INCLUDE_SPEC='@TCL_INCLUDE_SPEC@'
+
# Indicates whether a version numbers should be used in -l switches
# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means
# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for
# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'
-# Vendor prefix to be added to lib names
-TCL_VENDOR_PREFIX=@VENDORPREFIX@
+# Flag, 1: we built Tcl with threads enables, 0 we didn't
+TCL_THREADS=@TCL_THREADS@
#ifdef HAVE_EXEC_AOUT_H
# include <sys/exec_aout.h>
#endif
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#else
+# include "../compat/unistd.h"
+#endif
/*
* Some systems describe the a.out header in sys/exec.h, and some in
* Type of the dictionary function that begins each load module.
*/
-typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((char * symbol));
+typedef Tcl_PackageInitProc * (* DictFn) _ANSI_ARGS_ ((CONST char * symbol));
/*
* Prototypes for procedures referenced only in this file:
*/
-static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName,
+static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr,
Tcl_DString * buf));
static void UnlinkSymbolTable _ANSI_ARGS_((void));
\f
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
+ * message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code (UTF-8). */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
- char * inputSymbolTable; /* Name of the file containing the
+ char * inputSymbolTable; /* Name of the file containing the
* symbol table from the last link. */
- Tcl_DString linkCommandBuf; /* Command to do the run-time relocation
+ Tcl_DString linkCommandBuf; /* Command to do the run-time relocation
* of the module.*/
- char * linkCommand;
- char relocatedFileName [L_tmpnam];
+ char * linkCommand;
+ char relocatedFileName [L_tmpnam];
/* Name of the file holding the relocated */
/* text of the module */
- int relocatedFd; /* File descriptor of the file holding
+ int relocatedFd; /* File descriptor of the file holding
* relocated text */
- struct exec relocatedHead; /* Header of the relocated text */
- unsigned long relocatedSize; /* Size of the relocated text */
- char * startAddress; /* Starting address of the module */
- DictFn dictionary; /* Dictionary function in the load module */
- int status; /* Status return from Tcl_ calls */
- char * p;
-
- *clientDataPtr = NULL;
-
- /* Find the file that contains the symbols for the run-time link. */
-
- if (SymbolTableFile != NULL) {
- inputSymbolTable = SymbolTableFile;
- } else if (tclExecutableName == NULL) {
- Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC);
- return TCL_ERROR;
- } else {
- inputSymbolTable = tclExecutableName;
- }
-
- /* Construct the `ld' command that builds the relocated module */
-
- tmpnam (relocatedFileName);
- Tcl_DStringInit (&linkCommandBuf);
- Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1);
- Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1);
+ struct exec relocatedHead; /* Header of the relocated text */
+ unsigned long relocatedSize;/* Size of the relocated text */
+ char * startAddress; /* Starting address of the module */
+ int status; /* Status return from Tcl_ calls */
+ char * p;
+
+ /* Find the file that contains the symbols for the run-time link. */
+
+ if (SymbolTableFile != NULL) {
+ inputSymbolTable = SymbolTableFile;
+ } else if (tclExecutableName == NULL) {
+ Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC);
+ return TCL_ERROR;
+ } else {
+ inputSymbolTable = tclExecutableName;
+ }
+
+ /* Construct the `ld' command that builds the relocated module */
+
+ tmpnam (relocatedFileName);
+ Tcl_DStringInit (&linkCommandBuf);
+ Tcl_DStringAppend (&linkCommandBuf, "exec ld -o ", -1);
+ Tcl_DStringAppend (&linkCommandBuf, relocatedFileName, -1);
#if defined(__mips) || defined(mips)
- Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1);
+ Tcl_DStringAppend (&linkCommandBuf, " -G 0 ", -1);
#endif
- Tcl_DStringAppend (&linkCommandBuf, " -u TclLoadDictionary_", -1);
- TclGuessPackageName(fileName, &linkCommandBuf);
- Tcl_DStringAppend (&linkCommandBuf, " -A ", -1);
- Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1);
- Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1);
- Tcl_DStringAppend (&linkCommandBuf, fileName, -1);
- Tcl_DStringAppend (&linkCommandBuf, " ", -1);
- if (FindLibraries (interp, fileName, &linkCommandBuf) != TCL_OK) {
+ Tcl_DStringAppend (&linkCommandBuf, " -u TclLoadDictionary_", -1);
+ TclGuessPackageName(Tcl_GetString(pathPtr), &linkCommandBuf);
+ Tcl_DStringAppend (&linkCommandBuf, " -A ", -1);
+ Tcl_DStringAppend (&linkCommandBuf, inputSymbolTable, -1);
+ Tcl_DStringAppend (&linkCommandBuf, " -N -T XXXXXXXX ", -1);
+ Tcl_DStringAppend (&linkCommandBuf, Tcl_GetString(pathPtr), -1);
+ Tcl_DStringAppend (&linkCommandBuf, " ", -1);
+
+ if (FindLibraries (interp, pathPtr, &linkCommandBuf) != TCL_OK) {
+ Tcl_DStringFree (&linkCommandBuf);
+ return TCL_ERROR;
+ }
+
+ linkCommand = Tcl_DStringValue (&linkCommandBuf);
+
+ /* Determine the starting address, and plug it into the command */
+
+ startAddress = (char *) (((unsigned long) sbrk (0)
+ + TCL_LOADSHIM + TCL_LOADALIGN - 1)
+ & (- TCL_LOADALIGN));
+ p = strstr (linkCommand, "-T") + 3;
+ sprintf (p, "%08lx", (long) startAddress);
+ p [8] = ' ';
+
+ /* Run the linker */
+
+ status = Tcl_Eval (interp, linkCommand);
Tcl_DStringFree (&linkCommandBuf);
- return TCL_ERROR;
- }
- linkCommand = Tcl_DStringValue (&linkCommandBuf);
-
- /* Determine the starting address, and plug it into the command */
-
- startAddress = (char *) (((unsigned long) sbrk (0)
- + TCL_LOADSHIM + TCL_LOADALIGN - 1)
- & (- TCL_LOADALIGN));
- p = strstr (linkCommand, "-T") + 3;
- sprintf (p, "%08lx", (long) startAddress);
- p [8] = ' ';
-
- /* Run the linker */
-
- status = Tcl_Eval (interp, linkCommand);
- Tcl_DStringFree (&linkCommandBuf);
- if (status != 0) {
- return TCL_ERROR;
- }
-
- /* Open the linker's result file and read the header */
-
- relocatedFd = open (relocatedFileName, O_RDONLY);
- if (relocatedFd < 0) {
- goto ioError;
- }
- status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead);
- if (status < sizeof relocatedHead) {
- goto ioError;
- }
-
- /* Check the magic number */
-
- if (relocatedHead.a_magic != OMAGIC) {
- Tcl_AppendResult (interp, "bad magic number in intermediate file \"",
- relocatedFileName, "\"", (char *) NULL);
- goto failure;
- }
-
- /* Make sure that memory allocation is still consistent */
-
- if ((unsigned long) sbrk (0) > (unsigned long) startAddress) {
- Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.",
- TCL_STATIC);
- goto failure;
- }
-
- /* Make sure that the relocated module's size is reasonable */
-
- relocatedSize = relocatedHead.a_text + relocatedHead.a_data
- + relocatedHead.a_bss;
- if (relocatedSize > TCL_LOADMAX) {
- Tcl_SetResult (interp, "module too big to load", TCL_STATIC);
- goto failure;
- }
-
- /* Advance the break to protect the loaded module */
-
- (void) brk (startAddress + relocatedSize);
-
- /* Seek to the start of the module's text */
-
+ if (status != 0) {
+ return TCL_ERROR;
+ }
+
+ /* Open the linker's result file and read the header */
+
+ relocatedFd = open (relocatedFileName, O_RDONLY);
+ if (relocatedFd < 0) {
+ goto ioError;
+ }
+ status= read (relocatedFd, (char *) & relocatedHead, sizeof relocatedHead);
+ if (status < sizeof relocatedHead) {
+ goto ioError;
+ }
+
+ /* Check the magic number */
+
+ if (relocatedHead.a_magic != OMAGIC) {
+ Tcl_AppendResult (interp, "bad magic number in intermediate file \"",
+ relocatedFileName, "\"", (char *) NULL);
+ goto failure;
+ }
+
+ /* Make sure that memory allocation is still consistent */
+
+ if ((unsigned long) sbrk (0) > (unsigned long) startAddress) {
+ Tcl_SetResult (interp, "can't load, memory allocation is inconsistent.",
+ TCL_STATIC);
+ goto failure;
+ }
+
+ /* Make sure that the relocated module's size is reasonable */
+
+ relocatedSize = relocatedHead.a_text + relocatedHead.a_data
+ + relocatedHead.a_bss;
+ if (relocatedSize > TCL_LOADMAX) {
+ Tcl_SetResult (interp, "module too big to load", TCL_STATIC);
+ goto failure;
+ }
+
+ /* Advance the break to protect the loaded module */
+
+ (void) brk (startAddress + relocatedSize);
+
+ /*
+ * Seek to the start of the module's text.
+ *
+ * Note that this does not really work with large files (i.e. where
+ * lseek64 exists and is different to lseek), but anyone trying to
+ * dynamically load a binary that is larger than what can fit in
+ * addressable memory is in trouble anyway...
+ */
+
#if defined(__mips) || defined(mips)
- status = lseek (relocatedFd,
- (off_t) N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o),
- SEEK_SET);
+ status = lseek (relocatedFd,
+ (off_t) N_TXTOFF (relocatedHead.ex_f, relocatedHead.ex_o),
+ SEEK_SET);
#else
- status = lseek (relocatedFd, (off_t) N_TXTOFF (relocatedHead), SEEK_SET);
+ status = lseek (relocatedFd, (off_t) N_TXTOFF (relocatedHead), SEEK_SET);
#endif
- if (status < 0) {
- goto ioError;
- }
-
- /* Read in the module's text and data */
-
- relocatedSize = relocatedHead.a_text + relocatedHead.a_data;
- if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) {
- brk (startAddress);
- ioError:
- Tcl_AppendResult (interp, "error on intermediate file \"",
- relocatedFileName, "\": ", Tcl_PosixError (interp),
- (char *) NULL);
- failure:
- (void) unlink (relocatedFileName);
- return TCL_ERROR;
- }
-
- /* Close the intermediate file. */
-
- (void) close (relocatedFd);
-
- /* Arrange things so that intermediate symbol tables eventually get
- * deleted. */
-
- if (SymbolTableFile != NULL) {
- UnlinkSymbolTable ();
- } else {
- atexit (UnlinkSymbolTable);
- }
- SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
- strcpy (SymbolTableFile, relocatedFileName);
-
- /* Look up the entry points in the load module's dictionary. */
-
- dictionary = (DictFn) startAddress;
- *proc1Ptr = dictionary (sym1);
- *proc2Ptr = dictionary (sym2);
-
- return TCL_OK;
+ if (status < 0) {
+ goto ioError;
+ }
+
+ /* Read in the module's text and data */
+
+ relocatedSize = relocatedHead.a_text + relocatedHead.a_data;
+ if (read (relocatedFd, startAddress, relocatedSize) < relocatedSize) {
+ brk (startAddress);
+ ioError:
+ Tcl_AppendResult (interp, "error on intermediate file \"",
+ relocatedFileName, "\": ", Tcl_PosixError (interp),
+ (char *) NULL);
+ failure:
+ (void) unlink (relocatedFileName);
+ return TCL_ERROR;
+ }
+
+ /* Close the intermediate file. */
+
+ (void) close (relocatedFd);
+
+ /* Arrange things so that intermediate symbol tables eventually get
+ * deleted. */
+
+ if (SymbolTableFile != NULL) {
+ UnlinkSymbolTable ();
+ } else {
+ atexit (UnlinkSymbolTable);
+ }
+ SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
+ strcpy (SymbolTableFile, relocatedFileName);
+
+ *loadHandle = startAddress;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ /* Look up the entry point in the load module's dictionary. */
+ DictFn dictionary = (DictFn) loadHandle;
+ return (Tcl_PackageInitProc*) dictionary(sym1);
}
+
\f
/*
*------------------------------------------------------------------------
*/
static int
-FindLibraries (interp, fileName, buf)
- Tcl_Interp * interp; /* Used for error reporting */
- char * fileName; /* Name of the load module */
- Tcl_DString * buf; /* Buffer where the -l an -L flags */
+FindLibraries (interp, pathPtr, buf)
+ Tcl_Interp * interp; /* Used for error reporting */
+ Tcl_Obj * pathPtr; /* Name of the load module */
+ Tcl_DString * buf; /* Buffer where the -l an -L flags */
{
- FILE * f; /* The load module */
- int c; /* Byte from the load module */
- char * p;
- Tcl_DString ds;
- CONST char *native;
+ FILE * f; /* The load module */
+ int c = 0; /* Byte from the load module */
+ char * p;
+ CONST char *native;
- /* Open the load module */
-
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
- f = fopen(native, "rb"); /* INTL: Native. */
- Tcl_DStringFree(&ds);
+ char *fileName = Tcl_GetString(pathPtr);
- if (f == NULL) {
- Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ",
- Tcl_PosixError (interp), (char *) NULL);
- return TCL_ERROR;
- }
-
- /* Search for the library list in the load module */
-
- p = "@LIBS: ";
- while (*p != '\0' && (c = getc (f)) != EOF) {
- if (c == *p) {
- ++p;
+ /* Open the load module */
+
+ native = Tcl_FSGetNativePath(pathPtr);
+ f = fopen(native, "rb"); /* INTL: Native. */
+
+ if (f == NULL) {
+ Tcl_AppendResult (interp, "couldn't open \"", fileName, "\": ",
+ Tcl_PosixError (interp), (char *) NULL);
+ return TCL_ERROR;
}
- else {
- p = "@LIBS: ";
- if (c == *p) {
- ++p;
- }
+
+ /* Search for the library list in the load module */
+
+ p = "@LIBS: ";
+ while (*p != '\0' && (c = getc (f)) != EOF) {
+ if (c == *p) {
+ ++p;
+ }
+ else {
+ p = "@LIBS: ";
+ if (c == *p) {
+ ++p;
+ }
+ }
+ }
+
+ /* No library list -- this must be an ill-formed module */
+
+ if (c == EOF) {
+ Tcl_AppendResult (interp, "File \"", fileName,
+ "\" is not a Tcl load module.", (char *) NULL);
+ (void) fclose (f);
+ return TCL_ERROR;
+ }
+
+ /* Accumulate the library list */
+
+ while ((c = getc (f)) != '\0' && c != EOF) {
+ char cc = c;
+ Tcl_DStringAppend (buf, &cc, 1);
}
- }
-
- /* No library list -- this must be an ill-formed module */
-
- if (c == EOF) {
- Tcl_AppendResult (interp, "File \"", fileName,
- "\" is not a Tcl load module.", (char *) NULL);
(void) fclose (f);
- return TCL_ERROR;
- }
-
- /* Accumulate the library list */
-
- while ((c = getc (f)) != '\0' && c != EOF) {
- char cc = c;
- Tcl_DStringAppend (buf, &cc, 1);
- }
- (void) fclose (f);
-
- if (c == EOF) {
- Tcl_AppendResult (interp, "Library directory in \"", fileName,
- "\" ends prematurely.", (char *) NULL);
- return TCL_ERROR;
- }
+
+ if (c == EOF) {
+ Tcl_AppendResult (interp, "Library directory in \"", fileName,
+ "\" ends prematurely.", (char *) NULL);
+ return TCL_ERROR;
+ }
- return TCL_OK;
+ return TCL_OK;
}
\f
/*
static void
UnlinkSymbolTable ()
{
- (void) unlink (SymbolTableFile);
- ckfree (SymbolTableFile);
- SymbolTableFile = NULL;
+ (void) unlink (SymbolTableFile);
+ ckfree (SymbolTableFile);
+ SymbolTableFile = NULL;
}
\f
/*
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
- char *p, *q, *r;
- int srcOff, dstOff;
+ CONST char *p, *q;
+ char *r;
- if (q = strrchr(fileName,'/')) {
+ if ((q = strrchr(fileName,'/'))) {
q++;
} else {
q = fileName;
return 1;
}
-
-
/*
*---------------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
+ * message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
VOID *handle;
- Tcl_DString newName, ds;
- char *native;
+ CONST char *native;
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
- handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); /* INTL: Native. */
- Tcl_DStringFree(&ds);
-
- *clientDataPtr = (ClientData) handle;
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load
+ * using a relative path.
+ */
+ native = Tcl_FSGetNativePath(pathPtr);
+ handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
+ if (handle == NULL) {
+ /*
+ * Let the OS loader examine the binary search path for
+ * whatever string the user gave us which hopefully refers
+ * to a file on the binary path
+ */
+ Tcl_DString ds;
+ char *fileName = Tcl_GetString(pathPtr);
+ native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
+ Tcl_DStringFree(&ds);
+ }
if (handle == NULL) {
- Tcl_AppendResult(interp, "couldn't load file \"", fileName,
- "\": ", dlerror(), (char *) NULL);
+ Tcl_AppendResult(interp, "couldn't load file \"",
+ Tcl_GetString(pathPtr),
+ "\": ", dlerror(), (char *) NULL);
return TCL_ERROR;
}
+ *unloadProcPtr = &TclpUnloadFile;
+ *loadHandle = (Tcl_LoadHandle)handle;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ CONST char *native;
+ Tcl_DString newName, ds;
+ VOID *handle = (VOID*)loadHandle;
+ Tcl_PackageInitProc *proc;
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again
* with the underscore.
*/
- native = Tcl_UtfToExternalDString(NULL, sym1, -1, &ds);
- *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
+ native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
+ proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
native);
- if (*proc1Ptr == NULL) {
+ if (proc == NULL) {
Tcl_DStringInit(&newName);
Tcl_DStringAppend(&newName, "_", 1);
native = Tcl_DStringAppend(&newName, native, -1);
- *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
+ proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
native);
Tcl_DStringFree(&newName);
}
Tcl_DStringFree(&ds);
- native = Tcl_UtfToExternalDString(NULL, sym2, -1, &ds);
- *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
- native);
- if (*proc2Ptr == NULL) {
- Tcl_DStringInit(&newName);
- Tcl_DStringAppend(&newName, "_", 1);
- native = Tcl_DStringAppend(&newName, native, -1);
- *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
- native);
- Tcl_DStringFree(&newName);
- }
- Tcl_DStringFree(&ds);
-
- return TCL_OK;
+ return proc;
}
\f
/*
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
VOID *handle;
- handle = (VOID *) clientData;
+ handle = (VOID *) loadHandle;
dlclose(handle);
}
\f
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
return 0;
}
-
+++ /dev/null
-/*
- * tclLoadDl2.c --
- *
- * This procedure provides a version of the TclLoadFile that
- * works with the "dlopen" and "dlsym" library procedures for
- * dynamic loading. It is identical to tclLoadDl.c except that
- * it adds a "_" character to symbol names before looking them
- * up.
- *
- * Copyright (c) 1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclLoadDl2.c 1.3 96/02/15 11:58:45
- */
-
-#include "tcl.h"
-#include "dlfcn.h"
-
-/*
- * In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined
- * and this argument to dlopen must always be 1.
- */
-
-#ifndef RTLD_NOW
-# define RTLD_NOW 1
-#endif
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclLoadFile --
- *
- * Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
- *
- * Results:
- * A standard Tcl completion code. If an error occurs, an error
- * message is left in interp->result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
- *
- * Side effects:
- * New code suddenly appears in memory.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
-{
- VOID *handle;
- Tcl_DString newName;
-
- handle = dlopen(fileName, RTLD_NOW);
- if (handle == NULL) {
- Tcl_AppendResult(interp, "couldn't load file \"", fileName,
- "\": ", dlerror(), (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_DStringInit(&newName);
- Tcl_DStringAppend(&newName, "_", 1);
- Tcl_DStringAppend(&newName, sym1, -1);
- *proc1Ptr = (Tcl_PackageInitProc *) dlsym(handle,
- Tcl_DStringValue(&newName));
- Tcl_DStringSetLength(&newName, 0);
- Tcl_DStringAppend(&newName, "_", 1);
- Tcl_DStringAppend(&newName, sym2, -1);
- *proc2Ptr = (Tcl_PackageInitProc *) dlsym(handle,
- Tcl_DStringValue(&newName));
- Tcl_DStringFree(&newName);
- return TCL_OK;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclGuessPackageName --
- *
- * If the "load" command is invoked without providing a package
- * name, this procedure is invoked to try to figure it out.
- *
- * Results:
- * Always returns 0 to indicate that we couldn't figure out a
- * package name; generic code will then try to guess the package
- * from the file name. A return value of 1 would have meant that
- * we figured out the package name and put it in bufPtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
- * translated to local form if needed). */
- Tcl_DString *bufPtr; /* Initialized empty dstring. Append
- * package name to this if possible. */
-{
- return 0;
-}
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
+ * message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
static int firstTime = 1;
int returnCode;
-
+ char *fileName;
+ CONST char *native;
+
/*
* The dld package needs to know the pathname to the tcl binary.
- * If that's not know, return an error.
+ * If that's not known, return an error.
*/
if (firstTime) {
firstTime = 0;
}
- if ((returnCode = dld_link(fileName)) != 0) {
- Tcl_AppendResult(interp, "couldn't load file \"", fileName,
- "\": ", dld_strerror(returnCode), (char *) NULL);
+ fileName = Tcl_GetString(pathPtr);
+
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load
+ * using a relative path.
+ */
+ native = Tcl_FSGetNativePath(pathPtr);
+ returnCode = dld_link(native);
+
+ if (returnCode != 0) {
+ Tcl_DString ds;
+ native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ returnCode = dld_link(native);
+ Tcl_DStringFree(&ds);
+ }
+
+ if (returnCode != 0) {
+ Tcl_AppendResult(interp, "couldn't load file \"",
+ fileName, "\": ",
+ dld_strerror(returnCode), (char *) NULL);
return TCL_ERROR;
}
- *proc1Ptr = (Tcl_PackageInitProc *) dld_get_func(sym1);
- *proc2Ptr = (Tcl_PackageInitProc *) dld_get_func(sym2);
- *clientDataPtr = strcpy(
+ *loadHandle = (Tcl_LoadHandle) strcpy(
(char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
\f
/*
*----------------------------------------------------------------------
*
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ return (Tcl_PackageInitProc *) dld_get_func(symbol);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclpUnloadFile --
*
* Unloads a dynamically loaded binary code file from memory.
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
char *fileName;
- handle = (char *) clientData;
+ handle = (char *) loadHandle;
dld_unlink_by_file(handle, 0);
ckfree(handle);
}
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
return 0;
}
-
* tclLoadDyld.c --
*
* This procedure provides a version of the TclLoadFile that
- * works with NeXT/Apple's dyld dynamic loading. This file
+ * works with Apple's dyld dynamic loading. This file
* provided by Wilfredo Sanchez (wsanchez@apple.com).
- * The works on Mac OS X and Mac OS X Server.
- * It should work with OpenStep, but it's not been tried.
+ * This works on Mac OS X.
*
* Copyright (c) 1995 Apple Computer, Inc.
*
*/
#include "tclInt.h"
+#include "tclPort.h"
#include <mach-o/dyld.h>
+typedef struct Tcl_DyldModuleHandle {
+ struct Tcl_DyldModuleHandle *nextModuleHandle;
+ NSModule module;
+} Tcl_DyldModuleHandle;
+
+typedef struct Tcl_DyldLoadHandle {
+ const struct mach_header *dyld_lib;
+ Tcl_DyldModuleHandle *firstModuleHandle;
+} Tcl_DyldLoadHandle;
+
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
- * Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * Dynamically loads a binary code file into memory and returns
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in the interpreter's result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
+ * message is left in the interpreter's result.
*
* Side effects:
* New code suddenly appears in memory.
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
- NSObjectFileImageReturnCode err;
- NSObjectFileImage image;
- NSModule module;
- NSSymbol symbol;
- char *name;
+ Tcl_DyldLoadHandle *dyldLoadHandle;
+ const struct mach_header *dyld_lib;
+ CONST char *native;
- err = NSCreateObjectFileImageFromFile(fileName, &image);
- if (err != NSObjectFileImageSuccess) {
- switch (err) {
- case NSObjectFileImageFailure:
- Tcl_SetResult(interp, "dyld: general failure", TCL_STATIC);
- break;
- case NSObjectFileImageInappropriateFile:
- Tcl_SetResult(interp, "dyld: inappropriate Mach-O file",
- TCL_STATIC);
- break;
- case NSObjectFileImageArch:
- Tcl_SetResult(interp,
- "dyld: inappropriate Mach-O architecture", TCL_STATIC);
- break;
- case NSObjectFileImageFormat:
- Tcl_SetResult(interp, "dyld: invalid Mach-O file format",
- TCL_STATIC);
- break;
- case NSObjectFileImageAccess:
- Tcl_SetResult(interp, "dyld: permission denied", TCL_STATIC);
- break;
- default:
- Tcl_SetResult(interp, "dyld: unknown failure", TCL_STATIC);
- break;
- }
- return TCL_ERROR;
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load
+ * using a relative path.
+ */
+ native = Tcl_FSGetNativePath(pathPtr);
+ dyld_lib = NSAddImage(native,
+ NSADDIMAGE_OPTION_WITH_SEARCHING |
+ NSADDIMAGE_OPTION_RETURN_ON_ERROR);
+
+ if (!dyld_lib) {
+ /*
+ * Let the OS loader examine the binary search path for
+ * whatever string the user gave us which hopefully refers
+ * to a file on the binary path
+ */
+ Tcl_DString ds;
+ char *fileName = Tcl_GetString(pathPtr);
+ native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ dyld_lib = NSAddImage(native,
+ NSADDIMAGE_OPTION_WITH_SEARCHING |
+ NSADDIMAGE_OPTION_RETURN_ON_ERROR);
+ Tcl_DStringFree(&ds);
}
-
- module = NSLinkModule(image, fileName, TRUE);
-
- if (module == NULL) {
- Tcl_SetResult(interp, "dyld: falied to link module", TCL_STATIC);
- return TCL_ERROR;
+
+ if (!dyld_lib) {
+ NSLinkEditErrors editError;
+ char *name, *msg;
+ NSLinkEditError(&editError, &errno, &name, &msg);
+ Tcl_AppendResult(interp, msg, (char *) NULL);
+ return TCL_ERROR;
}
-
- name = (char*)malloc(sizeof(char)*(strlen(sym1)+2));
- sprintf(name, "_%s", sym1);
- symbol = NSLookupAndBindSymbol(name);
- free(name);
- *proc1Ptr = NSAddressOfSymbol(symbol);
-
- name = (char*)malloc(sizeof(char)*(strlen(sym2)+2));
- sprintf(name, "_%s", sym2);
- symbol = NSLookupAndBindSymbol(name);
- free(name);
- *proc2Ptr = NSAddressOfSymbol(symbol);
-
- *clientDataPtr = module;
-
+
+ dyldLoadHandle = (Tcl_DyldLoadHandle *) ckalloc(sizeof(Tcl_DyldLoadHandle));
+ if (!dyldLoadHandle) return TCL_ERROR;
+ dyldLoadHandle->dyld_lib = dyld_lib;
+ dyldLoadHandle->firstModuleHandle = NULL;
+ *loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ NSSymbol nsSymbol;
+ CONST char *native;
+ Tcl_DString newName, ds;
+ Tcl_PackageInitProc* proc = NULL;
+ Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
+ /*
+ * dyld adds an underscore to the beginning of symbol names.
+ */
+
+ native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
+ Tcl_DStringInit(&newName);
+ Tcl_DStringAppend(&newName, "_", 1);
+ native = Tcl_DStringAppend(&newName, native, -1);
+ nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyld_lib, native,
+ NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
+ NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
+ if(nsSymbol) {
+ Tcl_DyldModuleHandle *dyldModuleHandle;
+ proc = NSAddressOfSymbol(nsSymbol);
+ dyldModuleHandle = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle));
+ if (dyldModuleHandle) {
+ dyldModuleHandle->module = NSModuleForSymbol(nsSymbol);
+ dyldModuleHandle->nextModuleHandle = dyldLoadHandle->firstModuleHandle;
+ dyldLoadHandle->firstModuleHandle = dyldModuleHandle;
+ }
+ }
+ Tcl_DStringFree(&newName);
+ Tcl_DStringFree(&ds);
+
+ return proc;
+}
/*
*----------------------------------------------------------------------
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
- NSUnLinkModule(clientData, FALSE);
+ Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
+ Tcl_DyldModuleHandle *dyldModuleHandle = dyldLoadHandle->firstModuleHandle;
+ void *ptr;
+
+ while (dyldModuleHandle) {
+ NSUnLinkModule(dyldModuleHandle->module, NSUNLINKMODULE_OPTION_NONE);
+ ptr = dyldModuleHandle;
+ dyldModuleHandle = dyldModuleHandle->nextModuleHandle;
+ ckfree(ptr);
+ }
+ ckfree(dyldLoadHandle);
}
/*
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
+ * message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
- struct mach_header *header;
- char *data;
- int len, maxlen;
- char *files[]={fileName,NULL};
- NXStream *errorStream=NXOpenMemory(0,0,NX_READWRITE);
+ struct mach_header *header;
+ char *fileName;
+ char *files[2];
+ CONST char *native;
+ int result = 1;
+
+ NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);
+
+ fileName = Tcl_GetString(pathPtr);
- if(!rld_load(errorStream,&header,files,NULL)) {
- NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
- Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL);
- NXCloseMemory(errorStream,NX_FREEBUFFER);
- return TCL_ERROR;
- }
- NXCloseMemory(errorStream,NX_FREEBUFFER);
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load
+ * using a relative path.
+ */
+ native = Tcl_FSGetNativePath(pathPtr);
+ files = {native,NULL};
- *proc1Ptr=NULL;
- if(sym1) {
- char sym[strlen(sym1)+2];
- sym[0]='_'; sym[1]=0; strcat(sym,sym1);
- rld_lookup(NULL,sym,(unsigned long *)proc1Ptr);
- }
-
- *proc2Ptr=NULL;
- if(sym2) {
- char sym[strlen(sym2)+2];
- sym[0]='_'; sym[1]=0; strcat(sym,sym2);
- rld_lookup(NULL,sym,(unsigned long *)proc2Ptr);
- }
- *clientDataPtr = NULL;
-
- return TCL_OK;
+ result = rld_load(errorStream, &header, files, NULL);
+
+ if (!result) {
+ /*
+ * Let the OS loader examine the binary search path for
+ * whatever string the user gave us which hopefully refers
+ * to a file on the binary path
+ */
+ Tcl_DString ds;
+ native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ files = {native,NULL};
+ result = rld_load(errorStream, &header, files, NULL);
+ Tcl_DStringFree(&ds);
+ }
+
+ if (!result) {
+ char *data;
+ int len, maxlen;
+ NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
+ Tcl_AppendResult(interp, "couldn't load file \"",
+ fileName, "\": ", data, NULL);
+ NXCloseMemory(errorStream, NX_FREEBUFFER);
+ return TCL_ERROR;
+ }
+ NXCloseMemory(errorStream, NX_FREEBUFFER);
+
+ *loadHandle = (Tcl_LoadHandle)1; /* A dummy non-NULL value */
+ *unloadProcPtr = &TclpUnloadFile;
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ Tcl_PackageInitProc *proc=NULL;
+ if(symbol) {
+ char sym[strlen(symbol)+2];
+ sym[0]='_'; sym[1]=0; strcat(sym,symbol);
+ rld_lookup(NULL,sym,(unsigned long *)&proc);
+ }
+ return proc;
}
\f
/*
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
return 0;
}
-
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
+ * message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
ldr_module_t lm;
char *pkg;
+ char *fileName = Tcl_GetString(pathPtr);
+ CONST char *native;
- lm = (Tcl_PackageInitProc *) load(fileName, LDR_NOFLAGS);
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load
+ * using a relative path.
+ */
+ native = Tcl_FSGetNativePath(pathPtr);
+ lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
+
+ if (lm == LDR_NULL_MODULE) {
+ /*
+ * Let the OS loader examine the binary search path for
+ * whatever string the user gave us which hopefully refers
+ * to a file on the binary path
+ */
+ Tcl_DString ds;
+ native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ lm = (Tcl_PackageInitProc *) load(native, LDR_NOFLAGS);
+ Tcl_DStringFree(&ds);
+ }
+
if (lm == LDR_NULL_MODULE) {
Tcl_AppendResult(interp, "couldn't load file \"", fileName,
"\": ", Tcl_PosixError (interp), (char *) NULL);
* I build loadable modules with a makefile rule like
* ld ... -export $@: -o $@ $(OBJS)
*/
- if ((pkg = strrchr(fileName, '/')) == NULL)
- pkg = fileName;
- else
+ if ((pkg = strrchr(fileName, '/')) == NULL) {
+ pkg = fileName;
+ } else {
pkg++;
- *proc1Ptr = ldr_lookup_package(pkg, sym1);
- *proc2Ptr = ldr_lookup_package(pkg, sym2);
+ }
+ *loadHandle = pkg;
+ *unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
\f
/*
*----------------------------------------------------------------------
*
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ return ldr_lookup_package((char *)loadHandle, symbol);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclpUnloadFile --
*
* Unloads a dynamically loaded binary code file from memory.
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
return 0;
}
-
# undef EXTERN
#endif
-#include "tcl.h"
+#include "tclInt.h"
\f
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in the interp's result. *proc1Ptr and *proc2Ptr
- * are filled in with the addresses of the symbols given by
- * *sym1 and *sym2, or NULL if those symbols can't be found.
+ * message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
shl_t handle;
- Tcl_DString newName;
+ CONST char *native;
+ char *fileName = Tcl_GetString(pathPtr);
/*
* The flags below used to be BIND_IMMEDIATE; they were changed at
* when they are build."
*/
- handle = shl_load(fileName, BIND_DEFERRED|BIND_VERBOSE, 0L);
+
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load
+ * using a relative path.
+ */
+ native = Tcl_FSGetNativePath(pathPtr);
+ handle = shl_load(native,
+ BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
+
+ if (handle == NULL) {
+ /*
+ * Let the OS loader examine the binary search path for
+ * whatever string the user gave us which hopefully refers
+ * to a file on the binary path
+ */
+ Tcl_DString ds;
+ native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ handle = shl_load(native,
+ BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L);
+ Tcl_DStringFree(&ds);
+ }
+
if (handle == NULL) {
Tcl_AppendResult(interp, "couldn't load file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
- *clientDataPtr = (ClientData) handle;
-
+ *loadHandle = (Tcl_LoadHandle) handle;
+ *unloadProcPtr = &TclpUnloadFile;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ Tcl_DString newName;
+ Tcl_PackageInitProc *proc=NULL;
+ shl_t handle = (shl_t)loadHandle;
/*
* Some versions of the HP system software still use "_" at the
* beginning of exported symbols while others don't; try both
* forms of each name.
*/
- if (shl_findsym(&handle, sym1, (short) TYPE_PROCEDURE, (void *) proc1Ptr)
+ if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, (void *) &proc)
!= 0) {
Tcl_DStringInit(&newName);
Tcl_DStringAppend(&newName, "_", 1);
- Tcl_DStringAppend(&newName, sym1, -1);
+ Tcl_DStringAppend(&newName, symbol, -1);
if (shl_findsym(&handle, Tcl_DStringValue(&newName),
- (short) TYPE_PROCEDURE, (void *) proc1Ptr) != 0) {
- *proc1Ptr = NULL;
+ (short) TYPE_PROCEDURE, (void *) &proc) != 0) {
+ proc = NULL;
}
Tcl_DStringFree(&newName);
}
- if (shl_findsym(&handle, sym2, (short) TYPE_PROCEDURE, (void *) proc2Ptr)
- != 0) {
- Tcl_DStringInit(&newName);
- Tcl_DStringAppend(&newName, "_", 1);
- Tcl_DStringAppend(&newName, sym2, -1);
- if (shl_findsym(&handle, Tcl_DStringValue(&newName),
- (short) TYPE_PROCEDURE, (void *) proc2Ptr) != 0) {
- *proc2Ptr = NULL;
- }
- Tcl_DStringFree(&newName);
- }
- return TCL_OK;
+ return proc;
}
\f
/*
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
shl_t handle;
- handle = (shl_t) clientData;
+ handle = (shl_t) loadHandle;
shl_unload(handle);
}
\f
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
return 0;
}
-
+++ /dev/null
-/*
- * tclMatherr.c --
- *
- * This function provides a default implementation of the
- * "matherr" function, for SYS-V systems where it's needed.
- *
- * Copyright (c) 1993-1994 The Regents of the University of California.
- * Copyright (c) 1994 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id$
- */
-
-#include "tclInt.h"
-#include <math.h>
-
-#ifndef TCL_GENERIC_ONLY
-#include "tclPort.h"
-#else
-#define NO_ERRNO_H
-#endif
-
-#ifdef NO_ERRNO_H
-extern int errno; /* Use errno from tclExecute.c. */
-#define EDOM 33
-#define ERANGE 34
-#endif
-
-/*
- * The following definitions allow matherr to compile on systems
- * that don't really support it. The compiled procedure is bogus,
- * but it will never be executed on these systems anyway.
- */
-
-#ifndef NEED_MATHERR
-struct exception {
- int type;
-};
-#define DOMAIN 0
-#define SING 0
-#endif
-\f
-/*
- *----------------------------------------------------------------------
- *
- * matherr --
- *
- * This procedure is invoked on Sys-V systems when certain
- * errors occur in mathematical functions. Type "man matherr"
- * for more information on how this function works.
- *
- * Results:
- * Returns 1 to indicate that we've handled the error
- * locally.
- *
- * Side effects:
- * Sets errno based on what's in xPtr.
- *
- *----------------------------------------------------------------------
- */
-
-int
-matherr(xPtr)
- struct exception *xPtr; /* Describes error that occurred. */
-{
- if (TclMathInProgress()) {
- return 0;
- }
- if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) {
- errno = EDOM;
- } else {
- errno = ERANGE;
- }
- return 1;
-}
-
* RCS: @(#) $Id$
*/
-#include "tclInt.h" /* Internal definitions for Tcl. */
-#include "tclPort.h" /* Portability features for Tcl. */
+#include "tclInt.h" /* Internal definitions for Tcl. */
+#include "tclPort.h" /* Portability features for Tcl. */
/*
- * sys/ioctl.h has already been included by tclPort.h. Including termios.h
+ * sys/ioctl.h has already been included by tclPort.h. Including termios.h
* or termio.h causes a bunch of warning messages because some duplicate
* (but not contradictory) #defines exist in termios.h and/or termio.h
*/
#ifdef USE_TERMIOS
# include <termios.h>
+# ifdef HAVE_SYS_IOCTL_H
+# include <sys/ioctl.h>
+# endif /* HAVE_SYS_IOCTL_H */
+# ifdef HAVE_SYS_MODEM_H
+# include <sys/modem.h>
+# endif /* HAVE_SYS_MODEM_H */
# define IOSTATE struct termios
# define GETIOSTATE(fd, statePtr) tcgetattr((fd), (statePtr))
# define SETIOSTATE(fd, statePtr) tcsetattr((fd), TCSADRAIN, (statePtr))
+# define GETCONTROL(fd, intPtr) ioctl((fd), TIOCMGET, (intPtr))
+# define SETCONTROL(fd, intPtr) ioctl((fd), TIOCMSET, (intPtr))
+ /*
+ * TIP #35 introduced a different on exit flush/close behavior that
+ * doesn't work correctly with standard channels on all systems.
+ * The problem is tcflush throws away waiting channel data. This may
+ * be necessary for true serial channels that may block, but isn't
+ * correct in the standard case. This might be replaced with tcdrain
+ * instead, but that can block. For now, we revert to making this do
+ * nothing, and TtyOutputProc being the same old FileOutputProc.
+ * -- hobbs [Bug #525783]
+ */
+# define BAD_TIP35_FLUSH 0
+# if BAD_TIP35_FLUSH
+# define TTYFLUSH(fd) tcflush((fd), TCIOFLUSH);
+# else
+# define TTYFLUSH(fd)
+# endif /* BAD_TIP35_FLUSH */
+# ifdef FIONREAD
+# define GETREADQUEUE(fd, int) ioctl((fd), FIONREAD, &(int))
+# elif defined(FIORDCHK)
+# define GETREADQUEUE(fd, int) int = ioctl((fd), FIORDCHK, NULL)
+# endif /* FIONREAD */
+# ifdef TIOCOUTQ
+# define GETWRITEQUEUE(fd, int) ioctl((fd), TIOCOUTQ, &(int))
+# endif /* TIOCOUTQ */
+# if defined(TIOCSBRK) && defined(TIOCCBRK)
+/*
+ * Can't use ?: operator below because that messes up types on either
+ * Linux or Solaris (the two are mutually exclusive!)
+ */
+# define SETBREAK(fd, flag) \
+ if (flag) { \
+ ioctl((fd), TIOCSBRK, NULL); \
+ } else { \
+ ioctl((fd), TIOCCBRK, NULL); \
+ }
+# endif /* TIOCSBRK&TIOCCBRK */
+# if !defined(CRTSCTS) && defined(CNEW_RTSCTS)
+# define CRTSCTS CNEW_RTSCTS
+# endif /* !CRTSCTS&CNEW_RTSCTS */
#else /* !USE_TERMIOS */
+
#ifdef USE_TERMIO
# include <termio.h>
# define IOSTATE struct termio
# define GETIOSTATE(fd, statePtr) ioctl((fd), TCGETA, (statePtr))
# define SETIOSTATE(fd, statePtr) ioctl((fd), TCSETAW, (statePtr))
#else /* !USE_TERMIO */
+
#ifdef USE_SGTTY
# include <sgtty.h>
# define IOSTATE struct sgttyb
#else /* !USE_SGTTY */
# undef SUPPORTS_TTY
#endif /* !USE_SGTTY */
+
#endif /* !USE_TERMIO */
#endif /* !USE_TERMIOS */
int validMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which operations are valid on the file. */
+#ifdef DEPRECATED
struct FileState *nextPtr; /* Pointer to next file in list of all
* file channels. */
+#endif /* DEPRECATED */
} FileState;
#ifdef SUPPORTS_TTY
typedef struct TtyState {
FileState fs; /* Per-instance state of the file
- * descriptor. Must be the first field. */
+ * descriptor. Must be the first field. */
+ int stateUpdated; /* Flag to say if the state has been
+ * modified and needs resetting. */
IOSTATE savedState; /* Initial state of device. Used to reset
* state when device closed. */
} TtyState;
* The following structure is used to set or get the serial port
* attributes in a platform-independant manner.
*/
-
+
typedef struct TtyAttrs {
int baud;
int parity;
#endif /* !SUPPORTS_TTY */
+#define UNSUPPORTED_OPTION(detail) \
+ if (interp) { \
+ Tcl_AppendResult(interp, (detail), \
+ " not supported for this platform", (char *) NULL); \
+ }
+
+#ifdef DEPRECATED
typedef struct ThreadSpecificData {
/*
* List of all file channels currently open. This is per thread and is
* used to match up fd's to channels, which rarely occurs.
*/
-
+
FileState *firstFilePtr;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
+#endif /* DEPRECATED */
/*
* This structure describes per-instance state of a tcp based channel.
* the connection request will fail.
*/
-#ifndef SOMAXCONN
-#define SOMAXCONN 100
-#endif
+#ifndef SOMAXCONN
+# define SOMAXCONN 100
+#endif /* SOMAXCONN */
-#if (SOMAXCONN < 100)
-#undef SOMAXCONN
-#define SOMAXCONN 100
-#endif
+#if (SOMAXCONN < 100)
+# undef SOMAXCONN
+# define SOMAXCONN 100
+#endif /* SOMAXCONN < 100 */
/*
* The following defines how much buffer space the kernel should maintain
*/
static TcpState * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp,
- int port, char *host, int server,
- char *myaddr, int myport, int async));
+ int port, CONST char *host, int server,
+ CONST char *myaddr, int myport, int async));
static int CreateSocketAddress _ANSI_ARGS_(
(struct sockaddr_in *sockaddrPtr,
- char *host, int port));
+ CONST char *host, int port));
static int FileBlockModeProc _ANSI_ARGS_((
- ClientData instanceData, int mode));
+ ClientData instanceData, int mode));
static int FileCloseProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp));
static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData,
- int direction, ClientData *handlePtr));
+ int direction, ClientData *handlePtr));
static int FileInputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toRead, int *errorCode));
+ char *buf, int toRead, int *errorCode));
static int FileOutputProc _ANSI_ARGS_((
- ClientData instanceData, char *buf, int toWrite,
- int *errorCode));
+ ClientData instanceData, CONST char *buf,
+ int toWrite, int *errorCode));
static int FileSeekProc _ANSI_ARGS_((ClientData instanceData,
long offset, int mode, int *errorCode));
+static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_WideInt offset, int mode, int *errorCode));
static void FileWatchProc _ANSI_ARGS_((ClientData instanceData,
- int mask));
+ int mask));
static void TcpAccept _ANSI_ARGS_((ClientData data, int mask));
static int TcpBlockModeProc _ANSI_ARGS_((ClientData data,
- int mode));
+ int mode));
static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp));
static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData,
- int direction, ClientData *handlePtr));
+ int direction, ClientData *handlePtr));
static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
+ Tcl_Interp *interp, CONST char *optionName,
Tcl_DString *dsPtr));
static int TcpInputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toRead, int *errorCode));
+ char *buf, int toRead, int *errorCode));
static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCode));
+ CONST char *buf, int toWrite, int *errorCode));
static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData,
- int mask));
+ int mask));
#ifdef SUPPORTS_TTY
static int TtyCloseProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp));
static void TtyGetAttributes _ANSI_ARGS_((int fd,
TtyAttrs *ttyPtr));
static int TtyGetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
+ Tcl_Interp *interp, CONST char *optionName,
Tcl_DString *dsPtr));
-static FileState * TtyInit _ANSI_ARGS_((int fd));
+static FileState * TtyInit _ANSI_ARGS_((int fd, int initialize));
+#if BAD_TIP35_FLUSH
+static int TtyOutputProc _ANSI_ARGS_((ClientData instanceData,
+ CONST char *buf, int toWrite, int *errorCode));
+#endif /* BAD_TIP35_FLUSH */
static int TtyParseMode _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *mode, int *speedPtr, int *parityPtr,
int *dataPtr, int *stopPtr));
static void TtySetAttributes _ANSI_ARGS_((int fd,
TtyAttrs *ttyPtr));
static int TtySetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
- char *value));
+ Tcl_Interp *interp, CONST char *optionName,
+ CONST char *value));
#endif /* SUPPORTS_TTY */
static int WaitForConnect _ANSI_ARGS_((TcpState *statePtr,
- int *errorCodePtr));
+ int *errorCodePtr));
/*
* This structure describes the channel type structure for file based IO:
*/
static Tcl_ChannelType fileChannelType = {
- "file", /* Type name. */
- FileBlockModeProc, /* Set blocking/nonblocking mode.*/
- FileCloseProc, /* Close proc. */
- FileInputProc, /* Input proc. */
- FileOutputProc, /* Output proc. */
- FileSeekProc, /* Seek proc. */
- NULL, /* Set option proc. */
- NULL, /* Get option proc. */
- FileWatchProc, /* Initialize notifier. */
- FileGetHandleProc, /* Get OS handles out of channel. */
+ "file", /* Type name. */
+ TCL_CHANNEL_VERSION_3, /* v3 channel */
+ FileCloseProc, /* Close proc. */
+ FileInputProc, /* Input proc. */
+ FileOutputProc, /* Output proc. */
+ FileSeekProc, /* Seek proc. */
+ NULL, /* Set option proc. */
+ NULL, /* Get option proc. */
+ FileWatchProc, /* Initialize notifier. */
+ FileGetHandleProc, /* Get OS handles out of channel. */
+ NULL, /* close2proc. */
+ FileBlockModeProc, /* Set blocking or non-blocking mode.*/
+ NULL, /* flush proc. */
+ NULL, /* handler proc. */
+ FileWideSeekProc, /* wide seek proc. */
};
#ifdef SUPPORTS_TTY
*/
static Tcl_ChannelType ttyChannelType = {
- "tty", /* Type name. */
- FileBlockModeProc, /* Set blocking/nonblocking mode.*/
- TtyCloseProc, /* Close proc. */
- FileInputProc, /* Input proc. */
- FileOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- TtySetOptionProc, /* Set option proc. */
- TtyGetOptionProc, /* Get option proc. */
- FileWatchProc, /* Initialize notifier. */
- FileGetHandleProc, /* Get OS handles out of channel. */
+ "tty", /* Type name. */
+ TCL_CHANNEL_VERSION_2, /* v2 channel */
+ TtyCloseProc, /* Close proc. */
+ FileInputProc, /* Input proc. */
+#if BAD_TIP35_FLUSH
+ TtyOutputProc, /* Output proc. */
+#else /* !BAD_TIP35_FLUSH */
+ FileOutputProc, /* Output proc. */
+#endif /* BAD_TIP35_FLUSH */
+ NULL, /* Seek proc. */
+ TtySetOptionProc, /* Set option proc. */
+ TtyGetOptionProc, /* Get option proc. */
+ FileWatchProc, /* Initialize notifier. */
+ FileGetHandleProc, /* Get OS handles out of channel. */
+ NULL, /* close2proc. */
+ FileBlockModeProc, /* Set blocking or non-blocking mode.*/
+ NULL, /* flush proc. */
+ NULL, /* handler proc. */
};
#endif /* SUPPORTS_TTY */
*/
static Tcl_ChannelType tcpChannelType = {
- "tcp", /* Type name. */
- TcpBlockModeProc, /* Set blocking/nonblocking mode.*/
- TcpCloseProc, /* Close proc. */
- TcpInputProc, /* Input proc. */
- TcpOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- NULL, /* Set option proc. */
- TcpGetOptionProc, /* Get option proc. */
- TcpWatchProc, /* Initialize notifier. */
- TcpGetHandleProc, /* Get OS handles out of channel. */
+ "tcp", /* Type name. */
+ TCL_CHANNEL_VERSION_2, /* v2 channel */
+ TcpCloseProc, /* Close proc. */
+ TcpInputProc, /* Input proc. */
+ TcpOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ NULL, /* Set option proc. */
+ TcpGetOptionProc, /* Get option proc. */
+ TcpWatchProc, /* Initialize notifier. */
+ TcpGetHandleProc, /* Get OS handles out of channel. */
+ NULL, /* close2proc. */
+ TcpBlockModeProc, /* Set blocking or non-blocking mode.*/
+ NULL, /* flush proc. */
+ NULL, /* handler proc. */
};
\f
FileBlockModeProc(instanceData, mode)
ClientData instanceData; /* File state. */
int mode; /* The mode to set. Can be one of
- * TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+ * TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
{
FileState *fsPtr = (FileState *) instanceData;
int curStatus;
return errno;
}
curStatus = fcntl(fsPtr->fd, F_GETFL);
-#else
+#else /* USE_FIONBIO */
if (mode == TCL_MODE_BLOCKING) {
curStatus = 0;
} else {
if (ioctl(fsPtr->fd, (int) FIONBIO, &curStatus) < 0) {
return errno;
}
-#endif
+#endif /* !USE_FIONBIO */
return 0;
}
\f
ClientData instanceData; /* File state. */
char *buf; /* Where to store data read. */
int toRead; /* How much space is available
- * in the buffer? */
+ * in the buffer? */
int *errorCodePtr; /* Where to store error code. */
{
FileState *fsPtr = (FileState *) instanceData;
int bytesRead; /* How many bytes were actually
- * read from the input device? */
+ * read from the input device? */
*errorCodePtr = 0;
-
+
/*
* Assume there is always enough input available. This will block
* appropriately, and read will unblock as soon as a short read is
bytesRead = read(fsPtr->fd, buf, (size_t) toRead);
if (bytesRead > -1) {
- return bytesRead;
+ return bytesRead;
}
*errorCodePtr = errno;
return -1;
*
* Results:
* The number of bytes written is returned or -1 on error. An
- * output argument contains a POSIX error code if an error occurred,
+ * output argument contains a POSIX error code if an error occurred,
* or zero.
*
* Side effects:
static int
FileOutputProc(instanceData, buf, toWrite, errorCodePtr)
ClientData instanceData; /* File state. */
- char *buf; /* The data buffer. */
+ CONST char *buf; /* The data buffer. */
int toWrite; /* How many bytes to write? */
int *errorCodePtr; /* Where to store error code. */
{
int written;
*errorCodePtr = 0;
+
+ if (toWrite == 0) {
+ /*
+ * SF Tcl Bug 465765.
+ * Do not try to write nothing into a file. STREAM based
+ * implementations will considers this as EOF (if there is a
+ * pipe behind the file).
+ */
+
+ return 0;
+ }
written = write(fsPtr->fd, buf, (size_t) toWrite);
if (written > -1) {
- return written;
+ return written;
}
*errorCodePtr = errno;
return -1;
Tcl_Interp *interp; /* For error reporting - unused. */
{
FileState *fsPtr = (FileState *) instanceData;
- FileState **nextPtrPtr;
int errorCode = 0;
+#ifdef DEPRECATED
+ FileState **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
+#endif /* DEPRECATED */
Tcl_DeleteFileHandler(fsPtr->fd);
/*
errorCode = errno;
}
}
+#ifdef DEPRECATED
for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == fsPtr) {
break;
}
}
+#endif /* DEPRECATED */
ckfree((char *) fsPtr);
return errorCode;
}
static int
FileSeekProc(instanceData, offset, mode, errorCodePtr)
- ClientData instanceData; /* File state. */
- long offset; /* Offset to seek to. */
- int mode; /* Relative to where
- * should we seek? Can be
- * one of SEEK_START,
- * SEEK_SET or SEEK_END. */
- int *errorCodePtr; /* To store error code. */
+ ClientData instanceData; /* File state. */
+ long offset; /* Offset to seek to. */
+ int mode; /* Relative to where should we seek? Can be
+ * one of SEEK_START, SEEK_SET or SEEK_END. */
+ int *errorCodePtr; /* To store error code. */
+{
+ FileState *fsPtr = (FileState *) instanceData;
+ Tcl_WideInt oldLoc, newLoc;
+
+ /*
+ * Save our current place in case we need to roll-back the seek.
+ */
+ oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
+ if (oldLoc == Tcl_LongAsWide(-1)) {
+ /*
+ * Bad things are happening. Error out...
+ */
+ *errorCodePtr = errno;
+ return -1;
+ }
+
+ newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
+
+ /*
+ * Check for expressability in our return type, and roll-back otherwise.
+ */
+ if (newLoc > Tcl_LongAsWide(INT_MAX)) {
+ *errorCodePtr = EOVERFLOW;
+ TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
+ return -1;
+ } else {
+ *errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0;
+ }
+ return (int) Tcl_WideAsLong(newLoc);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileWideSeekProc --
+ *
+ * This procedure is called by the generic IO level to move the
+ * access point in a file based channel, with offsets expressed
+ * as wide integers.
+ *
+ * Results:
+ * -1 if failed, the new position if successful. An output
+ * argument contains the POSIX error code if an error occurred,
+ * or zero.
+ *
+ * Side effects:
+ * Moves the location at which the channel will be accessed in
+ * future operations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
+ ClientData instanceData; /* File state. */
+ Tcl_WideInt offset; /* Offset to seek to. */
+ int mode; /* Relative to where should we seek? Can be
+ * one of SEEK_START, SEEK_CUR or SEEK_END. */
+ int *errorCodePtr; /* To store error code. */
{
FileState *fsPtr = (FileState *) instanceData;
- int newLoc;
+ Tcl_WideInt newLoc;
- newLoc = lseek(fsPtr->fd, (off_t) offset, mode);
+ newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
*errorCodePtr = (newLoc == -1) ? errno : 0;
return newLoc;
FileWatchProc(instanceData, mask)
ClientData instanceData; /* The file state. */
int mask; /* Events of interest; an OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+ * combination of TCL_READABLE,
+ * TCL_WRITABLE and TCL_EXCEPTION. */
{
FileState *fsPtr = (FileState *) instanceData;
* 0 if successful, errno if failed.
*
* Side effects:
- * Restores the settings and closes the device of the channel.
+ * Closes the device of the channel.
*
*----------------------------------------------------------------------
*/
-
static int
TtyCloseProc(instanceData, interp)
ClientData instanceData; /* Tty state. */
Tcl_Interp *interp; /* For error reporting - unused. */
{
- TtyState *ttyPtr;
-
- ttyPtr = (TtyState *) instanceData;
- SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState);
+#if BAD_TIP35_FLUSH
+ TtyState *ttyPtr = (TtyState *) instanceData;
+#endif /* BAD_TIP35_FLUSH */
+#ifdef TTYFLUSH
+ TTYFLUSH(ttyPtr->fs.fd);
+#endif /* TTYFLUSH */
+#if 0
+ /*
+ * TIP#35 agreed to remove the unsave so that TCL could be used as a
+ * simple stty.
+ * It would be cleaner to remove all the stuff related to
+ * TtyState.stateUpdated
+ * TtyState.savedState
+ * Then the structure TtyState would be the same as FileState.
+ * IMO this cleanup could better be done for the final 8.4 release
+ * after nobody complained about the missing unsave. -- schroedter
+ */
+ if (ttyPtr->stateUpdated) {
+ SETIOSTATE(ttyPtr->fs.fd, &ttyPtr->savedState);
+ }
+#endif
return FileCloseProc(instanceData, interp);
}
\f
/*
*----------------------------------------------------------------------
*
+ * TtyOutputProc--
+ *
+ * This procedure is invoked from the generic IO level to write
+ * output to a TTY channel.
+ *
+ * Results:
+ * The number of bytes written is returned or -1 on error. An
+ * output argument contains a POSIX error code if an error occurred,
+ * or zero.
+ *
+ * Side effects:
+ * Writes output on the output device of the channel
+ * if the channel is not designated to be closed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#if BAD_TIP35_FLUSH
+static int
+TtyOutputProc(instanceData, buf, toWrite, errorCodePtr)
+ ClientData instanceData; /* File state. */
+ CONST char *buf; /* The data buffer. */
+ int toWrite; /* How many bytes to write? */
+ int *errorCodePtr; /* Where to store error code. */
+{
+ if (TclInExit()) {
+ /*
+ * Do not write data during Tcl exit.
+ * Serial port may block preventing Tcl from exit.
+ */
+ return toWrite;
+ } else {
+ return FileOutputProc(instanceData, buf, toWrite, errorCodePtr);
+ }
+}
+#endif /* BAD_TIP35_FLUSH */
+\f
+#ifdef USE_TERMIOS
+/*
+ *----------------------------------------------------------------------
+ *
+ * TtyModemStatusStr --
+ *
+ * Converts a RS232 modem status list of readable flags
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+TtyModemStatusStr(status, dsPtr)
+ int status; /* RS232 modem status */
+ Tcl_DString *dsPtr; /* Where to store string */
+{
+#ifdef TIOCM_CTS
+ Tcl_DStringAppendElement(dsPtr, "CTS");
+ Tcl_DStringAppendElement(dsPtr, (status & TIOCM_CTS) ? "1" : "0");
+#endif /* TIOCM_CTS */
+#ifdef TIOCM_DSR
+ Tcl_DStringAppendElement(dsPtr, "DSR");
+ Tcl_DStringAppendElement(dsPtr, (status & TIOCM_DSR) ? "1" : "0");
+#endif /* TIOCM_DSR */
+#ifdef TIOCM_RNG
+ Tcl_DStringAppendElement(dsPtr, "RING");
+ Tcl_DStringAppendElement(dsPtr, (status & TIOCM_RNG) ? "1" : "0");
+#endif /* TIOCM_RNG */
+#ifdef TIOCM_CD
+ Tcl_DStringAppendElement(dsPtr, "DCD");
+ Tcl_DStringAppendElement(dsPtr, (status & TIOCM_CD) ? "1" : "0");
+#endif /* TIOCM_CD */
+}
+#endif /* USE_TERMIOS */
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TtySetOptionProc --
*
* Sets an option on a channel.
*
* Side effects:
* May modify an option on a device.
- * Sets Error message if needed (by calling Tcl_BadChannelOption).
+ * Sets Error message if needed (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
TtySetOptionProc(instanceData, interp, optionName, value)
ClientData instanceData; /* File state. */
Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Which option to set? */
- char *value; /* New value for option. */
+ CONST char *optionName; /* Which option to set? */
+ CONST char *value; /* New value for option. */
{
FileState *fsPtr = (FileState *) instanceData;
- unsigned int len;
+ unsigned int len, vlen;
TtyAttrs tty;
+#ifdef USE_TERMIOS
+ int flag, control, argc;
+ CONST char **argv;
+ IOSTATE iostate;
+#endif /* USE_TERMIOS */
len = strlen(optionName);
- if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
+ vlen = strlen(value);
+
+ /*
+ * Option -mode baud,parity,databits,stopbits
+ */
+ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (TtyParseMode(interp, value, &tty.baud, &tty.parity, &tty.data,
&tty.stop) != TCL_OK) {
return TCL_ERROR;
*/
TtySetAttributes(fsPtr->fd, &tty);
+ ((TtyState *) fsPtr)->stateUpdated = 1;
+ return TCL_OK;
+ }
+
+#ifdef USE_TERMIOS
+
+ /*
+ * Option -handshake none|xonxoff|rtscts|dtrdsr
+ */
+ if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
+ /*
+ * Reset all handshake options
+ * DTR and RTS are ON by default
+ */
+ GETIOSTATE(fsPtr->fd, &iostate);
+ iostate.c_iflag &= ~(IXON | IXOFF | IXANY);
+#ifdef CRTSCTS
+ iostate.c_cflag &= ~CRTSCTS;
+#endif /* CRTSCTS */
+ if (strncasecmp(value, "NONE", vlen) == 0) {
+ /* leave all handshake options disabled */
+ } else if (strncasecmp(value, "XONXOFF", vlen) == 0) {
+ iostate.c_iflag |= (IXON | IXOFF | IXANY);
+ } else if (strncasecmp(value, "RTSCTS", vlen) == 0) {
+#ifdef CRTSCTS
+ iostate.c_cflag |= CRTSCTS;
+#else /* !CRTSTS */
+ UNSUPPORTED_OPTION("-handshake RTSCTS");
+ return TCL_ERROR;
+#endif /* CRTSCTS */
+ } else if (strncasecmp(value, "DTRDSR", vlen) == 0) {
+ UNSUPPORTED_OPTION("-handshake DTRDSR");
+ return TCL_ERROR;
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp, "bad value for -handshake: ",
+ "must be one of xonxoff, rtscts, dtrdsr or none",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ SETIOSTATE(fsPtr->fd, &iostate);
+ return TCL_OK;
+ }
+
+ /*
+ * Option -xchar {\x11 \x13}
+ */
+ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
+ GETIOSTATE(fsPtr->fd, &iostate);
+ if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (argc == 2) {
+ iostate.c_cc[VSTART] = argv[0][0];
+ iostate.c_cc[VSTOP] = argv[1][0];
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad value for -xchar: should be a list of two elements",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ SETIOSTATE(fsPtr->fd, &iostate);
+ return TCL_OK;
+ }
+
+ /*
+ * Option -timeout msec
+ */
+ if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
+ int msec;
+
+ GETIOSTATE(fsPtr->fd, &iostate);
+ if (Tcl_GetInt(interp, value, &msec) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ iostate.c_cc[VMIN] = 0;
+ iostate.c_cc[VTIME] = (msec == 0) ? 0 : (msec < 100) ? 1 : (msec+50)/100;
+ SETIOSTATE(fsPtr->fd, &iostate);
+ return TCL_OK;
+ }
+
+ /*
+ * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
+ */
+ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
+ if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if ((argc % 2) == 1) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad value for -ttycontrol: should be a list of",
+ "signal,value pairs", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ GETCONTROL(fsPtr->fd, &control);
+ while (argc > 1) {
+ if (Tcl_GetBoolean(interp, argv[1], &flag) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (strncasecmp(argv[0], "DTR", strlen(argv[0])) == 0) {
+#ifdef TIOCM_DTR
+ if (flag) {
+ control |= TIOCM_DTR;
+ } else {
+ control &= ~TIOCM_DTR;
+ }
+#else /* !TIOCM_DTR */
+ UNSUPPORTED_OPTION("-ttycontrol DTR");
+ return TCL_ERROR;
+#endif /* TIOCM_DTR */
+ } else if (strncasecmp(argv[0], "RTS", strlen(argv[0])) == 0) {
+#ifdef TIOCM_RTS
+ if (flag) {
+ control |= TIOCM_RTS;
+ } else {
+ control &= ~TIOCM_RTS;
+ }
+#else /* !TIOCM_RTS*/
+ UNSUPPORTED_OPTION("-ttycontrol RTS");
+ return TCL_ERROR;
+#endif /* TIOCM_RTS*/
+ } else if (strncasecmp(argv[0], "BREAK", strlen(argv[0])) == 0) {
+#ifdef SETBREAK
+ SETBREAK(fsPtr->fd, flag);
+#else /* !SETBREAK */
+ UNSUPPORTED_OPTION("-ttycontrol BREAK");
+ return TCL_ERROR;
+#endif /* SETBREAK */
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad signal for -ttycontrol: must be ",
+ "DTR, RTS or BREAK", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ argc -= 2, argv += 2;
+ } /* while (argc > 1) */
+
+ SETCONTROL(fsPtr->fd, &control);
return TCL_OK;
- } else {
- return Tcl_BadChannelOption(interp, optionName, "mode");
}
+
+ return Tcl_BadChannelOption(interp, optionName,
+ "mode handshake timeout ttycontrol xchar ");
+
+#else /* !USE_TERMIOS */
+ return Tcl_BadChannelOption(interp, optionName, "mode");
+#endif /* USE_TERMIOS */
}
\f
/*
* Side effects:
* The string returned by this function is in static storage and
* may be reused at any time subsequent to the call.
- * Sets Error message if needed (by calling Tcl_BadChannelOption).
+ * Sets Error message if needed (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
TtyGetOptionProc(instanceData, interp, optionName, dsPtr)
ClientData instanceData; /* File state. */
Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Option to get. */
+ CONST char *optionName; /* Option to get. */
Tcl_DString *dsPtr; /* Where to store value(s). */
{
FileState *fsPtr = (FileState *) instanceData;
unsigned int len;
char buf[3 * TCL_INTEGER_SPACE + 16];
TtyAttrs tty;
+ int valid = 0; /* flag if valid option parsed */
if (optionName == NULL) {
- Tcl_DStringAppendElement(dsPtr, "-mode");
len = 0;
} else {
len = strlen(optionName);
}
- if ((len == 0) ||
- ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-mode");
+ }
+ if (len==0 || (len>2 && strncmp(optionName, "-mode", len)==0)) {
+ valid = 1;
TtyGetAttributes(fsPtr->fd, &tty);
sprintf(buf, "%d,%c,%d,%d", tty.baud, tty.parity, tty.data, tty.stop);
Tcl_DStringAppendElement(dsPtr, buf);
+ }
+
+#ifdef USE_TERMIOS
+ /*
+ * get option -xchar
+ */
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-xchar");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ if (len==0 || (len>1 && strncmp(optionName, "-xchar", len)==0)) {
+ IOSTATE iostate;
+ valid = 1;
+
+ GETIOSTATE(fsPtr->fd, &iostate);
+ sprintf(buf, "%c", iostate.c_cc[VSTART]);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ sprintf(buf, "%c", iostate.c_cc[VSTOP]);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ }
+
+ /*
+ * get option -queue
+ * option is readonly and returned by [fconfigure chan -queue]
+ * but not returned by unnamed [fconfigure chan]
+ */
+ if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
+ int inQueue=0, outQueue=0;
+ int inBuffered, outBuffered;
+ valid = 1;
+#ifdef GETREADQUEUE
+ GETREADQUEUE(fsPtr->fd, inQueue);
+#endif /* GETREADQUEUE */
+#ifdef GETWRITEQUEUE
+ GETWRITEQUEUE(fsPtr->fd, outQueue);
+#endif /* GETWRITEQUEUE */
+ inBuffered = Tcl_InputBuffered(fsPtr->channel);
+ outBuffered = Tcl_OutputBuffered(fsPtr->channel);
+
+ sprintf(buf, "%d", inBuffered+inQueue);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ sprintf(buf, "%d", outBuffered+outQueue);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+
+ /*
+ * get option -ttystatus
+ * option is readonly and returned by [fconfigure chan -ttystatus]
+ * but not returned by unnamed [fconfigure chan]
+ */
+ if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
+ int status;
+ valid = 1;
+ GETCONTROL(fsPtr->fd, &status);
+ TtyModemStatusStr(status, dsPtr);
+ }
+#endif /* USE_TERMIOS */
+
+ if (valid) {
return TCL_OK;
} else {
- return Tcl_BadChannelOption(interp, optionName, "mode");
+ return Tcl_BadChannelOption(interp, optionName,
+#ifdef USE_TERMIOS
+ "mode queue ttystatus xchar");
+#else /* !USE_TERMIOS */
+ "mode");
+#endif /* USE_TERMIOS */
}
}
\f
#ifdef B4800
# if (B4800 == 4800)
# define DIRECT_BAUD
-# endif
-#endif
+# endif /* B4800 == 4800 */
+#endif /* B4800 */
#ifdef DIRECT_BAUD
# define TtyGetSpeed(baud) ((unsigned) (baud))
# define TtyGetBaud(speed) ((int) (speed))
-#else
+#else /* !DIRECT_BAUD */
static struct {int baud; unsigned long speed;} speeds[] = {
#ifdef B0
int baud; /* The baud rate to look up. */
{
int bestIdx, bestDiff, i, diff;
-
+
bestIdx = 0;
bestDiff = 1000000;
-
+
/*
* If the baud rate does not correspond to one of the known mask values,
* choose the mask value whose baud rate is closest to the specified
unsigned long speed; /* Speed mask value to look up. */
{
int i;
-
+
for (i = 0; speeds[i].baud >= 0; i++) {
if (speeds[i].speed == speed) {
return speeds[i].baud;
return 0;
}
-#endif /* !DIRECT_BAUD */
+#endif /* !DIRECT_BAUD */
\f
/*
*
*---------------------------------------------------------------------------
*/
-
+
static void
TtyGetAttributes(fd, ttyPtr)
int fd; /* Open file descriptor for serial port to
#ifdef USE_TERMIOS
baud = TtyGetBaud(cfgetospeed(&iostate));
-
+
parity = 'n';
#ifdef PAREXT
switch ((int) (iostate.c_cflag & (PARENB | PARODD | PAREXT))) {
case PARENB : parity = 'e'; break;
- case PARENB | PARODD : parity = 'o'; break;
+ case PARENB | PARODD : parity = 'o'; break;
case PARENB | PAREXT : parity = 's'; break;
- case PARENB | PARODD | PAREXT : parity = 'm'; break;
+ case PARENB | PARODD | PAREXT : parity = 'm'; break;
}
-#else /* !PAREXT */
+#else /* !PAREXT */
switch ((int) (iostate.c_cflag & (PARENB | PARODD))) {
case PARENB : parity = 'e'; break;
- case PARENB | PARODD : parity = 'o'; break;
+ case PARENB | PARODD : parity = 'o'; break;
}
-#endif /* !PAREXT */
+#endif /* !PAREXT */
data = iostate.c_cflag & CSIZE;
data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8;
stop = (iostate.c_cflag & CSTOPB) ? 2 : 1;
-#endif /* USE_TERMIOS */
+#endif /* USE_TERMIOS */
#ifdef USE_TERMIO
baud = TtyGetBaud(iostate.c_cflag & CBAUD);
parity = 'n';
switch (iostate.c_cflag & (PARENB | PARODD | PAREXT)) {
case PARENB : parity = 'e'; break;
- case PARENB | PARODD : parity = 'o'; break;
+ case PARENB | PARODD : parity = 'o'; break;
case PARENB | PAREXT : parity = 's'; break;
- case PARENB | PARODD | PAREXT : parity = 'm'; break;
+ case PARENB | PARODD | PAREXT : parity = 'm'; break;
}
data = iostate.c_cflag & CSIZE;
data = (data == CS5) ? 5 : (data == CS6) ? 6 : (data == CS7) ? 7 : 8;
stop = (iostate.c_cflag & CSTOPB) ? 2 : 1;
-#endif /* USE_TERMIO */
+#endif /* USE_TERMIO */
#ifdef USE_SGTTY
baud = TtyGetBaud(iostate.sg_ospeed);
data = (iostate.sg_flags & (EVENP | ODDP)) ? 7 : 8;
stop = 1;
-#endif /* USE_SGTTY */
+#endif /* USE_SGTTY */
ttyPtr->baud = baud;
ttyPtr->parity = parity;
*
*---------------------------------------------------------------------------
*/
-
+
static void
TtySetAttributes(fd, ttyPtr)
int fd; /* Open file descriptor for serial port to
if ((parity == 'm') || (parity == 's')) {
flag |= PAREXT;
}
-#endif
+#endif /* PAREXT */
if ((parity == 'm') || (parity == 'o')) {
flag |= PARODD;
}
*
*---------------------------------------------------------------------------
*/
-
+
static int
TtyParseMode(interp, mode, speedPtr, parityPtr, dataPtr, stopPtr)
Tcl_Interp *interp; /* If non-NULL, interp for error return. */
strchr("noems", parity) == NULL
#else
strchr("noe", parity) == NULL
-#endif
+#endif /* PAREXT|USE_TERMIO */
) {
if (interp != NULL) {
Tcl_AppendResult(interp, bad,
" parity: should be n, o, e, m, or s",
#else
" parity: should be n, o, or e",
-#endif
+#endif /* PAREXT|USE_TERMIO */
NULL);
}
return TCL_ERROR;
* Given file descriptor that refers to a serial port,
* initialize the serial port to a set of sane values so that
* Tcl can talk to a device located on the serial port.
+ * Note that no initialization happens if the initialize flag
+ * is not set; this is necessary for the correct handling of
+ * UNIX console TTYs at startup.
*
* Results:
- * None.
+ * A pointer to a FileState suitable for use with Tcl_CreateChannel
+ * and the ttyChannelType structure.
*
* Side effects:
* Serial device initialized to non-blocking raw mode, similar to
- * sockets. All other modes can be simulated on top of this in Tcl.
+ * sockets (if initialize flag is non-zero.) All other modes can
+ * be simulated on top of this in Tcl.
*
*---------------------------------------------------------------------------
*/
static FileState *
-TtyInit(fd)
+TtyInit(fd, initialize)
int fd; /* Open file descriptor for serial port to
* be initialized. */
+ int initialize;
{
- IOSTATE iostate;
TtyState *ttyPtr;
ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState));
GETIOSTATE(fd, &ttyPtr->savedState);
-
- iostate = ttyPtr->savedState;
-
-#ifdef USE_TERMIOS
- iostate.c_iflag = IGNBRK;
- iostate.c_oflag = 0;
- iostate.c_lflag = 0;
- iostate.c_cflag |= CREAD;
- iostate.c_cc[VMIN] = 1;
- iostate.c_cc[VTIME] = 0;
-#endif /* USE_TERMIOS */
-
-#ifdef USE_TERMIO
- iostate.c_iflag = IGNBRK;
- iostate.c_oflag = 0;
- iostate.c_lflag = 0;
- iostate.c_cflag |= CREAD;
- iostate.c_cc[VMIN] = 1;
- iostate.c_cc[VTIME] = 0;
-#endif /* USE_TERMIO */
+ ttyPtr->stateUpdated = 0;
+ if (initialize) {
+ IOSTATE iostate = ttyPtr->savedState;
+
+#if defined(USE_TERMIOS) || defined(USE_TERMIO)
+ if (iostate.c_iflag != IGNBRK ||
+ iostate.c_oflag != 0 ||
+ iostate.c_lflag != 0 ||
+ iostate.c_cflag & CREAD ||
+ iostate.c_cc[VMIN] != 1 ||
+ iostate.c_cc[VTIME] != 0) {
+ ttyPtr->stateUpdated = 1;
+ }
+ iostate.c_iflag = IGNBRK;
+ iostate.c_oflag = 0;
+ iostate.c_lflag = 0;
+ iostate.c_cflag |= CREAD;
+ iostate.c_cc[VMIN] = 1;
+ iostate.c_cc[VTIME] = 0;
+#endif /* USE_TERMIOS|USE_TERMIO */
#ifdef USE_SGTTY
- iostate.sg_flags &= (EVENP | ODDP);
- iostate.sg_flags |= RAW;
+ if ((iostate.sg_flags & (EVENP | ODDP)) ||
+ !(iostate.sg_flags & RAW)) {
+ ttyPtr->stateUpdated = 1;
+ }
+ iostate.sg_flags &= (EVENP | ODDP);
+ iostate.sg_flags |= RAW;
#endif /* USE_SGTTY */
- SETIOSTATE(fd, &iostate);
+ /*
+ * Only update if we're changing anything to avoid possible
+ * blocking.
+ */
+ if (ttyPtr->stateUpdated) {
+ SETIOSTATE(fd, &iostate);
+ }
+ }
return &ttyPtr->fs;
}
*/
Tcl_Channel
-TclpOpenFileChannel(interp, fileName, modeString, permissions)
+TclpOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- char *fileName; /* Name of file to open. */
- char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
+ * can be NULL. */
+ Tcl_Obj *pathPtr; /* Name of file to open. */
+ int mode; /* POSIX open mode. */
int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
+ * file, with what modes to create
+ * it? */
{
- int fd, seekFlag, mode, channelPermissions;
+ int fd, channelPermissions;
FileState *fsPtr;
- char *native, *translation;
+ CONST char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
- Tcl_DString ds, buffer;
Tcl_ChannelType *channelTypePtr;
+#ifdef SUPPORTS_TTY
+ int ctl_tty;
+#endif /* SUPPORTS_TTY */
+#ifdef DEPRECATED
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+#endif /* DEPRECATED */
- mode = TclGetOpenMode(interp, modeString, &seekFlag);
- if (mode == -1) {
- return NULL;
- }
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
channelPermissions = TCL_READABLE;
channelPermissions = (TCL_READABLE | TCL_WRITABLE);
break;
default:
- /*
- * This may occurr if modeString was "", for example.
- */
+ /*
+ * This may occurr if modeString was "", for example.
+ */
panic("TclpOpenFileChannel: invalid mode value");
return NULL;
}
- native = Tcl_TranslateFileName(interp, fileName, &buffer);
+ native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return NULL;
}
- native = Tcl_UtfToExternalDString(NULL, native, -1, &ds);
- fd = open(native, mode, permissions); /* INTL: Native. */
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&buffer);
+ fd = TclOSopen(native, mode, permissions);
+#ifdef SUPPORTS_TTY
+ ctl_tty = (strcmp (native, "/dev/tty") == 0);
+#endif /* SUPPORTS_TTY */
if (fd < 0) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- }
- return NULL;
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp, "couldn't open \"",
+ Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return NULL;
}
/*
* Set close-on-exec flag on the fd so that child processes will not
* inherit this fd.
*/
-
+
fcntl(fd, F_SETFD, FD_CLOEXEC);
-
+
sprintf(channelName, "file%d", fd);
-
+
#ifdef SUPPORTS_TTY
- if (isatty(fd)) {
+ if (!ctl_tty && isatty(fd)) {
/*
* Initialize the serial port to a set of sane parameters.
* Especially important if the remote device is set to echo and
* were sent to the serial port, the remote device would echo it,
* then the serial driver would echo it back to the device, etc.
*/
-
+
translation = "auto crlf";
channelTypePtr = &ttyChannelType;
- fsPtr = TtyInit(fd);
+ fsPtr = TtyInit(fd, 1);
} else
#endif /* SUPPORTS_TTY */
{
fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
}
+#ifdef DEPRECATED
fsPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = fsPtr;
+#endif /* DEPRECATED */
fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fd = fd;
-
+
fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
(ClientData) fsPtr, channelPermissions);
- if (seekFlag) {
- if (Tcl_Seek(fsPtr->channel, 0, SEEK_END) < 0) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't seek to end of file on \"",
- channelName, "\": ", Tcl_PosixError(interp), NULL);
- }
- Tcl_Close(NULL, fsPtr->channel);
- return NULL;
- }
- }
-
if (translation != NULL) {
/*
* Gotcha. Most modems need a "\r" at the end of the command
* command. So, by default, newlines are translated to "\r\n" on
* output to avoid "bug" reports that the serial port isn't working.
*/
-
+
if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation",
translation) != TCL_OK) {
Tcl_Close(NULL, fsPtr->channel);
Tcl_MakeFileChannel(handle, mode)
ClientData handle; /* OS level handle. */
int mode; /* ORed combination of TCL_READABLE and
- * TCL_WRITABLE to indicate file mode. */
+ * TCL_WRITABLE to indicate file mode. */
{
FileState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = (int) handle;
+ Tcl_ChannelType *channelTypePtr;
+#ifdef DEPRECATED
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+#endif /* DEPRECATED */
+ int socketType = 0;
+ socklen_t argLength = sizeof(int);
if (mode == 0) {
- return NULL;
+ return NULL;
}
- sprintf(channelName, "file%d", fd);
/*
* Look to see if a channel with this fd and the same mode already exists.
* If the fd is used, but the mode doesn't match, return NULL.
*/
-
+
+#ifdef DEPRECATED
for (fsPtr = tsdPtr->firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) {
if (fsPtr->fd == fd) {
return ((mode|TCL_EXCEPTION) == fsPtr->validMask) ?
fsPtr->channel : NULL;
}
}
+#endif /* DEPRECATED */
- fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
+#ifdef SUPPORTS_TTY
+ if (isatty(fd)) {
+ fsPtr = TtyInit(fd, 0);
+ channelTypePtr = &ttyChannelType;
+ sprintf(channelName, "serial%d", fd);
+ } else
+#endif /* SUPPORTS_TTY */
+ if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (VOID *)&socketType,
+ &argLength) == 0 && socketType == SOCK_STREAM) {
+ /*
+ * The mode parameter gets lost here, unfortunately.
+ */
+ return Tcl_MakeTcpClientChannel((ClientData) fd);
+ } else {
+ channelTypePtr = &fileChannelType;
+ fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
+ sprintf(channelName, "file%d", fd);
+ }
+
+#ifdef DEPRECATED
fsPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = fsPtr;
-
+#endif /* DEPRECATED */
fsPtr->fd = fd;
fsPtr->validMask = mode | TCL_EXCEPTION;
- fsPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
- (ClientData) fsPtr, mode);
-
+ fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
+ (ClientData) fsPtr, mode);
+
return fsPtr->channel;
}
\f
TcpBlockModeProc(instanceData, mode)
ClientData instanceData; /* Socket state. */
int mode; /* The mode to set. Can be one of
- * TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+ * TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
{
TcpState *statePtr = (TcpState *) instanceData;
int setting;
-
-#ifndef USE_FIONBIO
+
+#ifndef USE_FIONBIO
setting = fcntl(statePtr->fd, F_GETFL);
if (mode == TCL_MODE_BLOCKING) {
- statePtr->flags &= (~(TCP_ASYNC_SOCKET));
- setting &= (~(O_NONBLOCK));
+ statePtr->flags &= (~(TCP_ASYNC_SOCKET));
+ setting &= (~(O_NONBLOCK));
} else {
- statePtr->flags |= TCP_ASYNC_SOCKET;
- setting |= O_NONBLOCK;
+ statePtr->flags |= TCP_ASYNC_SOCKET;
+ setting |= O_NONBLOCK;
}
if (fcntl(statePtr->fd, F_SETFL, setting) < 0) {
- return errno;
+ return errno;
}
-#endif
-
-#ifdef USE_FIONBIO
+#else /* USE_FIONBIO */
if (mode == TCL_MODE_BLOCKING) {
- statePtr->flags &= (~(TCP_ASYNC_SOCKET));
- setting = 0;
- if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) {
- return errno;
- }
+ statePtr->flags &= (~(TCP_ASYNC_SOCKET));
+ setting = 0;
+ if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) {
+ return errno;
+ }
} else {
- statePtr->flags |= TCP_ASYNC_SOCKET;
- setting = 1;
- if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) {
- return errno;
- }
+ statePtr->flags |= TCP_ASYNC_SOCKET;
+ setting = 1;
+ if (ioctl(statePtr->fd, (int) FIONBIO, &setting) == -1) {
+ return errno;
+ }
}
-#endif
+#endif /* !USE_FIONBIO */
return 0;
}
* If an asynchronous connect is in progress, attempt to wait for it
* to complete before reading.
*/
-
+
if (statePtr->flags & TCP_ASYNC_CONNECT) {
- if (statePtr->flags & TCP_ASYNC_SOCKET) {
- timeOut = 0;
- } else {
- timeOut = -1;
- }
- errno = 0;
- state = TclUnixWaitForFile(statePtr->fd,
+ if (statePtr->flags & TCP_ASYNC_SOCKET) {
+ timeOut = 0;
+ } else {
+ timeOut = -1;
+ }
+ errno = 0;
+ state = TclUnixWaitForFile(statePtr->fd,
TCL_WRITABLE | TCL_EXCEPTION, timeOut);
- if (!(statePtr->flags & TCP_ASYNC_SOCKET)) {
-#ifndef USE_FIONBIO
- flags = fcntl(statePtr->fd, F_GETFL);
- flags &= (~(O_NONBLOCK));
- (void) fcntl(statePtr->fd, F_SETFL, flags);
-#endif
-
-#ifdef USE_FIONBIO
- flags = 0;
- (void) ioctl(statePtr->fd, FIONBIO, &flags);
-#endif
- }
- if (state & TCL_EXCEPTION) {
- return -1;
- }
- if (state & TCL_WRITABLE) {
- statePtr->flags &= (~(TCP_ASYNC_CONNECT));
- } else if (timeOut == 0) {
- *errorCodePtr = errno = EWOULDBLOCK;
- return -1;
- }
+ if (!(statePtr->flags & TCP_ASYNC_SOCKET)) {
+#ifndef USE_FIONBIO
+ flags = fcntl(statePtr->fd, F_GETFL);
+ flags &= (~(O_NONBLOCK));
+ (void) fcntl(statePtr->fd, F_SETFL, flags);
+#else /* USE_FIONBIO */
+ flags = 0;
+ (void) ioctl(statePtr->fd, FIONBIO, &flags);
+#endif /* !USE_FIONBIO */
+ }
+ if (state & TCL_EXCEPTION) {
+ return -1;
+ }
+ if (state & TCL_WRITABLE) {
+ statePtr->flags &= (~(TCP_ASYNC_CONNECT));
+ } else if (timeOut == 0) {
+ *errorCodePtr = errno = EWOULDBLOCK;
+ return -1;
+ }
}
return 0;
}
ClientData instanceData; /* Socket state. */
char *buf; /* Where to store data read. */
int bufSize; /* How much space is available
- * in the buffer? */
+ * in the buffer? */
int *errorCodePtr; /* Where to store error code. */
{
TcpState *statePtr = (TcpState *) instanceData;
*errorCodePtr = 0;
state = WaitForConnect(statePtr, errorCodePtr);
if (state != 0) {
- return -1;
+ return -1;
}
bytesRead = recv(statePtr->fd, buf, (size_t) bufSize, 0);
if (bytesRead > -1) {
- return bytesRead;
+ return bytesRead;
}
if (errno == ECONNRESET) {
+ /*
+ * Turn ECONNRESET into a soft EOF condition.
+ */
- /*
- * Turn ECONNRESET into a soft EOF condition.
- */
-
- return 0;
+ return 0;
}
*errorCodePtr = errno;
return -1;
static int
TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
ClientData instanceData; /* Socket state. */
- char *buf; /* The data buffer. */
+ CONST char *buf; /* The data buffer. */
int toWrite; /* How many bytes to write? */
int *errorCodePtr; /* Where to store error code. */
{
*errorCodePtr = 0;
state = WaitForConnect(statePtr, errorCodePtr);
if (state != 0) {
- return -1;
+ return -1;
}
written = send(statePtr->fd, buf, (size_t) toWrite, 0);
if (written > -1) {
- return written;
+ return written;
}
*errorCodePtr = errno;
return -1;
*
* Results:
* A standard Tcl result. The value of the specified option or a
- * list of all options and their values is returned in the
+ * list of all options and their values is returned in the
* supplied DString. Sets Error message if needed.
*
* Side effects:
static int
TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
- ClientData instanceData; /* Socket state. */
- Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Name of the option to
+ ClientData instanceData; /* Socket state. */
+ Tcl_Interp *interp; /* For error reporting - can be NULL. */
+ CONST char *optionName; /* Name of the option to
* retrieve the value for, or
* NULL to get all options and
* their values. */
- Tcl_DString *dsPtr; /* Where to store the computed
+ Tcl_DString *dsPtr; /* Where to store the computed
* value; initialized by caller. */
{
TcpState *statePtr = (TcpState *) instanceData;
struct sockaddr_in sockname;
struct sockaddr_in peername;
struct hostent *hostEntPtr;
- int size = sizeof(struct sockaddr_in);
+ socklen_t size = sizeof(struct sockaddr_in);
size_t len = 0;
char buf[TCL_INTEGER_SPACE];
if (optionName != (char *) NULL) {
- len = strlen(optionName);
+ len = strlen(optionName);
}
if ((len > 1) && (optionName[1] == 'e') &&
(strncmp(optionName, "-error", len) == 0)) {
- int optlen;
+ socklen_t optlen = sizeof(int);
int err, ret;
-
- optlen = sizeof(int);
+
ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR,
(char *)&err, &optlen);
if (ret < 0) {
if (err != 0) {
Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1);
}
- return TCL_OK;
+ return TCL_OK;
}
if ((len == 0) ||
- ((len > 1) && (optionName[1] == 'p') &&
- (strncmp(optionName, "-peername", len) == 0))) {
- if (getpeername(statePtr->fd, (struct sockaddr *) &peername,
+ ((len > 1) && (optionName[1] == 'p') &&
+ (strncmp(optionName, "-peername", len) == 0))) {
+ if (getpeername(statePtr->fd, (struct sockaddr *) &peername,
&size) >= 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-peername");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
- hostEntPtr = gethostbyaddr( /* INTL: Native. */
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-peername");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
+ hostEntPtr = gethostbyaddr( /* INTL: Native. */
(char *) &peername.sin_addr,
sizeof(peername.sin_addr), AF_INET);
- if (hostEntPtr != NULL) {
+ if (hostEntPtr != NULL) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds);
- Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
- } else {
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
- }
- TclFormatInt(buf, ntohs(peername.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
- }
- } else {
- /*
- * getpeername failed - but if we were asked for all the options
- * (len==0), don't flag an error at that point because it could
- * be an fconfigure request on a server socket. (which have
- * no peer). same must be done on win&mac.
- */
-
- if (len) {
- if (interp) {
- Tcl_AppendResult(interp, "can't get peername: ",
- Tcl_PosixError(interp),
- (char *) NULL);
- }
- return TCL_ERROR;
- }
- }
+ Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
+ } else {
+ Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
+ }
+ TclFormatInt(buf, ntohs(peername.sin_port));
+ Tcl_DStringAppendElement(dsPtr, buf);
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ } else {
+ return TCL_OK;
+ }
+ } else {
+ /*
+ * getpeername failed - but if we were asked for all the options
+ * (len==0), don't flag an error at that point because it could
+ * be an fconfigure request on a server socket. (which have
+ * no peer). same must be done on win&mac.
+ */
+
+ if (len) {
+ if (interp) {
+ Tcl_AppendResult(interp, "can't get peername: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ }
}
if ((len == 0) ||
- ((len > 1) && (optionName[1] == 's') &&
- (strncmp(optionName, "-sockname", len) == 0))) {
- if (getsockname(statePtr->fd, (struct sockaddr *) &sockname, &size)
- >= 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-sockname");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
- hostEntPtr = gethostbyaddr( /* INTL: Native. */
+ ((len > 1) && (optionName[1] == 's') &&
+ (strncmp(optionName, "-sockname", len) == 0))) {
+ if (getsockname(statePtr->fd, (struct sockaddr *) &sockname,
+ &size) >= 0) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-sockname");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
+ hostEntPtr = gethostbyaddr( /* INTL: Native. */
(char *) &sockname.sin_addr,
- sizeof(sockname.sin_addr), AF_INET);
- if (hostEntPtr != (struct hostent *) NULL) {
+ sizeof(sockname.sin_addr), AF_INET);
+ if (hostEntPtr != (struct hostent *) NULL) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds);
- Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
- } else {
- Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
- }
- TclFormatInt(buf, ntohs(sockname.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
- }
- } else {
+ Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
+ } else {
+ Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
+ }
+ TclFormatInt(buf, ntohs(sockname.sin_port));
+ Tcl_DStringAppendElement(dsPtr, buf);
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ } else {
+ return TCL_OK;
+ }
+ } else {
if (interp) {
Tcl_AppendResult(interp, "can't get sockname: ",
- Tcl_PosixError(interp),
- (char *) NULL);
+ Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
}
}
if (len > 0) {
- return Tcl_BadChannelOption(interp, optionName, "peername sockname");
+ return Tcl_BadChannelOption(interp, optionName, "peername sockname");
}
return TCL_OK;
TcpWatchProc(instanceData, mask)
ClientData instanceData; /* The socket state. */
int mask; /* Events of interest; an OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
+ * combination of TCL_READABLE,
+ * TCL_WRITABLE and TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *) instanceData;
CreateSocket(interp, port, host, server, myaddr, myport, async)
Tcl_Interp *interp; /* For error reporting; can be NULL. */
int port; /* Port number to open. */
- char *host; /* Name of host on which to open port.
+ CONST char *host; /* Name of host on which to open port.
* NULL implies INADDR_ANY */
int server; /* 1 if socket should be a server socket,
* else 0 for a client socket. */
- char *myaddr; /* Optional client-side address */
+ CONST char *myaddr; /* Optional client-side address */
int myport; /* Optional client-side port */
int async; /* If nonzero and creating a client socket,
- * attempt to do an async connect. Otherwise
- * do a synchronous connect or bind. */
+ * attempt to do an async connect. Otherwise
+ * do a synchronous connect or bind. */
{
int status, sock, asyncConnect, curState, origState;
struct sockaddr_in sockaddr; /* socket address */
*/
fcntl(sock, F_SETFD, FD_CLOEXEC);
-
+
/*
* Set kernel space buffering
*/
asyncConnect = 0;
status = 0;
if (server) {
-
/*
* Set up to reuse server addresses automatically and bind to the
* specified port.
*/
-
+
status = 1;
(void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, (char *) &status,
sizeof(status));
status = bind(sock, (struct sockaddr *) &sockaddr,
- sizeof(struct sockaddr));
+ sizeof(struct sockaddr));
if (status != -1) {
status = listen(sock, SOMAXCONN);
}
if (myaddr != NULL || myport != 0) {
curState = 1;
(void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
- (char *) &curState, sizeof(curState));
+ (char *) &curState, sizeof(curState));
status = bind(sock, (struct sockaddr *) &mysockaddr,
sizeof(struct sockaddr));
if (status < 0) {
* being informed when the connect completes.
*/
- if (async) {
-#ifndef USE_FIONBIO
- origState = fcntl(sock, F_GETFL);
- curState = origState | O_NONBLOCK;
- status = fcntl(sock, F_SETFL, curState);
-#endif
-
-#ifdef USE_FIONBIO
- curState = 1;
- status = ioctl(sock, FIONBIO, &curState);
-#endif
- } else {
- status = 0;
- }
- if (status > -1) {
- status = connect(sock, (struct sockaddr *) &sockaddr,
- sizeof(sockaddr));
- if (status < 0) {
- if (errno == EINPROGRESS) {
- asyncConnect = 1;
- status = 0;
- }
+ if (async) {
+#ifndef USE_FIONBIO
+ origState = fcntl(sock, F_GETFL);
+ curState = origState | O_NONBLOCK;
+ status = fcntl(sock, F_SETFL, curState);
+#else /* USE_FIONBIO */
+ curState = 1;
+ status = ioctl(sock, FIONBIO, &curState);
+#endif /* !USE_FIONBIO */
+ } else {
+ status = 0;
+ }
+ if (status > -1) {
+ status = connect(sock, (struct sockaddr *) &sockaddr,
+ sizeof(sockaddr));
+ if (status < 0) {
+ if (errno == EINPROGRESS) {
+ asyncConnect = 1;
+ status = 0;
+ }
} else {
/*
* Here we are if the connect succeeds. In case of an
origState = fcntl(sock, F_GETFL);
curState = origState & ~(O_NONBLOCK);
status = fcntl(sock, F_SETFL, curState);
-#endif
-
-#ifdef USE_FIONBIO
+#else /* USE_FIONBIO */
curState = 0;
status = ioctl(sock, FIONBIO, &curState);
-#endif
+#endif /* !USE_FIONBIO */
}
}
- }
+ }
}
bindError:
if (status < 0) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open socket: ",
- Tcl_PosixError(interp), (char *) NULL);
- }
- if (sock != -1) {
- close(sock);
- }
- return NULL;
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "couldn't open socket: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ if (sock != -1) {
+ close(sock);
+ }
+ return NULL;
}
/*
statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState));
statePtr->flags = 0;
if (asyncConnect) {
- statePtr->flags = TCP_ASYNC_CONNECT;
+ statePtr->flags = TCP_ASYNC_CONNECT;
}
statePtr->fd = sock;
addressError:
if (sock != -1) {
- close(sock);
+ close(sock);
}
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't open socket: ",
static int
CreateSocketAddress(sockaddrPtr, host, port)
struct sockaddr_in *sockaddrPtr; /* Socket address */
- char *host; /* Host. NULL implies INADDR_ANY */
+ CONST char *host; /* Host. NULL implies INADDR_ANY */
int port; /* Port number */
{
struct hostent *hostent; /* Host database entry */
} else {
native = Tcl_UtfToExternalDString(NULL, host, -1, &ds);
}
- addr.s_addr = inet_addr(native); /* INTL: Native. */
+ addr.s_addr = inet_addr(native); /* INTL: Native. */
/*
* This is 0xFFFFFFFF to ensure that it compares as a 32bit -1
* on either 32 or 64 bits systems.
*/
- if (addr.s_addr == 0xFFFFFFFF) {
- hostent = gethostbyname(native); /* INTL: Native. */
- if (hostent != NULL) {
- memcpy((VOID *) &addr,
- (VOID *) hostent->h_addr_list[0],
- (size_t) hostent->h_length);
- } else {
+ if (addr.s_addr == 0xFFFFFFFF) {
+ hostent = gethostbyname(native); /* INTL: Native. */
+ if (hostent != NULL) {
+ memcpy((VOID *) &addr,
+ (VOID *) hostent->h_addr_list[0],
+ (size_t) hostent->h_length);
+ } else {
#ifdef EHOSTUNREACH
- errno = EHOSTUNREACH;
-#else
+ errno = EHOSTUNREACH;
+#else /* !EHOSTUNREACH */
#ifdef ENXIO
- errno = ENXIO;
-#endif
-#endif
+ errno = ENXIO;
+#endif /* ENXIO */
+#endif /* EHOSTUNREACH */
if (native != NULL) {
Tcl_DStringFree(&ds);
}
- return 0; /* error */
- }
- }
+ return 0; /* error */
+ }
+ }
if (native != NULL) {
Tcl_DStringFree(&ds);
}
}
-
+
/*
* NOTE: On 64 bit machines the assignment below is rumored to not
* do the right thing. Please report errors related to this if you
* Opens a TCP client socket and creates a channel around it.
*
* Results:
- * The channel or NULL if failed. An error message is returned
+ * The channel or NULL if failed. An error message is returned
* in the interpreter on failure.
*
* Side effects:
Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
Tcl_Interp *interp; /* For error reporting; can be NULL. */
int port; /* Port number to open. */
- char *host; /* Host on which to open port. */
- char *myaddr; /* Client-side address */
+ CONST char *host; /* Host on which to open port. */
+ CONST char *myaddr; /* Client-side address */
int myport; /* Client-side port */
int async; /* If nonzero, attempt to do an
- * asynchronous connect. Otherwise
- * we do a blocking connect. */
+ * asynchronous connect. Otherwise
+ * we do a blocking connect. */
{
TcpState *statePtr;
char channelName[16 + TCL_INTEGER_SPACE];
sprintf(channelName, "sock%d", statePtr->fd);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE));
+ (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
"auto crlf") == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, statePtr->channel);
- return NULL;
+ Tcl_Close((Tcl_Interp *) NULL, statePtr->channel);
+ return NULL;
}
return statePtr->channel;
}
statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState));
statePtr->fd = (int) sock;
+ statePtr->flags = 0;
statePtr->acceptProc = NULL;
statePtr->acceptProcData = (ClientData) NULL;
sprintf(channelName, "sock%d", statePtr->fd);
-
+
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE));
+ (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption((Tcl_Interp *) NULL, statePtr->channel,
"-translation", "auto crlf") == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, statePtr->channel);
- return NULL;
+ Tcl_Close((Tcl_Interp *) NULL, statePtr->channel);
+ return NULL;
}
return statePtr->channel;
}
Tcl_Channel
Tcl_OpenTcpServer(interp, port, myHost, acceptProc, acceptProcData)
Tcl_Interp *interp; /* For error reporting - may be
- * NULL. */
+ * NULL. */
int port; /* Port number to open. */
- char *myHost; /* Name of local host. */
+ CONST char *myHost; /* Name of local host. */
Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections
- * from new clients. */
+ * from new clients. */
ClientData acceptProcData; /* Data for the callback. */
{
TcpState *statePtr;
*/
Tcl_CreateFileHandler(statePtr->fd, TCL_READABLE, TcpAccept,
- (ClientData) statePtr);
+ (ClientData) statePtr);
sprintf(channelName, "sock%d", statePtr->fd);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) statePtr, 0);
+ (ClientData) statePtr, 0);
return statePtr->channel;
}
\f
*----------------------------------------------------------------------
*
* TcpAccept --
- * Accept a TCP socket connection. This is called by the event loop.
+ * Accept a TCP socket connection. This is called by the event loop.
*
* Results:
* None.
int newsock; /* The new client socket */
TcpState *newSockState; /* State for new socket. */
struct sockaddr_in addr; /* The remote address */
- int len; /* For accept interface */
+ socklen_t len; /* For accept interface */
char channelName[16 + TCL_INTEGER_SPACE];
sockState = (TcpState *) data;
len = sizeof(struct sockaddr_in);
newsock = accept(sockState->fd, (struct sockaddr *) &addr, &len);
if (newsock < 0) {
- return;
+ return;
}
/*
*/
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
-
+
newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState));
newSockState->flags = 0;
newSockState->fd = newsock;
newSockState->acceptProc = NULL;
newSockState->acceptProcData = NULL;
-
+
sprintf(channelName, "sock%d", newsock);
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
(ClientData) newSockState, (TCL_READABLE | TCL_WRITABLE));
int mode = 0; /* compiler warning (used before set). */
char *bufMode = NULL;
+ /*
+ * Some #def's to make the code a little clearer!
+ */
+#define ZERO_OFFSET ((Tcl_SeekOffset) 0)
+#define ERROR_OFFSET ((Tcl_SeekOffset) -1)
+
switch (type) {
- case TCL_STDIN:
- if ((lseek(0, (off_t) 0, SEEK_CUR) == -1) &&
- (errno == EBADF)) {
- return (Tcl_Channel) NULL;
- }
+ case TCL_STDIN:
+ if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
+ && (errno == EBADF)) {
+ return (Tcl_Channel) NULL;
+ }
fd = 0;
mode = TCL_READABLE;
- bufMode = "line";
- break;
- case TCL_STDOUT:
- if ((lseek(1, (off_t) 0, SEEK_CUR) == -1) &&
- (errno == EBADF)) {
- return (Tcl_Channel) NULL;
- }
+ bufMode = "line";
+ break;
+ case TCL_STDOUT:
+ if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
+ && (errno == EBADF)) {
+ return (Tcl_Channel) NULL;
+ }
fd = 1;
mode = TCL_WRITABLE;
- bufMode = "line";
- break;
- case TCL_STDERR:
- if ((lseek(2, (off_t) 0, SEEK_CUR) == -1) &&
- (errno == EBADF)) {
- return (Tcl_Channel) NULL;
- }
+ bufMode = "line";
+ break;
+ case TCL_STDERR:
+ if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
+ && (errno == EBADF)) {
+ return (Tcl_Channel) NULL;
+ }
fd = 2;
mode = TCL_WRITABLE;
bufMode = "none";
- break;
+ break;
default:
panic("TclGetDefaultStdChannel: Unexpected channel type");
break;
}
+#undef ZERO_OFFSET
+#undef ERROR_OFFSET
+
channel = Tcl_MakeFileChannel((ClientData) fd, mode);
if (channel == NULL) {
return NULL;
* Set up the normal channel options for stdio handles.
*/
- Tcl_SetChannelOption(NULL, channel, "-translation", "auto");
+ if (Tcl_GetChannelType(channel) == &fileChannelType) {
+ Tcl_SetChannelOption(NULL, channel, "-translation", "auto");
+ } else {
+ Tcl_SetChannelOption(NULL, channel, "-translation", "auto crlf");
+ }
Tcl_SetChannelOption(NULL, channel, "-buffering", bufMode);
return channel;
}
int
Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr)
Tcl_Interp *interp; /* Interpreter in which to find file. */
- char *string; /* String that identifies file. */
+ CONST char *string; /* String that identifies file. */
int forWriting; /* 1 means the file is going to be used
* for writing, 0 means for reading. */
int checkUsage; /* 1 means verify that the file was opened
* in a mode that allows the access specified
* by "forWriting". Ignored, we always
- * check that the channel is open for the
- * requested mode. */
+ * check that the channel is open for the
+ * requested mode. */
ClientData *filePtr; /* Store pointer to FILE structure here. */
{
Tcl_Channel chan;
ClientData data;
int fd;
FILE *f;
-
+
chan = Tcl_GetChannel(interp, string, &chanMode);
if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) {
- Tcl_AppendResult(interp,
- "\"", string, "\" wasn't opened for writing", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\"", string, "\" wasn't opened for writing", (char *) NULL);
+ return TCL_ERROR;
} else if ((!(forWriting)) && ((chanMode & TCL_READABLE) == 0)) {
- Tcl_AppendResult(interp,
- "\"", string, "\" wasn't opened for reading", (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendResult(interp,
+ "\"", string, "\" wasn't opened for reading", (char *) NULL);
+ return TCL_ERROR;
}
/*
if ((chanTypePtr == &fileChannelType)
#ifdef SUPPORTS_TTY
|| (chanTypePtr == &ttyChannelType)
-#endif /* SUPPORTS_TTY */
+#endif /* SUPPORTS_TTY */
|| (chanTypePtr == &tcpChannelType)
|| (strcmp(chanTypePtr->typeName, "pipe") == 0)) {
- if (Tcl_GetChannelHandle(chan,
+ if (Tcl_GetChannelHandle(chan,
(forWriting ? TCL_WRITABLE : TCL_READABLE),
(ClientData*) &data) == TCL_OK) {
fd = (int) data;
* truncate an existing file if the file is being opened
* for writing....
*/
-
+
f = fdopen(fd, (forWriting ? "w" : "r"));
if (f == NULL) {
Tcl_AppendResult(interp, "cannot get a FILE * for \"", string,
}
Tcl_AppendResult(interp, "\"", string,
- "\" cannot be used to get a FILE *", (char *) NULL);
- return TCL_ERROR;
+ "\" cannot be used to get a FILE *", (char *) NULL);
+ return TCL_ERROR;
}
\f
/*
*/
if (timeout > 0) {
- TclpGetTime(&now);
+ Tcl_GetTime(&now);
abortTime.sec = now.sec + timeout/1000;
abortTime.usec = now.usec + (timeout%1000)*1000;
if (abortTime.usec >= 1000000) {
memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
index = fd/(NBBY*sizeof(fd_mask));
bit = 1 << (fd%(NBBY*sizeof(fd_mask)));
-
+
/*
* Loop in a mini-event loop of our own, waiting for either the
* file to become ready or a timeout to occur.
blockTime.tv_usec = 0;
}
}
-
+
/*
* Set the appropriate bit in the ready masks for the fd.
*/
* The select returned early, so we need to recompute the timeout.
*/
- TclpGetTime(&now);
+ Tcl_GetTime(&now);
if ((abortTime.sec < now.sec)
|| ((abortTime.sec == now.sec)
&& (abortTime.usec <= now.usec))) {
}
return result;
}
-
-
* early, go back to sleep again.
*/
- TclpGetTime(&before);
+ Tcl_GetTime(&before);
after = before;
after.sec += ms/1000;
after.usec += (ms%1000)*1000;
}
(void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0,
(SELECT_MASK *) 0, &delay);
- TclpGetTime(&before);
+ Tcl_GetTime(&before);
}
}
-
*/
static int GetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int GetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int GetPermissionsAttribute _ANSI_ARGS_((
Tcl_Interp *interp, int objIndex,
- CONST char *fileName, Tcl_Obj **attributePtrPtr));
+ Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr));
static int SetGroupAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr));
static int SetOwnerAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr));
static int SetPermissionsAttribute _ANSI_ARGS_((
Tcl_Interp *interp, int objIndex,
- CONST char *fileName, Tcl_Obj *attributePtr));
+ Tcl_Obj *fileName, Tcl_Obj *attributePtr));
static int GetModeFromPermString _ANSI_ARGS_((
Tcl_Interp *interp, char *modeStringPtr,
mode_t *modePtr));
*/
typedef int (TraversalProc) _ANSI_ARGS_((Tcl_DString *srcPtr,
- Tcl_DString *dstPtr, CONST struct stat *statBufPtr, int type,
+ Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr, int type,
Tcl_DString *errorPtr));
/*
UNIX_PERMISSIONS_ATTRIBUTE
};
-char *tclpFileAttrStrings[] = {
+CONST char *tclpFileAttrStrings[] = {
"-group",
"-owner",
"-permissions",
*/
static int CopyFile _ANSI_ARGS_((CONST char *src,
- CONST char *dst, CONST struct stat *statBufPtr));
+ CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
static int CopyFileAtts _ANSI_ARGS_((CONST char *src,
- CONST char *dst, CONST struct stat *statBufPtr));
-static int DoCopyFile _ANSI_ARGS_((Tcl_DString *srcPtr,
- Tcl_DString *dstPtr));
-static int DoCreateDirectory _ANSI_ARGS_((Tcl_DString *pathPtr));
-static int DoDeleteFile _ANSI_ARGS_((Tcl_DString *pathPtr));
+ CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
+static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr,
+ CONST char *dstPtr));
+static int DoCreateDirectory _ANSI_ARGS_((CONST char *pathPtr));
+static int DoDeleteFile _ANSI_ARGS_((CONST char *path));
static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr,
int recursive, Tcl_DString *errorPtr));
static int DoRenameFile _ANSI_ARGS_((CONST char *src,
CONST char *dst));
static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr,
- Tcl_DString *dstPtr, CONST struct stat *statBufPtr,
+ Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
int type, Tcl_DString *errorPtr));
static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr,
- Tcl_DString *dstPtr, CONST struct stat *statBufPtr,
+ Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
int type, Tcl_DString *errorPtr));
static int TraverseUnixTree _ANSI_ARGS_((
TraversalProc *traversalProc,
Tcl_DString *sourcePtr, Tcl_DString *destPtr,
Tcl_DString *errorPtr));
+
+#ifdef PURIFY
+/*
+ * realpath and purify don't mix happily. It has been noted that realpath
+ * should not be used with purify because of bogus warnings, but just
+ * memset'ing the resolved path will squelch those. This assumes we are
+ * passing the standard MAXPATHLEN size resolved arg.
+ */
+static char * Realpath _ANSI_ARGS_((CONST char *path,
+ char *resolved));
+
+char *
+Realpath(path, resolved)
+ CONST char *path;
+ char *resolved;
+{
+ memset(resolved, 0, MAXPATHLEN);
+ return realpath(path, resolved);
+}
+#else
+#define Realpath realpath
+#endif
+
\f
/*
*---------------------------------------------------------------------------
*
- * TclpRenameFile, DoRenameFile --
+ * TclpObjRenameFile, DoRenameFile --
*
* Changes the name of an existing file or directory, from src to dst.
* If src and dst refer to the same file or directory, does nothing
*---------------------------------------------------------------------------
*/
-int
-TclpRenameFile(src, dst)
- CONST char *src; /* Pathname of file or dir to be renamed
- * (UTF-8). */
- CONST char *dst; /* New pathname of file or directory
- * (UTF-8). */
+int
+TclpObjRenameFile(srcPathPtr, destPathPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_UtfToExternalDString(NULL, src, -1, &srcString);
- Tcl_UtfToExternalDString(NULL, dst, -1, &dstString);
- result = DoRenameFile(Tcl_DStringValue(&srcString),
- Tcl_DStringValue(&dstString));
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
+ return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
if (errno == EINVAL) {
char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
DIR *dirPtr;
- struct dirent *dirEntPtr;
+ Tcl_DirEntry *dirEntPtr;
- if ((realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
- && (realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
+ if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
+ && (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
dirPtr = opendir(dst); /* INTL: Native. */
if (dirPtr != NULL) {
while (1) {
- dirEntPtr = readdir(dirPtr); /* INTL: Native. */
+ dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
if (dirEntPtr == NULL) {
break;
}
return TCL_ERROR;
}
-
\f
/*
*---------------------------------------------------------------------------
*
- * TclpCopyFile, DoCopyFile --
+ * TclpObjCopyFile, DoCopyFile --
*
* Copy a single file (not a directory). If dst already exists and
* is not a directory, it is removed.
*/
int
-TclpCopyFile(src, dst)
- CONST char *src; /* Pathname of file to be copied (UTF-8). */
- CONST char *dst; /* Pathname of file to copy to (UTF-8). */
+TclpObjCopyFile(srcPathPtr, destPathPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_UtfToExternalDString(NULL, src, -1, &srcString);
- Tcl_UtfToExternalDString(NULL, dst, -1, &dstString);
- result = DoCopyFile(&srcString, &dstString);
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
+ return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
-DoCopyFile(srcPtr, dstPtr)
- Tcl_DString *srcPtr; /* Pathname of file to be copied (native). */
- Tcl_DString *dstPtr; /* Pathname of file to copy to (native). */
+DoCopyFile(src, dst)
+ CONST char *src; /* Pathname of file to be copied (native). */
+ CONST char *dst; /* Pathname of file to copy to (native). */
{
- struct stat srcStatBuf, dstStatBuf;
- CONST char *src, *dst;
-
- src = Tcl_DStringValue(srcPtr);
- dst = Tcl_DStringValue(dstPtr);
+ Tcl_StatBuf srcStatBuf, dstStatBuf;
/*
* Have to do a stat() to determine the filetype.
*/
- if (lstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
+ if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
return TCL_ERROR;
}
if (S_ISDIR(srcStatBuf.st_mode)) {
* exists, so we remove it first
*/
- if (lstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */
+ if (TclOSlstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */
if (S_ISDIR(dstStatBuf.st_mode)) {
errno = EISDIR;
return TCL_ERROR;
}
switch ((int) (srcStatBuf.st_mode & S_IFMT)) {
+#ifndef DJGPP
case S_IFLNK: {
char link[MAXPATHLEN];
int length;
}
break;
}
+#endif
case S_IFBLK:
case S_IFCHR: {
if (mknod(dst, srcStatBuf.st_mode, /* INTL: Native. */
CONST char *src; /* Pathname of file to copy (native). */
CONST char *dst; /* Pathname of file to create/overwrite
* (native). */
- CONST struct stat *statBufPtr;
+ CONST Tcl_StatBuf *statBufPtr;
/* Used to determine mode and blocksize. */
{
int srcFd;
char *buffer; /* Data buffer for copy */
size_t nread;
- if ((srcFd = open(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */
+ if ((srcFd = TclOSopen(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */
return TCL_ERROR;
}
- dstFd = open(dst, O_CREAT | O_TRUNC | O_WRONLY, /* INTL: Native. */
+ dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY, /* INTL: Native. */
statBufPtr->st_mode);
if (dstFd < 0) {
close(srcFd);
/*
*---------------------------------------------------------------------------
*
- * TclpDeleteFile, DoDeleteFile --
+ * TclpObjDeleteFile, DoDeleteFile --
*
* Removes a single file (not a directory).
*
*---------------------------------------------------------------------------
*/
-int
-TclpDeleteFile(path)
- CONST char *path; /* Pathname of file to be removed (UTF-8). */
+int
+TclpObjDeleteFile(pathPtr)
+ Tcl_Obj *pathPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_UtfToExternalDString(NULL, path, -1, &pathString);
- result = DoDeleteFile(&pathString);
- Tcl_DStringFree(&pathString);
- return result;
+ return DoDeleteFile(Tcl_FSGetNativePath(pathPtr));
}
static int
-DoDeleteFile(pathPtr)
- Tcl_DString *pathPtr; /* Pathname of file to be removed (native). */
+DoDeleteFile(path)
+ CONST char *path; /* Pathname of file to be removed (native). */
{
- CONST char *path;
-
- path = Tcl_DStringValue(pathPtr);
if (unlink(path) != 0) { /* INTL: Native. */
return TCL_ERROR;
}
*---------------------------------------------------------------------------
*/
-int
-TclpCreateDirectory(path)
- CONST char *path; /* Pathname of directory to create (UTF-8). */
+int
+TclpObjCreateDirectory(pathPtr)
+ Tcl_Obj *pathPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_UtfToExternalDString(NULL, path, -1, &pathString);
- result = DoCreateDirectory(&pathString);
- Tcl_DStringFree(&pathString);
- return result;
+ return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
-DoCreateDirectory(pathPtr)
- Tcl_DString *pathPtr; /* Pathname of directory to create (native). */
+DoCreateDirectory(path)
+ CONST char *path; /* Pathname of directory to create (native). */
{
mode_t mode;
- CONST char *path;
-
- path = Tcl_DStringValue(pathPtr);
mode = umask(0);
umask(mode);
/*
*---------------------------------------------------------------------------
*
- * TclpCopyDirectory --
+ * TclpObjCopyDirectory --
*
* Recursively copies a directory. The target directory dst must
* not already exist. Note that this function does not merge two
* If the directory was successfully copied, returns TCL_OK.
* Otherwise the return value is TCL_ERROR, errno is set to indicate
* the error, and the pathname of the file that caused the error
- * is stored in errorPtr. See TclpCreateDirectory and TclpCopyFile
- * for a description of possible values for errno.
+ * is stored in errorPtr. See TclpObjCreateDirectory and
+ * TclpObjCopyFile for a description of possible values for errno.
*
* Side effects:
* An exact copy of the directory hierarchy src will be created
*---------------------------------------------------------------------------
*/
-int
-TclpCopyDirectory(src, dst, errorPtr)
- CONST char *src; /* Pathname of directory to be copied
- * (UTF-8). */
- CONST char *dst; /* Pathname of target directory (UTF-8). */
- Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+int
+TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
+ Tcl_Obj **errorPtr;
{
+ Tcl_DString ds;
Tcl_DString srcString, dstString;
- int result;
+ int ret;
- Tcl_UtfToExternalDString(NULL, src, -1, &srcString);
- Tcl_UtfToExternalDString(NULL, dst, -1, &dstString);
+ Tcl_UtfToExternalDString(NULL,
+ Tcl_FSGetTranslatedStringPath(NULL,srcPathPtr),
+ -1, &srcString);
+ Tcl_UtfToExternalDString(NULL,
+ Tcl_FSGetTranslatedStringPath(NULL,destPathPtr),
+ -1, &dstString);
- result = TraverseUnixTree(TraversalCopy, &srcString, &dstString, errorPtr);
+ ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
- return result;
+
+ if (ret != TCL_OK) {
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_DStringFree(&ds);
+ Tcl_IncrRefCount(*errorPtr);
+ }
+ return ret;
}
+
\f
/*
*---------------------------------------------------------------------------
*---------------------------------------------------------------------------
*/
-int
-TclpRemoveDirectory(path, recursive, errorPtr)
- CONST char *path; /* Pathname of directory to be removed
- * (UTF-8). */
- int recursive; /* If non-zero, removes directories that
- * are nonempty. Otherwise, will only remove
- * empty directories. */
- Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+int
+TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
+ Tcl_Obj *pathPtr;
+ int recursive;
+ Tcl_Obj **errorPtr;
{
- int result;
+ Tcl_DString ds;
Tcl_DString pathString;
+ int ret;
- Tcl_UtfToExternalDString(NULL, path, -1, &pathString);
- result = DoRemoveDirectory(&pathString, recursive, errorPtr);
+ Tcl_UtfToExternalDString(NULL, Tcl_FSGetTranslatedStringPath(NULL, pathPtr),
+ -1, &pathString);
+ ret = DoRemoveDirectory(&pathString, recursive, &ds);
Tcl_DStringFree(&pathString);
- return result;
+ if (ret != TCL_OK) {
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_DStringFree(&ds);
+ Tcl_IncrRefCount(*errorPtr);
+ }
+ return ret;
}
static int
* causing error. */
{
CONST char *path;
-
+ mode_t oldPerm = 0;
+ int result;
+
path = Tcl_DStringValue(pathPtr);
+
+ if (recursive != 0) {
+ /* We should try to change permissions so this can be deleted */
+ Tcl_StatBuf statBuf;
+ int newPerm;
+
+ if (TclOSstat(path, &statBuf) == 0) {
+ oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
+ }
+
+ newPerm = oldPerm | (64+128+256);
+ chmod(path, (mode_t) newPerm);
+ }
+
if (rmdir(path) == 0) { /* INTL: Native. */
return TCL_OK;
}
if (errno == ENOTEMPTY) {
errno = EEXIST;
}
+
+ result = TCL_OK;
if ((errno != EEXIST) || (recursive == 0)) {
if (errorPtr != NULL) {
Tcl_ExternalToUtfDString(NULL, path, -1, errorPtr);
}
- return TCL_ERROR;
+ result = TCL_ERROR;
}
/*
* specified, so we recursively remove all the files in the directory.
*/
- return TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr);
+ if (result == TCL_OK) {
+ result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr);
+ }
+
+ if ((result != TCL_OK) && (recursive != 0)) {
+ /* Try to restore permissions */
+ chmod(path, oldPerm);
+ }
+ return result;
}
\f
/*
* DString filled with UTF-8 name of file
* causing error. */
{
- struct stat statBuf;
+ Tcl_StatBuf statBuf;
CONST char *source, *errfile;
int result, sourceLen;
int targetLen;
- struct dirent *dirEntPtr;
+ Tcl_DirEntry *dirEntPtr;
DIR *dirPtr;
errfile = NULL;
targetLen = 0; /* lint. */
source = Tcl_DStringValue(sourcePtr);
- if (lstat(source, &statBuf) != 0) { /* INTL: Native. */
+ if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */
errfile = source;
goto end;
}
Tcl_DStringAppend(targetPtr, "/", 1);
targetLen = Tcl_DStringLength(targetPtr);
}
-
- while ((dirEntPtr = readdir(dirPtr)) != NULL) { /* INTL: Native. */
+
+ while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
if ((strcmp(dirEntPtr->d_name, ".") == 0)
|| (strcmp(dirEntPtr->d_name, "..") == 0)) {
continue;
*
* TraversalCopy
*
- * Called from TraverseUnixTree in order to execute a recursive copy of a
- * directory.
+ * Called from TraverseUnixTree in order to execute a recursive copy
+ * of a directory.
*
* Results:
* Standard Tcl result.
TraversalCopy(srcPtr, dstPtr, statBufPtr, type, errorPtr)
Tcl_DString *srcPtr; /* Source pathname to copy (native). */
Tcl_DString *dstPtr; /* Destination pathname of copy (native). */
- CONST struct stat *statBufPtr;
+ CONST Tcl_StatBuf *statBufPtr;
/* Stat info for file specified by srcPtr. */
int type; /* Reason for call - see TraverseUnixTree(). */
Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
{
switch (type) {
case DOTREE_F:
- if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) {
+ if (DoCopyFile(Tcl_DStringValue(srcPtr),
+ Tcl_DStringValue(dstPtr)) == TCL_OK) {
return TCL_OK;
}
break;
case DOTREE_PRED:
- if (DoCreateDirectory(dstPtr) == TCL_OK) {
+ if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
return TCL_OK;
}
break;
TraversalDelete(srcPtr, ignore, statBufPtr, type, errorPtr)
Tcl_DString *srcPtr; /* Source pathname (native). */
Tcl_DString *ignore; /* Destination pathname (not used). */
- CONST struct stat *statBufPtr;
+ CONST Tcl_StatBuf *statBufPtr;
/* Stat info for file specified by srcPtr. */
int type; /* Reason for call - see TraverseUnixTree(). */
Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
{
switch (type) {
case DOTREE_F: {
- if (DoDeleteFile(srcPtr) == 0) {
+ if (DoDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
return TCL_OK;
}
break;
CopyFileAtts(src, dst, statBufPtr)
CONST char *src; /* Path name of source file (native). */
CONST char *dst; /* Path name of target file (native). */
- CONST struct stat *statBufPtr;
+ CONST Tcl_StatBuf *statBufPtr;
/* Stat info for source file */
{
struct utimbuf tval;
GetGroupAttribute(interp, objIndex, fileName, attributePtrPtr)
Tcl_Interp *interp; /* The interp we are using for errors. */
int objIndex; /* The index of the attribute. */
- CONST char *fileName; /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName; /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
{
- struct stat statBuf;
+ Tcl_StatBuf statBuf;
struct group *groupPtr;
int result;
- result = TclStat(fileName, &statBuf);
+ result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read \"", fileName, "\": ",
+ Tcl_AppendResult(interp, "could not read \"",
+ Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
groupPtr = getgrgid(statBuf.st_gid); /* INTL: Native. */
if (groupPtr == NULL) {
- *attributePtrPtr = Tcl_NewIntObj(statBuf.st_gid);
+ *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
} else {
Tcl_DString ds;
CONST char *utf;
GetOwnerAttribute(interp, objIndex, fileName, attributePtrPtr)
Tcl_Interp *interp; /* The interp we are using for errors. */
int objIndex; /* The index of the attribute. */
- CONST char *fileName; /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName; /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
{
- struct stat statBuf;
+ Tcl_StatBuf statBuf;
struct passwd *pwPtr;
int result;
- result = TclStat(fileName, &statBuf);
+ result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read \"", fileName, "\": ",
+ Tcl_AppendResult(interp, "could not read \"",
+ Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
pwPtr = getpwuid(statBuf.st_uid); /* INTL: Native. */
if (pwPtr == NULL) {
- *attributePtrPtr = Tcl_NewIntObj(statBuf.st_uid);
+ *attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
} else {
Tcl_DString ds;
CONST char *utf;
GetPermissionsAttribute(interp, objIndex, fileName, attributePtrPtr)
Tcl_Interp *interp; /* The interp we are using for errors. */
int objIndex; /* The index of the attribute. */
- CONST char *fileName; /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName; /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr; /* A pointer to return the object with. */
{
- struct stat statBuf;
+ Tcl_StatBuf statBuf;
char returnString[7];
int result;
- result = TclStat(fileName, &statBuf);
+ result = TclpObjStat(fileName, &statBuf);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read \"", fileName, "\": ",
+ Tcl_AppendResult(interp, "could not read \"",
+ Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
- sprintf(returnString, "%0#5lo", (statBuf.st_mode & 0x00007FFF));
+ sprintf(returnString, "%0#5lo", (long) (statBuf.st_mode & 0x00007FFF));
*attributePtrPtr = Tcl_NewStringObj(returnString, -1);
SetGroupAttribute(interp, objIndex, fileName, attributePtr)
Tcl_Interp *interp; /* The interp for error reporting. */
int objIndex; /* The index of the attribute. */
- CONST char *fileName; /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName; /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr; /* New group for file. */
{
long gid;
int result;
- Tcl_DString ds;
CONST char *native;
if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
+ Tcl_DString ds;
struct group *groupPtr;
CONST char *string;
int length;
if (groupPtr == NULL) {
endgrent();
Tcl_AppendResult(interp, "could not set group for file \"",
- fileName, "\": group \"", string, "\" does not exist",
+ Tcl_GetString(fileName), "\": group \"",
+ string, "\" does not exist",
(char *) NULL);
return TCL_ERROR;
}
gid = groupPtr->gr_gid;
}
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ native = Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */
- Tcl_DStringFree(&ds);
endgrent();
if (result != 0) {
Tcl_AppendResult(interp, "could not set group for file \"",
- fileName, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_GetString(fileName), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
SetOwnerAttribute(interp, objIndex, fileName, attributePtr)
Tcl_Interp *interp; /* The interp for error reporting. */
int objIndex; /* The index of the attribute. */
- CONST char *fileName; /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName; /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr; /* New owner for file. */
{
long uid;
int result;
- Tcl_DString ds;
CONST char *native;
if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
+ Tcl_DString ds;
struct passwd *pwPtr;
CONST char *string;
int length;
if (pwPtr == NULL) {
Tcl_AppendResult(interp, "could not set owner for file \"",
- fileName, "\": user \"", string, "\" does not exist",
+ Tcl_GetString(fileName), "\": user \"",
+ string, "\" does not exist",
(char *) NULL);
return TCL_ERROR;
}
uid = pwPtr->pw_uid;
}
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ native = Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */
- Tcl_DStringFree(&ds);
if (result != 0) {
- Tcl_AppendResult(interp, "could not set owner for file \"", fileName,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "could not set owner for file \"",
+ Tcl_GetString(fileName), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
SetPermissionsAttribute(interp, objIndex, fileName, attributePtr)
Tcl_Interp *interp; /* The interp we are using for errors. */
int objIndex; /* The index of the attribute. */
- CONST char *fileName; /* The name of the file (UTF-8). */
+ Tcl_Obj *fileName; /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr; /* The attribute to set. */
{
long mode;
mode_t newMode;
int result;
CONST char *native;
- Tcl_DString ds;
/*
* First try if the string is a number
if (Tcl_GetLongFromObj(NULL, attributePtr, &mode) == TCL_OK) {
newMode = (mode_t) (mode & 0x00007FFF);
} else {
- struct stat buf;
+ Tcl_StatBuf buf;
char *modeStringPtr = Tcl_GetString(attributePtr);
/*
* We get the current mode of the file, in order to allow for
* ug+-=rwx style chmod strings.
*/
- result = TclStat(fileName, &buf);
+ result = TclpObjStat(fileName, &buf);
if (result != 0) {
- Tcl_AppendResult(interp, "could not read \"", fileName, "\": ",
+ Tcl_AppendResult(interp, "could not read \"",
+ Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
}
}
- native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
+ native = Tcl_FSGetNativePath(fileName);
result = chmod(native, newMode); /* INTL: Native. */
- Tcl_DStringFree(&ds);
if (result != 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not set permissions for file \"", fileName, "\": ",
+ "could not set permissions for file \"",
+ Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
- * TclpListVolumes --
+ * TclpObjListVolumes --
*
* Lists the currently mounted volumes, which on UNIX is just /.
*
* Results:
- * A standard Tcl result. Will always be TCL_OK, since there is no way
- * that this command can fail. Also, the interpreter's result is set to
- * the list of volumes.
+ * The list of volumes.
*
* Side effects:
* None.
*---------------------------------------------------------------------------
*/
-int
-TclpListVolumes(interp)
- Tcl_Interp *interp; /* Interpreter to which to pass
- * the volume list. */
+Tcl_Obj*
+TclpObjListVolumes(void)
{
- Tcl_Obj *resultPtr;
-
- resultPtr = Tcl_GetObjResult(interp);
- Tcl_SetStringObj(resultPtr, "/", 1);
- return TCL_OK;
+ Tcl_Obj *resultPtr = Tcl_NewStringObj("/",1);
+
+ Tcl_IncrRefCount(resultPtr);
+ return resultPtr;
}
\f
/*
}
return TCL_OK;
}
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpObjNormalizePath --
+ *
+ * This function scans through a path specification and replaces
+ * it, in place, with a normalized version. A normalized version
+ * is one in which all symlinks in the path are replaced with
+ * their expanded form (except a symlink at the very end of the
+ * path).
+ *
+ * Results:
+ * The new 'nextCheckpoint' value, giving as far as we could
+ * understand in the path.
+ *
+ * Side effects:
+ * The pathPtr string, is modified.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+ int nextCheckpoint;
+{
+ char *currentPathEndPosition;
+ int pathLen;
+ char cur;
+ char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+#ifndef NO_REALPATH
+ char normPath[MAXPATHLEN];
+ Tcl_DString ds;
+ CONST char *nativePath;
+#endif
+ currentPathEndPosition = path + nextCheckpoint;
+
+ while (1) {
+ cur = *currentPathEndPosition;
+ if ((cur == '/') && (path != currentPathEndPosition)) {
+ /* Reached directory separator */
+ Tcl_DString ds;
+ CONST char *nativePath;
+ int accessOk;
+
+ nativePath = Tcl_UtfToExternalDString(NULL, path,
+ currentPathEndPosition - path, &ds);
+ accessOk = access(nativePath, F_OK);
+ Tcl_DStringFree(&ds);
+ if (accessOk != 0) {
+ /* File doesn't exist */
+ break;
+ }
+ /* Update the acceptable point */
+ nextCheckpoint = currentPathEndPosition - path;
+ } else if (cur == 0) {
+ /* Reached end of string */
+ break;
+ }
+ currentPathEndPosition++;
+ }
+ /*
+ * We should really now convert this to a canonical path. We do
+ * that with 'realpath' if we have it available. Otherwise we could
+ * step through every single path component, checking whether it is a
+ * symlink, but that would be a lot of work, and most modern OSes
+ * have 'realpath'.
+ */
+#ifndef NO_REALPATH
+ /*
+ * If we only had '/foo' or '/' then we never increment nextCheckpoint
+ * and we don't need or want to go through 'Realpath'. Also, on some
+ * platforms, passing an empty string to 'Realpath' will give us the
+ * normalized pwd, which is not what we want at all!
+ */
+ if (nextCheckpoint == 0) return 0;
+
+ nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
+ if (Realpath(nativePath, normPath) != NULL) {
+ /*
+ * Free up the native path and put in its place the
+ * converted, normalized path.
+ */
+ Tcl_DStringFree(&ds);
+ Tcl_ExternalToUtfDString(NULL, normPath, (int) strlen(normPath), &ds);
+
+ if (path[nextCheckpoint] != '\0') {
+ /* not at end, append remaining path */
+ int normLen = Tcl_DStringLength(&ds);
+ Tcl_DStringAppend(&ds, path + nextCheckpoint,
+ pathLen - nextCheckpoint);
+ /*
+ * We recognise up to and including the directory
+ * separator.
+ */
+ nextCheckpoint = normLen + 1;
+ } else {
+ /* We recognise the whole string */
+ nextCheckpoint = Tcl_DStringLength(&ds);
+ }
+ /*
+ * Overwrite with the normalized path.
+ */
+ Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ }
+ Tcl_DStringFree(&ds);
+#endif /* !NO_REALPATH */
+ return nextCheckpoint;
+}
#include "tclInt.h"
#include "tclPort.h"
+static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types);
+
\f
/*
*---------------------------------------------------------------------------
* (native). */
{
CONST char *name, *p;
- struct stat statBuf;
+ Tcl_StatBuf statBuf;
int length;
Tcl_DString buffer, nameString;
* strings directly.
*/
- if ((access(name, X_OK) == 0) /* INTL: Native. */
- && (stat(name, &statBuf) == 0) /* INTL: Native. */
+ if ((access(name, X_OK) == 0) /* INTL: Native. */
+ && (TclOSstat(name, &statBuf) == 0) /* INTL: Native. */
&& S_ISREG(statBuf.st_mode)) {
goto gotName;
}
* If the name starts with "/" then just copy it to tclExecutableName.
*/
- gotName:
+gotName:
+#ifdef DJGPP
+ if (name[1] == ':') {
+#else
if (name[0] == '/') {
+#endif
Tcl_ExternalToUtfDString(NULL, name, -1, &nameString);
tclNativeExecutableName = (char *)
ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1));
Tcl_DStringValue(&nameString));
Tcl_DStringFree(&nameString);
- done:
+done:
Tcl_DStringFree(&buffer);
return tclNativeExecutableName;
}
/*
*----------------------------------------------------------------------
*
- * TclpMatchFilesTypes --
+ * TclpMatchInDirectory --
*
* This routine is used by the globbing code to search a
* directory for all files which match a given pattern.
*
* Results:
- * If the tail argument is NULL, then the matching files are
- * added to the the interp's result. Otherwise, TclDoGlob is called
- * recursively for each matching subdirectory. The return value
- * is a standard Tcl result indicating whether an error occurred
- * in globbing.
+ * The return value is a standard Tcl result indicating whether an
+ * error occurred in globbing. Errors are left in interp, good
+ * results are lappended to resultPtr (which must be a valid object)
*
* Side effects:
* None.
*
- *----------------------------------------------------------------------
- */
+ *---------------------------------------------------------------------- */
int
-TclpMatchFilesTypes(interp, separators, dirPtr, pattern, tail, types)
- Tcl_Interp *interp; /* Interpreter to receive results. */
- char *separators; /* Directory separators to pass to TclDoGlob */
- Tcl_DString *dirPtr; /* Contains path to directory to search. */
- char *pattern; /* Pattern to match against. */
- char *tail; /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static. */
- GlobTypeData *types; /* Object containing list of acceptable types.
- * May be NULL. */
+TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
+ Tcl_Interp *interp; /* Interpreter to receive errors. */
+ Tcl_Obj *resultPtr; /* List object to lappend results. */
+ Tcl_Obj *pathPtr; /* Contains path to directory to search. */
+ CONST char *pattern; /* Pattern to match against. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. In particular the directory
+ * flag is very important. */
{
- char *native, *fname, *dirName, *patternEnd = tail;
- char savedChar = 0; /* lint. */
- DIR *d;
- Tcl_DString ds;
- struct stat statBuf;
- int matchHidden;
- int result = TCL_OK;
- int baseLength = Tcl_DStringLength(dirPtr);
- Tcl_Obj *resultPtr;
+ CONST char *native;
+ Tcl_Obj *fileNamePtr;
- /*
- * Make sure that the directory part of the name really is a
- * directory. If the directory name is "", use the name "."
- * instead, because some UNIX systems don't treat "" like "."
- * automatically. Keep the "" for use in generating file names,
- * otherwise "glob foo.c" would return "./foo.c".
- */
-
- if (Tcl_DStringLength(dirPtr) == 0) {
- dirName = ".";
- } else {
- dirName = Tcl_DStringValue(dirPtr);
+ fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (fileNamePtr == NULL) {
+ return TCL_ERROR;
}
-
- if ((TclpStat(dirName, &statBuf) != 0) /* INTL: UTF-8. */
- || !S_ISDIR(statBuf.st_mode)) {
+
+ if (pattern == NULL || (*pattern == '\0')) {
+ /* Match a file directly */
+ CONST char *native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
+ if (NativeMatchType(native, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
+ }
return TCL_OK;
- }
-
- /*
- * Check to see if the pattern needs to compare with hidden files.
- */
-
- if ((pattern[0] == '.')
- || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
- matchHidden = 1;
} else {
- matchHidden = 0;
- }
-
- /*
- * Now open the directory for reading and iterate over the contents.
- */
-
- native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
- d = opendir(native); /* INTL: Native. */
- Tcl_DStringFree(&ds);
- if (d == NULL) {
- Tcl_ResetResult(interp);
-
+ CONST char *fname, *dirName;
+ DIR *d;
+ Tcl_DString ds;
+ Tcl_StatBuf statBuf;
+ int matchHidden;
+ int nativeDirLen;
+ int result = TCL_OK;
+ Tcl_DString dsOrig;
+ int baseLength;
+
+ Tcl_DStringInit(&dsOrig);
+ Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
+ baseLength = Tcl_DStringLength(&dsOrig);
+
/*
- * Strip off a trailing '/' if necessary, before reporting the error.
+ * Make sure that the directory part of the name really is a
+ * directory. If the directory name is "", use the name "."
+ * instead, because some UNIX systems don't treat "" like "."
+ * automatically. Keep the "" for use in generating file names,
+ * otherwise "glob foo.c" would return "./foo.c".
*/
- if (baseLength > 0) {
- savedChar = (Tcl_DStringValue(dirPtr))[baseLength-1];
- if (savedChar == '/') {
- (Tcl_DStringValue(dirPtr))[baseLength-1] = '\0';
+ if (baseLength == 0) {
+ dirName = ".";
+ } else {
+ dirName = Tcl_DStringValue(&dsOrig);
+ /* Make sure we have a trailing directory delimiter */
+ if (dirName[baseLength-1] != '/') {
+ dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
+ baseLength++;
}
}
- Tcl_AppendResult(interp, "couldn't read directory \"",
- Tcl_DStringValue(dirPtr), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- if (baseLength > 0) {
- (Tcl_DStringValue(dirPtr))[baseLength-1] = savedChar;
+
+ /*
+ * Check to see if the pattern needs to compare with hidden files.
+ */
+
+ if ((pattern[0] == '.')
+ || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
+ matchHidden = 1;
+ } else {
+ matchHidden = 0;
}
- return TCL_ERROR;
- }
- /*
- * Clean up the end of the pattern and the tail pointer. Leave
- * the tail pointing to the first character after the path separator
- * following the pattern, or NULL. Also, ensure that the pattern
- * is null-terminated.
- */
+ /*
+ * Now open the directory for reading and iterate over the contents.
+ */
- if (*tail == '\\') {
- tail++;
- }
- if (*tail == '\0') {
- tail = NULL;
- } else {
- tail++;
- }
- savedChar = *patternEnd;
- *patternEnd = '\0';
+ native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
- resultPtr = Tcl_GetObjResult(interp);
- while (1) {
- char *utf;
- struct dirent *entryPtr;
-
- entryPtr = readdir(d); /* INTL: Native. */
- if (entryPtr == NULL) {
- break;
+ if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
+ || !S_ISDIR(statBuf.st_mode)) {
+ Tcl_DStringFree(&dsOrig);
+ Tcl_DStringFree(&ds);
+ return TCL_OK;
}
- if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) {
- /*
- * We explicitly asked for hidden files, so turn around
- * and ignore any file which isn't hidden.
- */
- if (*entryPtr->d_name != '.') {
- continue;
- }
- } else if (!matchHidden && (*entryPtr->d_name == '.')) {
+ d = opendir(native); /* INTL: Native. */
+ if (d == NULL) {
+ char savedChar = '\0';
+ Tcl_ResetResult(interp);
+ Tcl_DStringFree(&ds);
+
/*
- * Don't match names starting with "." unless the "." is
- * present in the pattern.
+ * Strip off a trailing '/' if necessary, before reporting the error.
*/
- continue;
+
+ if (baseLength > 0) {
+ savedChar = (Tcl_DStringValue(&dsOrig))[baseLength-1];
+ if (savedChar == '/') {
+ (Tcl_DStringValue(&dsOrig))[baseLength-1] = '\0';
+ }
+ }
+ Tcl_AppendResult(interp, "couldn't read directory \"",
+ Tcl_DStringValue(&dsOrig), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ if (baseLength > 0) {
+ (Tcl_DStringValue(&dsOrig))[baseLength-1] = savedChar;
+ }
+ Tcl_DStringFree(&dsOrig);
+ return TCL_ERROR;
}
- /*
- * Now check to see if the file matches. If there are more
- * characters to be processed, then ensure matching files are
- * directories before calling TclDoGlob. Otherwise, just add
- * the file to the result.
- */
+ nativeDirLen = Tcl_DStringLength(&ds);
+
+ while (1) {
+ Tcl_DString utfDs;
+ CONST char *utf;
+ Tcl_DirEntry *entryPtr;
+
+ entryPtr = TclOSreaddir(d); /* INTL: Native. */
+ if (entryPtr == NULL) {
+ break;
+ }
+ if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) {
+ /*
+ * We explicitly asked for hidden files, so turn around
+ * and ignore any file which isn't hidden.
+ */
+ if (*entryPtr->d_name != '.') {
+ continue;
+ }
+ } else if (!matchHidden && (*entryPtr->d_name == '.')) {
+ /*
+ * Don't match names starting with "." unless the "." is
+ * present in the pattern.
+ */
+ continue;
+ }
- utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &ds);
- if (Tcl_StringMatch(utf, pattern) != 0) {
- Tcl_DStringSetLength(dirPtr, baseLength);
- Tcl_DStringAppend(dirPtr, utf, -1);
- fname = Tcl_DStringValue(dirPtr);
- if (tail == NULL) {
+ /*
+ * Now check to see if the file matches, according to both type
+ * and pattern. If so, add the file to the result.
+ */
+
+ utf = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs);
+ if (Tcl_StringMatch(utf, pattern) != 0) {
int typeOk = 1;
- if (types != NULL) {
- if (types->perm != 0) {
- struct stat buf;
- if (TclpStat(fname, &buf) != 0) {
- panic("stat failed on known file");
- }
- /*
- * readonly means that there are NO write permissions
- * (even for user), but execute is OK for anybody
- */
- if (
- ((types->perm & TCL_GLOB_PERM_RONLY) &&
- (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
- ((types->perm & TCL_GLOB_PERM_R) &&
- (TclpAccess(fname, R_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_W) &&
- (TclpAccess(fname, W_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_X) &&
- (TclpAccess(fname, X_OK) != 0))
- ) {
- typeOk = 0;
- }
- }
- if (typeOk && (types->type != 0)) {
- struct stat buf;
- /*
- * We must match at least one flag to be listed
- */
- typeOk = 0;
- if (TclpLstat(fname, &buf) >= 0) {
- /*
- * In order bcdpfls as in 'find -t'
- */
- if (
- ((types->type & TCL_GLOB_TYPE_BLOCK) &&
- S_ISBLK(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_CHAR) &&
- S_ISCHR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_DIR) &&
- S_ISDIR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_PIPE) &&
- S_ISFIFO(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_FILE) &&
- S_ISREG(buf.st_mode))
-#ifdef S_ISLNK
- || ((types->type & TCL_GLOB_TYPE_LINK) &&
- S_ISLNK(buf.st_mode))
-#endif
-#ifdef S_ISSOCK
- || ((types->type & TCL_GLOB_TYPE_SOCK) &&
- S_ISSOCK(buf.st_mode))
-#endif
- ) {
- typeOk = 1;
- }
- } else {
- /* Posix error occurred */
- }
- }
+ Tcl_DStringSetLength(&dsOrig, baseLength);
+ Tcl_DStringAppend(&dsOrig, utf, -1);
+ fname = Tcl_DStringValue(&dsOrig);
+ if (types != NULL) {
+ char *nativeEntry;
+ Tcl_DStringSetLength(&ds, nativeDirLen);
+ nativeEntry = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
+ typeOk = NativeMatchType(nativeEntry, types);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname,
- Tcl_DStringLength(dirPtr)));
- }
- } else if ((TclpStat(fname, &statBuf) == 0)
- && S_ISDIR(statBuf.st_mode)) {
- Tcl_DStringAppend(dirPtr, "/", 1);
- result = TclDoGlob(interp, separators, dirPtr, tail, types);
- if (result != TCL_OK) {
- Tcl_DStringFree(&ds);
- break;
+ Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
}
}
+ Tcl_DStringFree(&utfDs);
}
+
+ closedir(d);
Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&dsOrig);
+ return result;
}
- *patternEnd = savedChar;
-
- closedir(d);
- return result;
}
-\f
-/*
- * TclpMatchFiles --
- *
- * This function is now obsolete. Call the above function
- * 'TclpMatchFilesTypes' instead.
- */
-int
-TclpMatchFiles(interp, separators, dirPtr, pattern, tail)
- Tcl_Interp *interp; /* Interpreter to receive results. */
- char *separators; /* Directory separators to pass to TclDoGlob */
- Tcl_DString *dirPtr; /* Contains path to directory to search. */
- char *pattern; /* Pattern to match against. */
- char *tail; /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static. */
+static int
+NativeMatchType(
+ CONST char* nativeEntry, /* Native path to check */
+ Tcl_GlobTypeData *types) /* Type description to match against */
{
- return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
+ Tcl_StatBuf buf;
+ if (types == NULL) {
+ /*
+ * Simply check for the file's existence, but do it
+ * with lstat, in case it is a link to a file which
+ * doesn't exist (since that case would not show up
+ * if we used 'access' or 'stat')
+ */
+ if (TclOSlstat(nativeEntry, &buf) != 0) {
+ return 0;
+ }
+ } else {
+ if (types->perm != 0) {
+ if (TclOSstat(nativeEntry, &buf) != 0) {
+ /*
+ * Either the file has disappeared between the
+ * 'readdir' call and the 'stat' call, or
+ * the file is a link to a file which doesn't
+ * exist (which we could ascertain with
+ * lstat), or there is some other strange
+ * problem. In all these cases, we define this
+ * to mean the file does not match any defined
+ * permission, and therefore it is not
+ * added to the list of files to return.
+ */
+ return 0;
+ }
+
+ /*
+ * readonly means that there are NO write permissions
+ * (even for user), but execute is OK for anybody
+ */
+ if (((types->perm & TCL_GLOB_PERM_RONLY) &&
+ (buf.st_mode & (S_IWOTH|S_IWGRP|S_IWUSR))) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (access(nativeEntry, R_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (access(nativeEntry, W_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (access(nativeEntry, X_OK) != 0))
+ ) {
+ return 0;
+ }
+ }
+ if (types->type != 0) {
+ if (types->perm == 0) {
+ /* We haven't yet done a stat on the file */
+ if (TclOSstat(nativeEntry, &buf) != 0) {
+ /* Posix error occurred */
+ return 0;
+ }
+ }
+ /*
+ * In order bcdpfls as in 'find -t'
+ */
+ if (
+ ((types->type & TCL_GLOB_TYPE_BLOCK) &&
+ S_ISBLK(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_CHAR) &&
+ S_ISCHR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_DIR) &&
+ S_ISDIR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_PIPE) &&
+ S_ISFIFO(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_FILE) &&
+ S_ISREG(buf.st_mode))
+#ifdef S_ISSOCK
+ || ((types->type & TCL_GLOB_TYPE_SOCK) &&
+ S_ISSOCK(buf.st_mode))
+#endif /* S_ISSOCK */
+ ) {
+ /* Do nothing -- this file is ok */
+ } else {
+#ifdef S_ISLNK
+ if (types->type & TCL_GLOB_TYPE_LINK) {
+ if (TclOSlstat(nativeEntry, &buf) == 0) {
+ if (S_ISLNK(buf.st_mode)) {
+ return 1;
+ }
+ }
+ }
+#endif /* S_ISLNK */
+ return 0;
+ }
+ }
+ }
+ return 1;
}
\f
/*
{
struct passwd *pwPtr;
Tcl_DString ds;
- char *native;
+ CONST char *native;
native = Tcl_UtfToExternalDString(NULL, name, -1, &ds);
pwPtr = getpwnam(native); /* INTL: Native. */
/*
*---------------------------------------------------------------------------
*
- * TclpAccess --
+ * TclpObjAccess --
*
* This function replaces the library version of access().
*
*---------------------------------------------------------------------------
*/
-int
-TclpAccess(path, mode)
- CONST char *path; /* Path of file to access (UTF-8). */
- int mode; /* Permission setting. */
+int
+TclpObjAccess(pathPtr, mode)
+ Tcl_Obj *pathPtr; /* Path of file to access */
+ int mode; /* Permission setting. */
{
- int result;
- Tcl_DString ds;
- char *native;
-
- native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
- result = access(native, mode); /* INTL: Native. */
- Tcl_DStringFree(&ds);
-
- return result;
+ CONST char *path = Tcl_FSGetNativePath(pathPtr);
+ if (path == NULL) {
+ return -1;
+ } else {
+ return access(path, mode);
+ }
}
\f
/*
*---------------------------------------------------------------------------
*
- * TclpChdir --
+ * TclpObjChdir --
*
* This function replaces the library version of chdir().
*
*---------------------------------------------------------------------------
*/
-int
-TclpChdir(dirName)
- CONST char *dirName; /* Path to new working directory (UTF-8). */
+int
+TclpObjChdir(pathPtr)
+ Tcl_Obj *pathPtr; /* Path to new working directory */
{
- int result;
- Tcl_DString ds;
- char *native;
-
- native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
- result = chdir(native); /* INTL: Native. */
- Tcl_DStringFree(&ds);
-
- return result;
+ CONST char *path = Tcl_FSGetNativePath(pathPtr);
+ if (path == NULL) {
+ return -1;
+ } else {
+ return chdir(path);
+ }
}
\f
/*
*----------------------------------------------------------------------
*
- * TclpLstat --
+ * TclpObjLstat --
*
* This function replaces the library version of lstat().
*
*----------------------------------------------------------------------
*/
-int
-TclpLstat(path, bufPtr)
- CONST char *path; /* Path of file to stat (UTF-8). */
- struct stat *bufPtr; /* Filled with results of stat call. */
+int
+TclpObjLstat(pathPtr, bufPtr)
+ Tcl_Obj *pathPtr; /* Path of file to stat */
+ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
- int result;
- Tcl_DString ds;
- char *native;
-
- native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
- result = lstat(native, bufPtr); /* INTL: Native. */
- Tcl_DStringFree(&ds);
-
- return result;
+ return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
}
\f
/*
*---------------------------------------------------------------------------
*
- * TclpGetCwd --
+ * TclpObjGetCwd --
*
* This function replaces the library version of getcwd().
*
*----------------------------------------------------------------------
*/
-char *
+Tcl_Obj*
+TclpObjGetCwd(interp)
+ Tcl_Interp *interp;
+{
+ Tcl_DString ds;
+ if (TclpGetCwd(interp, &ds) != NULL) {
+ Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_IncrRefCount(cwdPtr);
+ Tcl_DStringFree(&ds);
+ return cwdPtr;
+ } else {
+ return NULL;
+ }
+}
+
+/* Older string based version */
+CONST char *
TclpGetCwd(interp, bufferPtr)
Tcl_Interp *interp; /* If non-NULL, used for error reporting. */
Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
Tcl_DString *linkPtr; /* Uninitialized or free DString filled
* with contents of link (UTF-8). */
{
+#ifndef DJGPP
char link[MAXPATHLEN];
int length;
- char *native;
+ CONST char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
return Tcl_DStringValue(linkPtr);
+#else
+ return NULL;
+#endif
}
\f
/*
*----------------------------------------------------------------------
*
- * TclpStat --
+ * TclpObjStat --
*
* This function replaces the library version of stat().
*
*----------------------------------------------------------------------
*/
-int
-TclpStat(path, bufPtr)
- CONST char *path; /* Path of file to stat (in UTF-8). */
- struct stat *bufPtr; /* Filled with results of stat call. */
+int
+TclpObjStat(pathPtr, bufPtr)
+ Tcl_Obj *pathPtr; /* Path of file to stat */
+ Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
- int result;
- Tcl_DString ds;
- char *native;
-
- native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
- result = stat(native, bufPtr); /* INTL: Native. */
- Tcl_DStringFree(&ds);
+ CONST char *path = Tcl_FSGetNativePath(pathPtr);
+ if (path == NULL) {
+ return -1;
+ } else {
+ return TclOSstat(path, bufPtr);
+ }
+}
+\f
+
+#ifdef S_IFLNK
+
+Tcl_Obj*
+TclpObjLink(pathPtr, toPtr, linkAction)
+ Tcl_Obj *pathPtr;
+ Tcl_Obj *toPtr;
+ int linkAction;
+{
+ if (toPtr != NULL) {
+ CONST char *src = Tcl_FSGetNativePath(pathPtr);
+ CONST char *target = Tcl_FSGetNativePath(toPtr);
+
+ if (src == NULL || target == NULL) {
+ return NULL;
+ }
+ if (access(src, F_OK) != -1) {
+ /* src exists */
+ errno = EEXIST;
+ return NULL;
+ }
+ if (access(target, F_OK) == -1) {
+ /* target doesn't exist */
+ errno = ENOENT;
+ return NULL;
+ }
+ /*
+ * Check symbolic link flag first, since we prefer to
+ * create these.
+ */
+ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ if (symlink(target, src) != 0) return NULL;
+ } else if (linkAction & TCL_CREATE_HARD_LINK) {
+ if (link(target, src) != 0) return NULL;
+ } else {
+ errno = ENODEV;
+ return NULL;
+ }
+ return toPtr;
+ } else {
+ Tcl_Obj* linkPtr = NULL;
+
+ char link[MAXPATHLEN];
+ int length;
+ Tcl_DString ds;
- return result;
+ if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) {
+ return NULL;
+ }
+ length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
+ if (length < 0) {
+ return NULL;
+ }
+
+ Tcl_ExternalToUtfDString(NULL, link, length, &ds);
+ linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ if (linkPtr != NULL) {
+ Tcl_IncrRefCount(linkPtr);
+ }
+ return linkPtr;
+ }
}
+#endif
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpFilesystemPathType --
+ *
+ * This function is part of the native filesystem support, and
+ * returns the path type of the given path. Right now it simply
+ * returns NULL. In the future it could return specific path
+ * types, like 'nfs', 'samba', 'FAT32', etc.
+ *
+ * Results:
+ * NULL at present.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+TclpFilesystemPathType(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+ /* All native paths are of the same type */
+ return NULL;
+}
* RCS: @(#) $Id$
*/
+#if defined(HAVE_CFBUNDLE)
+#include <CoreFoundation/CoreFoundation.h>
+#endif
#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>
+#ifdef HAVE_LANGINFO
+#include <langinfo.h>
+#endif
#if defined(__FreeBSD__)
# include <floatingpoint.h>
#endif
*/
#include "tclInitScript.h"
+/* Used to store the encoding used for binary files */
+static Tcl_Encoding binaryEncoding = NULL;
+/* Has the basic library path encoding issue been fixed */
+static int libraryPathEncodingFixed = 0;
+
+/*
+ * Tcl tries to use standard and homebrew methods to guess the right
+ * encoding on the platform. However, there is always a final fallback,
+ * and this value is it. Make sure it is a real Tcl encoding.
+ */
+
+#ifndef TCL_DEFAULT_ENCODING
+#define TCL_DEFAULT_ENCODING "iso8859-1"
+#endif
/*
* Default directory in which to look for Tcl library scripts. The
/*
* The following table is used to map from Unix locale strings to
- * encoding files.
+ * encoding files. If HAVE_LANGINFO is defined, then this is a fallback
+ * table when the result from nl_langinfo isn't a recognized encoding.
+ * Otherwise this is the first list checked for a mapping from env
+ * encoding to Tcl encoding name.
*/
typedef struct LocaleTable {
} LocaleTable;
static CONST LocaleTable localeTable[] = {
+#ifdef HAVE_LANGINFO
+ {"gb2312-1980", "gb2312"},
+#ifdef __hpux
+ {"SJIS", "shiftjis"},
+ {"eucjp", "euc-jp"},
+ {"euckr", "euc-kr"},
+ {"euctw", "euc-cn"},
+ {"greek8", "cp869"},
+ {"iso88591", "iso8859-1"},
+ {"iso88592", "iso8859-2"},
+ {"iso88595", "iso8859-5"},
+ {"iso88596", "iso8859-6"},
+ {"iso88597", "iso8859-7"},
+ {"iso88598", "iso8859-8"},
+ {"iso88599", "iso8859-9"},
+ {"iso885915", "iso8859-15"},
+ {"roman8", "iso8859-1"},
+ {"tis620", "tis-620"},
+ {"turkish8", "cp857"},
+ {"utf8", "utf-8"},
+#endif /* __hpux */
+#endif /* HAVE_LANGINFO */
+
{"ja_JP.SJIS", "shiftjis"},
{"ja_JP.EUC", "euc-jp"},
+ {"ja_JP.eucJP", "euc-jp"},
{"ja_JP.JIS", "iso2022-jp"},
{"ja_JP.mscode", "shiftjis"},
{"ja_JP.ujis", "euc-jp"},
{NULL, NULL}
};
+
+#ifdef HAVE_CFBUNDLE
+static int Tcl_MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath);
+#endif /* HAVE_CFBUNDLE */
+
\f
/*
*---------------------------------------------------------------------------
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
- char *str;
+ CONST char *str;
Tcl_DString buffer, ds;
int pathc;
- char **pathv;
+ CONST char **pathv;
char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];
Tcl_DStringInit(&ds);
* is installed. The developLib computes the path as though the
* executable is run from a develpment directory.
*/
-
- /* CYGNUS LOCAL */
+
+ /* REDHAT LOCAL */
sprintf(installLib, "share/tcl%s", TCL_VERSION);
- /* END CYGNUS LOCAL */
- sprintf(developLib, "tcl%s/library",
- ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION));
+ /* sprintf(installLib, "lib/tcl%s", TCL_VERSION); */
+ /* END REDHAT LOCAL */
+
+ sprintf(developLib, "tcl%s/library", TCL_PATCH_LEVEL);
/*
* Look for the library relative to default encoding dir.
* This code looks in the following directories:
*
* <bindir>/../<installLib>
- * (e.g. /usr/local/bin/../lib/tcl8.2)
+ * (e.g. /usr/local/bin/../lib/tcl8.4)
* <bindir>/../../<installLib>
- * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.2)
+ * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.4)
* <bindir>/../library
- * (e.g. /usr/src/tcl8.2/unix/../library)
+ * (e.g. /usr/src/tcl8.4.0/unix/../library)
* <bindir>/../../library
- * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../library)
+ * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../library)
* <bindir>/../../<developLib>
- * (e.g. /usr/src/tcl8.2/unix/../../tcl8.2/library)
- * <bindir>/../../../<devlopLib>
- * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../../tcl8.2/library)
+ * (e.g. /usr/src/tcl8.4.0/unix/../../tcl8.4.0/library)
+ * <bindir>/../../../<developLib>
+ * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../../tcl8.4.0/library)
*/
+
+ /*
+ * The variable path holds an absolute path. Take care not to
+ * overwrite pathv[0] since that might produce a relative path.
+ */
+
if (path != NULL) {
Tcl_SplitPath(path, &pathc, &pathv);
- if (pathc > 1) {
+ if (pathc > 2) {
+ str = pathv[pathc - 2];
pathv[pathc - 2] = installLib;
path = Tcl_JoinPath(pathc - 1, pathv, &ds);
+ pathv[pathc - 2] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 2) {
+ if (pathc > 3) {
+ str = pathv[pathc - 3];
pathv[pathc - 3] = installLib;
path = Tcl_JoinPath(pathc - 2, pathv, &ds);
+ pathv[pathc - 3] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 1) {
+ if (pathc > 2) {
+ str = pathv[pathc - 2];
pathv[pathc - 2] = "library";
path = Tcl_JoinPath(pathc - 1, pathv, &ds);
+ pathv[pathc - 2] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 2) {
+ if (pathc > 3) {
+ str = pathv[pathc - 3];
pathv[pathc - 3] = "library";
path = Tcl_JoinPath(pathc - 2, pathv, &ds);
+ pathv[pathc - 3] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 1) {
+ if (pathc > 3) {
+ str = pathv[pathc - 3];
pathv[pathc - 3] = developLib;
path = Tcl_JoinPath(pathc - 2, pathv, &ds);
+ pathv[pathc - 3] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 3) {
+ if (pathc > 4) {
+ str = pathv[pathc - 4];
pathv[pathc - 4] = developLib;
path = Tcl_JoinPath(pathc - 3, pathv, &ds);
+ pathv[pathc - 4] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
* is different from the prtefix.
*/
- str = defaultLibraryDir;
+ {
+#ifdef HAVE_CFBUNDLE
+ char tclLibPath[MAXPATHLEN + 1];
+
+ if (Tcl_MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) {
+ str = tclLibPath;
+ } else
+#endif /* HAVE_CFBUNDLE */
+ {
+ str = defaultLibraryDir;
+ }
if (str[0] != '\0') {
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
+ }
TclSetLibraryPath(pathPtr);
Tcl_DStringFree(&buffer);
* Based on the locale, determine the encoding of the operating
* system and the default encoding for newly opened files.
*
- * Called at process initialization time.
+ * Called at process initialization time, and part way through
+ * startup, we verify that the initial encodings were correctly
+ * setup. Depending on Tcl's environment, there may not have been
+ * enough information first time through (above).
*
* Results:
* None.
*
* Side effects:
- * The Tcl library path is converted from native encoding to UTF-8.
+ * The Tcl library path is converted from native encoding to UTF-8,
+ * on the first call, and the encodings may be changed on first or
+ * second call.
*
*---------------------------------------------------------------------------
*/
void
TclpSetInitialEncodings()
{
- CONST char *encoding;
- int i;
- Tcl_Obj *pathPtr;
- char *langEnv;
+ if (libraryPathEncodingFixed == 0) {
+ CONST char *encoding = NULL;
+ int i, setSysEncCode = TCL_ERROR;
+ Tcl_Obj *pathPtr;
- /*
- * Determine the current encoding from the LC_* or LANG environment
- * variables. We previously used setlocale() to determine the locale,
- * but this does not work on some systems (e.g. Linux/i386 RH 5.0).
- */
+ /*
+ * Determine the current encoding from the LC_* or LANG environment
+ * variables. We previously used setlocale() to determine the locale,
+ * but this does not work on some systems (e.g. Linux/i386 RH 5.0).
+ */
+#ifdef HAVE_LANGINFO
+ if (setlocale(LC_CTYPE, "") != NULL) {
+ Tcl_DString ds;
- langEnv = getenv("LC_ALL");
+ /*
+ * Use a DString so we can overwrite it in name compatability
+ * checks below.
+ */
- if (langEnv == NULL || langEnv[0] == '\0') {
- langEnv = getenv("LC_CTYPE");
- }
- if (langEnv == NULL || langEnv[0] == '\0') {
- langEnv = getenv("LANG");
- }
- if (langEnv == NULL || langEnv[0] == '\0') {
- langEnv = NULL;
- }
+ Tcl_DStringInit(&ds);
+ encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
- encoding = NULL;
- if (langEnv != NULL) {
- for (i = 0; localeTable[i].lang != NULL; i++) {
- if (strcmp(localeTable[i].lang, langEnv) == 0) {
- encoding = localeTable[i].encoding;
- break;
+ Tcl_UtfToLower(Tcl_DStringValue(&ds));
+#ifdef HAVE_LANGINFO_DEBUG
+ fprintf(stderr, "encoding '%s'", encoding);
+#endif
+ if (encoding[0] == 'i' && encoding[1] == 's' && encoding[2] == 'o'
+ && encoding[3] == '-') {
+ char *p, *q;
+ /* need to strip '-' from iso-* encoding */
+ for(p = Tcl_DStringValue(&ds)+3, q = Tcl_DStringValue(&ds)+4;
+ *p; *p++ = *q++);
+ } else if (encoding[0] == 'i' && encoding[1] == 'b'
+ && encoding[2] == 'm' && encoding[3] >= '0'
+ && encoding[3] <= '9') {
+ char *p, *q;
+ /* if langinfo reports "ibm*" we should use "cp*" */
+ p = Tcl_DStringValue(&ds);
+ *p++ = 'c'; *p++ = 'p';
+ for(q = p+1; *p ; *p++ = *q++);
+ } else if ((*encoding == '\0')
+ || !strcmp(encoding, "ansi_x3.4-1968")) {
+ /* Use iso8859-1 for empty or 'ansi_x3.4-1968' encoding */
+ encoding = "iso8859-1";
+ }
+#ifdef HAVE_LANGINFO_DEBUG
+ fprintf(stderr, " ?%s?", encoding);
+#endif
+ setSysEncCode = Tcl_SetSystemEncoding(NULL, encoding);
+ if (setSysEncCode != TCL_OK) {
+ /*
+ * If this doesn't return TCL_OK, the encoding returned by
+ * nl_langinfo or as we translated it wasn't accepted. Do
+ * this fallback check. If this fails, we will enter the
+ * old fallback below.
+ */
+
+ for (i = 0; localeTable[i].lang != NULL; i++) {
+ if (strcmp(localeTable[i].lang, encoding) == 0) {
+ setSysEncCode = Tcl_SetSystemEncoding(NULL,
+ localeTable[i].encoding);
+ break;
+ }
+ }
}
+#ifdef HAVE_LANGINFO_DEBUG
+ fprintf(stderr, " => '%s'\n", encoding);
+#endif
+ Tcl_DStringFree(&ds);
}
- /*
- * There was no mapping in the locale table. If there is an
- * encoding subfield, we can try to guess from that.
- */
+#ifdef HAVE_LANGINFO_DEBUG
+ else {
+ fprintf(stderr, "setlocale returned NULL\n");
+ }
+#endif
+#endif /* HAVE_LANGINFO */
- if (encoding == NULL) {
- char *p;
- for (p = langEnv; *p != '\0'; p++) {
- if (*p == '.') {
- p++;
- break;
- }
+ if (setSysEncCode != TCL_OK) {
+ /*
+ * Classic fallback check. This tries a homebrew algorithm to
+ * determine what encoding should be used based on env vars.
+ */
+ char *langEnv = getenv("LC_ALL");
+ encoding = NULL;
+
+ if (langEnv == NULL || langEnv[0] == '\0') {
+ langEnv = getenv("LC_CTYPE");
}
- if (*p != '\0') {
- Tcl_DString ds;
- Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, p, -1);
-
- encoding = Tcl_DStringValue(&ds);
- Tcl_UtfToLower(Tcl_DStringValue(&ds));
- if (Tcl_SetSystemEncoding(NULL, encoding) == TCL_OK) {
- Tcl_DStringFree(&ds);
- goto resetPath;
- }
- Tcl_DStringFree(&ds);
- encoding = NULL;
+ if (langEnv == NULL || langEnv[0] == '\0') {
+ langEnv = getenv("LANG");
+ }
+ if (langEnv == NULL || langEnv[0] == '\0') {
+ langEnv = NULL;
}
- }
- }
- if (encoding == NULL) {
- encoding = "iso8859-1";
- }
- Tcl_SetSystemEncoding(NULL, encoding);
+ if (langEnv != NULL) {
+ for (i = 0; localeTable[i].lang != NULL; i++) {
+ if (strcmp(localeTable[i].lang, langEnv) == 0) {
+ encoding = localeTable[i].encoding;
+ break;
+ }
+ }
+ /*
+ * There was no mapping in the locale table. If there is an
+ * encoding subfield, we can try to guess from that.
+ */
+
+ if (encoding == NULL) {
+ char *p;
+ for (p = langEnv; *p != '\0'; p++) {
+ if (*p == '.') {
+ p++;
+ break;
+ }
+ }
+ if (*p != '\0') {
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
+ encoding = Tcl_DStringAppend(&ds, p, -1);
+
+ Tcl_UtfToLower(Tcl_DStringValue(&ds));
+ setSysEncCode = Tcl_SetSystemEncoding(NULL, encoding);
+ if (setSysEncCode != TCL_OK) {
+ encoding = NULL;
+ }
+ Tcl_DStringFree(&ds);
+ }
+ }
+#ifdef HAVE_LANGINFO_DEBUG
+ fprintf(stderr, "encoding fallback check '%s' => '%s'\n",
+ langEnv, encoding);
+#endif
+ }
+ if (setSysEncCode != TCL_OK) {
+ if (encoding == NULL) {
+ encoding = TCL_DEFAULT_ENCODING;
+ }
- resetPath:
- /*
- * Initialize the C library's locale subsystem. This is required
- * for input methods to work properly on X11. We only do this for
- * LC_CTYPE because that's the necessary one, and we don't want to
- * affect LC_TIME here. The side effect of setting the default locale
- * should be to load any locale specific modules that are needed by X.
- * [BUG: 5422 3345 4236 2522 2521].
- */
+ Tcl_SetSystemEncoding(NULL, encoding);
+ }
- setlocale(LC_CTYPE, "");
+ /*
+ * Initialize the C library's locale subsystem. This is required
+ * for input methods to work properly on X11. We only do this for
+ * LC_CTYPE because that's the necessary one, and we don't want to
+ * affect LC_TIME here. The side effect of setting the default
+ * locale should be to load any locale specific modules that are
+ * needed by X. [BUG: 5422 3345 4236 2522 2521].
+ * In HAVE_LANGINFO, this call is already done above.
+ */
+#ifndef HAVE_LANGINFO
+ setlocale(LC_CTYPE, "");
+#endif
+ }
- /*
- * In case the initial locale is not "C", ensure that the numeric
- * processing is done in "C" locale regardless. This is needed because
- * Tcl relies on routines like strtod, but should not have locale
- * dependent behavior.
- */
+ /*
+ * In case the initial locale is not "C", ensure that the numeric
+ * processing is done in "C" locale regardless. This is needed because
+ * Tcl relies on routines like strtod, but should not have locale
+ * dependent behavior.
+ */
- setlocale(LC_NUMERIC, "C");
+ setlocale(LC_NUMERIC, "C");
- /*
- * Until the system encoding was actually set, the library path was
- * actually in the native multi-byte encoding, and not really UTF-8
- * as advertised. We cheated as follows:
- *
- * 1. It was safe to allow the Tcl_SetSystemEncoding() call to
- * append the ASCII chars that make up the encoding's filename to
- * the names (in the native encoding) of directories in the library
- * path, since all Unix multi-byte encodings have ASCII in the
- * beginning.
- *
- * 2. To open the encoding file, the native bytes in the file name
- * were passed to the OS, without translating from UTF-8 to native,
- * because the name was already in the native encoding.
- *
- * Now that the system encoding was actually successfully set,
- * translate all the names in the library path to UTF-8. That way,
- * next time we search the library path, we'll translate the names
- * from UTF-8 to the system encoding which will be the native
- * encoding.
- */
+ /*
+ * Until the system encoding was actually set, the library path was
+ * actually in the native multi-byte encoding, and not really UTF-8
+ * as advertised. We cheated as follows:
+ *
+ * 1. It was safe to allow the Tcl_SetSystemEncoding() call to
+ * append the ASCII chars that make up the encoding's filename to
+ * the names (in the native encoding) of directories in the library
+ * path, since all Unix multi-byte encodings have ASCII in the
+ * beginning.
+ *
+ * 2. To open the encoding file, the native bytes in the file name
+ * were passed to the OS, without translating from UTF-8 to native,
+ * because the name was already in the native encoding.
+ *
+ * Now that the system encoding was actually successfully set,
+ * translate all the names in the library path to UTF-8. That way,
+ * next time we search the library path, we'll translate the names
+ * from UTF-8 to the system encoding which will be the native
+ * encoding.
+ */
- pathPtr = TclGetLibraryPath();
- if (pathPtr != NULL) {
- int objc;
- Tcl_Obj **objv;
-
- objc = 0;
- Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
- for (i = 0; i < objc; i++) {
- int length;
- char *string;
- Tcl_DString ds;
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr != NULL) {
+ int objc;
+ Tcl_Obj **objv;
+
+ objc = 0;
+ Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+ for (i = 0; i < objc; i++) {
+ int length;
+ char *string;
+ Tcl_DString ds;
- string = Tcl_GetStringFromObj(objv[i], &length);
- Tcl_ExternalToUtfDString(NULL, string, length, &ds);
- Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
+ string = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+ Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
}
- }
-
- /*
- * Keep the iso8859-1 encoding preloaded. The IO package uses it for
- * gets on a binary channel.
- */
- Tcl_GetEncoding(NULL, "iso8859-1");
+ libraryPathEncodingFixed = 1;
+ }
+
+ /* This is only ever called from the startup thread */
+ if (binaryEncoding == NULL) {
+ /*
+ * Keep the iso8859-1 encoding preloaded. The IO package uses
+ * it for gets on a binary channel.
+ */
+ binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
+ }
}
\f
/*
struct utsname name;
#endif
int unameOK;
- char *user;
+ CONST char *user;
Tcl_DString ds;
- Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
+#ifdef HAVE_CFBUNDLE
+ char tclLibPath[MAXPATHLEN + 1];
+
+ if (Tcl_MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
+ CONST char *str;
+ Tcl_DString ds;
+ CFBundleRef bundleRef;
+
+ Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ str = TclGetEnv("DYLD_FRAMEWORK_PATH", &ds);
+ if ((str != NULL) && (str[0] != '\0')) {
+ char *p = Tcl_DStringValue(&ds);
+ /* convert DYLD_FRAMEWORK_PATH from colon to space separated */
+ do {
+ if(*p == ':') *p = ' ';
+ } while (*p++);
+ Tcl_SetVar(interp, "tcl_pkgPath", Tcl_DStringValue(&ds),
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ Tcl_DStringFree(&ds);
+ }
+ if ((bundleRef = CFBundleGetMainBundle())) {
+ CFURLRef frameworksURL;
+ Tcl_StatBuf statBuf;
+ if((frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef))) {
+ if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
+ tclLibPath, MAXPATHLEN) &&
+ ! TclOSstat(tclLibPath, &statBuf) &&
+ S_ISDIR(statBuf.st_mode)) {
+ Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ }
+ CFRelease(frameworksURL);
+ }
+ if((frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef))) {
+ if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
+ tclLibPath, MAXPATHLEN) &&
+ ! TclOSstat(tclLibPath, &statBuf) &&
+ S_ISDIR(statBuf.st_mode)) {
+ Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ Tcl_SetVar(interp, "tcl_pkgPath", " ",
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ }
+ CFRelease(frameworksURL);
+ }
+ }
+ Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
+ TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
+ } else
+#endif /* HAVE_CFBUNDLE */
+ {
+ Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
+ }
+
+#ifdef DJGPP
+ Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
+#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
+#endif
unameOK = 0;
#ifndef NO_UNAME
if (uname(&name) >= 0) {
- char *native;
+ CONST char *native;
unameOK = 1;
Tcl_Interp *interp; /* Interpreter to source rc file into. */
{
Tcl_DString temp;
- char *fileName;
+ CONST char *fileName;
Tcl_Channel errChannel;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
- char *fullName;
+ CONST char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
return 1;
}
+\f
+#ifdef HAVE_CFBUNDLE
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_MacOSXGetLibraryPath --
+ *
+ * If we have a bundle structure for the Tcl installation,
+ * then check there first to see if we can find the libraries
+ * there.
+ *
+ * Results:
+ * TCL_OK if we have found the tcl library; TCL_ERROR otherwise.
+ *
+ * Side effects:
+ * Same as for Tcl_MacOSXOpenBundleResources.
+ *
+ *----------------------------------------------------------------------
+ */
+static int Tcl_MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath)
+{
+ int foundInFramework = TCL_ERROR;
+ if (strcmp(defaultLibraryDir, "@TCL_IN_FRAMEWORK@") == 0) {
+ foundInFramework = Tcl_MacOSXOpenBundleResources(interp,
+ "com.tcltk.tcllibrary", 0, maxPathLen, tclLibPath);
+ }
+ return foundInFramework;
+}
+#endif /* HAVE_CFBUNDLE */
}
if (found || (tsdPtr->pollState & POLL_DONE)) {
tsdPtr->eventReady = 1;
- Tcl_ConditionNotify(&tsdPtr->waitCV);
if (tsdPtr->onList) {
/*
* Remove the ThreadSpecificData structure of this
tsdPtr->onList = 0;
tsdPtr->pollState = 0;
}
+ Tcl_ConditionNotify(&tsdPtr->waitCV);
}
}
Tcl_MutexUnlock(¬ifierMutex);
Tcl_MutexUnlock(¬ifierMutex);
}
#endif
-
-
static int PipeInputProc _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
static int PipeOutputProc _ANSI_ARGS_((
- ClientData instanceData, char *buf, int toWrite,
+ ClientData instanceData, CONST char *buf, int toWrite,
int *errorCode));
static void PipeWatchProc _ANSI_ARGS_((ClientData instanceData, int mask));
static void RestoreSignals _ANSI_ARGS_((void));
*/
static Tcl_ChannelType pipeChannelType = {
- "pipe", /* Type name. */
- PipeBlockModeProc, /* Set blocking/nonblocking mode.*/
- PipeCloseProc, /* Close proc. */
- PipeInputProc, /* Input proc. */
- PipeOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- NULL, /* Set option proc. */
- NULL, /* Get option proc. */
- PipeWatchProc, /* Initialize notifier. */
- PipeGetHandleProc, /* Get OS handles out of channel. */
+ "pipe", /* Type name. */
+ TCL_CHANNEL_VERSION_2, /* v2 channel */
+ PipeCloseProc, /* Close proc. */
+ PipeInputProc, /* Input proc. */
+ PipeOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ NULL, /* Set option proc. */
+ NULL, /* Get option proc. */
+ PipeWatchProc, /* Initialize notifier. */
+ PipeGetHandleProc, /* Get OS handles out of channel. */
+ NULL, /* close2proc. */
+ PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
+ NULL, /* flush proc. */
+ NULL, /* handler proc. */
};
\f
/*
int mode; /* In what mode to open the file? */
{
int fd;
- char *native;
+ CONST char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
- fd = open(native, mode, 0666); /* INTL: Native. */
+ fd = TclOSopen(native, mode, 0666); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (fd != -1) {
fcntl(fd, F_SETFD, FD_CLOEXEC);
*/
if (mode & O_WRONLY) {
- lseek(fd, (off_t) 0, SEEK_END);
+ TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END);
}
/*
TclpCreateTempFile(contents)
CONST char *contents; /* String to write into temp file, or NULL. */
{
- char fileName[L_tmpnam], *native;
+ char fileName[L_tmpnam + 9];
+ CONST char *native;
Tcl_DString dstring;
int fd;
- if (tmpnam(fileName) == NULL) { /* INTL: Native. */
- return NULL;
+ /*
+ * We should also check against making more then TMP_MAX of these.
+ */
+
+ strcpy(fileName, P_tmpdir); /* INTL: Native. */
+ if (fileName[strlen(fileName) - 1] != '/') {
+ strcat(fileName, "/"); /* INTL: Native. */
}
- fd = open(fileName, O_RDWR|O_CREAT|O_TRUNC, 0666); /* INTL: Native. */
+ strcat(fileName, "tclXXXXXX");
+ fd = mkstemp(fileName); /* INTL: Native. */
if (fd == -1) {
return NULL;
}
return NULL;
}
Tcl_DStringFree(&dstring);
- lseek(fd, (off_t) 0, SEEK_SET);
+ TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
}
return MakeFile(fd);
}
/*
*----------------------------------------------------------------------
*
+ * TclpTempFileName --
+ *
+ * This function returns unique filename.
+ *
+ * Results:
+ * Returns a valid Tcl_Obj* with refCount 0, or NULL on failure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclpTempFileName()
+{
+ char fileName[L_tmpnam + 9];
+ Tcl_Obj *result = NULL;
+ int fd;
+
+ /*
+ * We should also check against making more then TMP_MAX of these.
+ */
+
+ strcpy(fileName, P_tmpdir); /* INTL: Native. */
+ if (fileName[strlen(fileName) - 1] != '/') {
+ strcat(fileName, "/"); /* INTL: Native. */
+ }
+ strcat(fileName, "tclXXXXXX");
+ fd = mkstemp(fileName); /* INTL: Native. */
+ if (fd == -1) {
+ return NULL;
+ }
+ fcntl(fd, F_SETFD, FD_CLOEXEC);
+ unlink(fileName); /* INTL: Native. */
+
+ result = TclpNativeToNormalized((ClientData) fileName);
+ close (fd);
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclpCreatePipe --
*
* Creates a pipe - simply calls the pipe() function.
* Error messages from the child process
* itself are sent to errorFile. */
int argc; /* Number of arguments in following array. */
- char **argv; /* Array of argument strings in UTF-8.
+ CONST char **argv; /* Array of argument strings in UTF-8.
* argv[0] contains the name of the executable
* translated using Tcl_TranslateFileName
* call). Additional arguments have not been
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
}
- joinThisError = (errorFile == outputFile);
+ joinThisError = errorFile && (errorFile == outputFile);
pid = fork();
if (pid == 0) {
fd = GetFd(errPipeOut);
if (pid != -1) {
/*
* Reap the child process now if an error occurred during its
- * startup.
+ * startup. We don't call this with WNOHANG because that can lead to
+ * defunct processes on an MP system. We shouldn't have to worry
+ * about hanging here, since this is the error case. [Bug: 6148]
*/
- Tcl_WaitPid((Tcl_Pid) pid, &status, WNOHANG);
+ Tcl_WaitPid((Tcl_Pid) pid, &status, 0);
}
if (errPipeIn) {
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
* nonblocking, the read will never block.
+ * Some OSes can throw an interrupt error, for which we should
+ * immediately retry. [Bug #415131]
*/
- bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead);
- if (bytesRead > -1) {
- return bytesRead;
+ do {
+ bytesRead = read (GetFd(psPtr->inFile), buf, (size_t) toRead);
+ } while ((bytesRead < 0) && (errno == EINTR));
+
+ if (bytesRead < 0) {
+ *errorCodePtr = errno;
+ return -1;
+ } else {
+ return bytesRead;
}
- *errorCodePtr = errno;
- return -1;
}
\f
/*
static int
PipeOutputProc(instanceData, buf, toWrite, errorCodePtr)
ClientData instanceData; /* Pipe state. */
- char *buf; /* The data buffer. */
+ CONST char *buf; /* The data buffer. */
int toWrite; /* How many bytes to write? */
int *errorCodePtr; /* Where to store error code. */
{
int written;
*errorCodePtr = 0;
- written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite);
- if (written > -1) {
- return written;
+
+ /*
+ * Some OSes can throw an interrupt error, for which we should
+ * immediately retry. [Bug #415131]
+ */
+
+ do {
+ written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite);
+ } while ((written < 0) && (errno == EINTR));
+
+ if (written < 0) {
+ *errorCodePtr = errno;
+ return -1;
+ } else {
+ return written;
}
- *errorCodePtr = errno;
- return -1;
}
\f
/*
}
return TCL_OK;
}
-
-
# include <dirent.h>
#endif
#endif
+
+#ifdef HAVE_STRUCT_DIRENT64
+typedef struct dirent64 Tcl_DirEntry;
+# define TclOSreaddir readdir64
+# define TclOSreaddir_r readdir64_r
+#else
+typedef struct dirent Tcl_DirEntry;
+# define TclOSreaddir readdir
+# define TclOSreaddir_r readdir_r
+#endif
+
+#ifdef HAVE_TYPE_OFF64_T
+typedef off64_t Tcl_SeekOffset;
+# define TclOSseek lseek64
+# define TclOSopen open64
+#else
+typedef off_t Tcl_SeekOffset;
+# define TclOSseek lseek
+# define TclOSopen open
+#endif
+
+#ifdef HAVE_STRUCT_STAT64
+# define TclOSstat stat64
+# define TclOSlstat lstat64
+#else
+# define TclOSstat stat
+# define TclOSlstat lstat
+#endif
+
+#if !HAVE_STRTOLL && defined(TCL_WIDE_INT_TYPE) && !TCL_WIDE_INT_IS_LONG
+EXTERN Tcl_WideInt strtoll _ANSI_ARGS_((CONST char *string,
+ char **endPtr, int base));
+EXTERN Tcl_WideUInt strtoull _ANSI_ARGS_((CONST char *string,
+ char **endPtr, int base));
+#endif
+
#include <sys/file.h>
#ifdef HAVE_SYS_SELECT_H
# include <sys/select.h>
*/
#ifndef S_IFLNK
+# undef TclOSlstat
# define lstat stat
+# define lstat64 stat64
+# define TclOSlstat TclOSstat
#endif
/*
# else
# define S_ISREG(m) 0
# endif
-# endif
+#endif /* !S_ISREG */
#ifndef S_ISDIR
# ifdef S_IFDIR
# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
# else
# define S_ISDIR(m) 0
# endif
-# endif
+#endif /* !S_ISDIR */
#ifndef S_ISCHR
# ifdef S_IFCHR
# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
# else
# define S_ISCHR(m) 0
# endif
-# endif
+#endif /* !S_ISCHR */
#ifndef S_ISBLK
# ifdef S_IFBLK
# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
# else
# define S_ISBLK(m) 0
# endif
-# endif
+#endif /* !S_ISBLK */
#ifndef S_ISFIFO
# ifdef S_IFIFO
# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
# else
# define S_ISFIFO(m) 0
# endif
-# endif
+#endif /* !S_ISFIFO */
#ifndef S_ISLNK
# ifdef S_IFLNK
# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
# else
# define S_ISLNK(m) 0
# endif
-# endif
+#endif /* !S_ISLNK */
#ifndef S_ISSOCK
# ifdef S_IFSOCK
# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK)
# else
# define S_ISSOCK(m) 0
# endif
-# endif
+#endif /* !S_ISSOCK */
/*
* Make sure that MAXPATHLEN is defined.
#ifndef NO_FD_SET
# define SELECT_MASK fd_set
-#else
+#else /* NO_FD_SET */
# ifndef _AIX
typedef long fd_mask;
-# endif
+# endif /* !AIX */
# if defined(_IBMR2)
# define SELECT_MASK void
-# else
+# else /* !defined(_IBMR2) */
# define SELECT_MASK int
-# endif
-#endif
+# endif /* defined(_IBMR2) */
+#endif /* !NO_FD_SET */
/*
* Define "NBBY" (number of bits per byte) if it's not already defined.
# else
# define FD_SETSIZE 256
# endif
-#endif
+#endif /* FD_SETSIZE */
#if !defined(howmany)
# define howmany(x, y) (((x)+((y)-1))/(y))
-#endif
+#endif /* !defined(howmany) */
#ifndef NFDBITS
# define NFDBITS NBBY*sizeof(fd_mask)
-#endif
+#endif /* NFDBITS */
#define MASK_SIZE howmany(FD_SETSIZE, NFDBITS)
/*
extern int errno;
/*
+ * Not all systems declare all the errors that Tcl uses! Provide some
+ * work-arounds...
+ */
+
+#ifndef EOVERFLOW
+# ifdef EFBIG
+# define EOVERFLOW EFBIG
+# else /* !EFBIG */
+# define EOVERFLOW EINVAL
+# endif /* EFBIG */
+#endif /* EOVERFLOW */
+
+/*
* Variables provided by the C library:
*/
extern double strtod();
/*
+ * There is no platform-specific panic routine for Unix in the Tcl internals.
+ */
+
+#define TclpPanic ((Tcl_PanicProc *) NULL)
+
+/*
*---------------------------------------------------------------------------
* The following macros and declarations represent the interface between
* generic and unix-specific parts of Tcl. Some of the macros may override
* The default platform eol translation on Unix is TCL_TRANSLATE_LF.
*/
+#ifdef DJGPP
+#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_CRLF
+#else
#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_LF
+#endif
/*
* The following macros have trivial definitions, allowing generic code to
* address platform-specific issues.
*/
-#define TclpAsyncMark(async)
#define TclpGetPid(pid) ((unsigned long) (pid))
#define TclpReleaseFile(file) /* Nothing. */
#define TclpExit exit
-#ifdef TclpStat
-#undef TclpStat
-#endif
-
-EXTERN int TclpLstat _ANSI_ARGS_((CONST char *path,
- struct stat *buf));
-EXTERN int TclpStat _ANSI_ARGS_((CONST char *path,
- struct stat *buf));
-
/*
* Platform specific mutex definition used by memory allocators.
* These mutexes are statically allocated and explicitly initialized.
EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr));
+EXTERN Tcl_DirEntry * TclpReaddir(DIR *);
+EXTERN struct tm * TclpLocaltime(time_t *);
+EXTERN struct tm * TclpGmtime(time_t *);
+EXTERN char * TclpInetNtoa(struct in_addr);
+#define readdir(x) TclpReaddir(x)
+#define localtime(x) TclpLocaltime(x)
+#define gmtime(x) TclpGmtime(x)
+#define inet_ntoa(x) TclpInetNtoa(x)
+#undef TclOSreaddir
+#define TclOSreaddir(x) TclpReaddir(x)
#else
typedef int TclpMutex;
#define TclpMutexInit(a)
#include "tclIntPlatDecls.h"
#endif /* _TCLUNIXPORT */
-
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetHostName()
{
#ifndef NO_UNAME
(VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname));
if (uname(&u) > -1) { /* INTL: Native. */
hp = gethostbyname(u.nodename); /* INTL: Native. */
+ if (hp == NULL) {
+ /*
+ * Sometimes the nodename is fully qualified, but gets truncated
+ * as it exceeds SYS_NMLN. See if we can just get the immediate
+ * nodename and get a proper answer that way.
+ */
+ char *dot = strchr(u.nodename, '.');
+ if (dot != NULL) {
+ char *node = ckalloc((unsigned) (dot - u.nodename + 1));
+ memcpy(node, u.nodename, (size_t) (dot - u.nodename));
+ node[dot - u.nodename] = '\0';
+ hp = gethostbyname(node);
+ ckfree(node);
+ }
+ }
if (hp != NULL) {
native = hp->h_name;
} else {
{
return TCL_OK;
}
-
static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData,
int mask));
static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
static int TestalarmCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
static void AlarmHandler _ANSI_ARGS_(());
\f
/*
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Pipe *pipePtr;
int i, mask, timeout;
} else if (strcmp(argv[1], "wait") == 0) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
- argv[0], " wait index readable/writable timeout\"",
+ argv[0], " wait index readable|writable timeout\"",
(char *) NULL);
return TCL_ERROR;
}
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
char *oldName;
char *oldNativeName;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
ClientData filePtr;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp,
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
if (argc != 1) {
Tcl_AppendResult(interp,
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
#ifdef SA_RESTART
unsigned int sec;
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, gotsig, (char *) NULL);
gotsig = "0";
return TCL_OK;
}
-
*/
#include "tclInt.h"
+#include "tclPort.h"
#ifdef TCL_THREADS
-#include "tclPort.h"
#include "pthread.h"
+typedef struct ThreadSpecificData {
+ char nabuf[16];
+ struct tm gtbuf;
+ struct tm ltbuf;
+ struct {
+ Tcl_DirEntry ent;
+ char name[PATH_MAX+1];
+ } rdbuf;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
/*
* masterLock is used to serialize creation of mutexes, condition
* variables, and thread local storage.
#endif /* TCL_THREADS */
\f
-
-\f
/*
*----------------------------------------------------------------------
*
#endif /* TCL_THREADS */
}
\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_JoinThread --
+ *
+ * This procedure waits upon the exit of the specified thread.
+ *
+ * Results:
+ * TCL_OK if the wait was successful, TCL_ERROR else.
+ *
+ * Side effects:
+ * The result area is set to the exit code of the thread we
+ * waited upon.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_JoinThread(id, state)
+ Tcl_ThreadId id; /* Id of the thread to wait upon */
+ int* state; /* Reference to the storage the result
+ * of the thread we wait upon will be
+ * written into. */
+{
+#ifdef TCL_THREADS
+ int result;
+
+ result = pthread_join ((pthread_t) id, (VOID**) state);
+ return (result == 0) ? TCL_OK : TCL_ERROR;
+#else
+ return TCL_ERROR;
+#endif
+}
+\f
#ifdef TCL_THREADS
/*
*----------------------------------------------------------------------
if (timePtr == NULL) {
pthread_cond_wait(pcondPtr, pmutexPtr);
} else {
- ptime.tv_sec = timePtr->sec + TclpGetSeconds();
- ptime.tv_nsec = 1000 * timePtr->usec;
+ Tcl_Time now;
+
+ /*
+ * Make sure to take into account the microsecond component of the
+ * current time, including possible overflow situations. [Bug #411603]
+ */
+
+ Tcl_GetTime(&now);
+ ptime.tv_sec = timePtr->sec + now.sec +
+ (timePtr->usec + now.usec) / 1000000;
+ ptime.tv_nsec = 1000 * ((timePtr->usec + now.usec) % 1000000);
pthread_cond_timedwait(pcondPtr, pmutexPtr, &ptime);
}
}
*condPtr = NULL;
}
}
+#endif /* TCL_THREADS */
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa --
+ *
+ * These procedures replace core C versions to be used in a
+ * threaded environment.
+ *
+ * Results:
+ * See documentation of C functions.
+ *
+ * Side effects:
+ * See documentation of C functions.
+ *
+ *----------------------------------------------------------------------
+ */
+#if defined(TCL_THREADS) && !defined(HAVE_READDIR_R)
+TCL_DECLARE_MUTEX( rdMutex )
+#undef readdir
+#endif
+Tcl_DirEntry *
+TclpReaddir(DIR * dir)
+{
+ Tcl_DirEntry *ent;
+#ifdef TCL_THREADS
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-#endif /* TCL_THREADS */
+#ifdef HAVE_READDIR_R
+ ent = &tsdPtr->rdbuf.ent;
+ if (TclOSreaddir_r(dir, ent, &ent) != 0) {
+ ent = NULL;
+ }
+
+#else /* !HAVE_READDIR_R */
+
+ Tcl_MutexLock(&rdMutex);
+# ifdef HAVE_STRUCT_DIRENT64
+ ent = readdir64(dir);
+# else /* !HAVE_STRUCT_DIRENT64 */
+ ent = readdir(dir);
+# endif /* HAVE_STRUCT_DIRENT64 */
+ if (ent != NULL) {
+ memcpy((VOID *) &tsdPtr->rdbuf.ent, (VOID *) ent,
+ sizeof(Tcl_DirEntry) + sizeof(char) * (PATH_MAX+1));
+ ent = &tsdPtr->rdbuf.ent;
+ }
+ Tcl_MutexUnlock(&rdMutex);
+#endif /* HAVE_READDIR_R */
+#else
+# ifdef HAVE_STRUCT_DIRENT64
+ ent = readdir64(dir);
+# else /* !HAVE_STRUCT_DIRENT64 */
+ ent = readdir(dir);
+# endif /* HAVE_STRUCT_DIRENT64 */
+#endif
+ return ent;
+}
+
+#if defined(TCL_THREADS) && (!defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R))
+TCL_DECLARE_MUTEX( tmMutex )
+#undef localtime
+#undef gmtime
+#endif
+
+struct tm *
+TclpLocaltime(time_t * clock)
+{
+#ifdef TCL_THREADS
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+#ifdef HAVE_LOCALTIME_R
+ return localtime_r(clock, &tsdPtr->ltbuf);
+#else
+ Tcl_MutexLock( &tmMutex );
+ memcpy( (VOID *) &tsdPtr->ltbuf, (VOID *) localtime( clock ), sizeof (struct tm) );
+ Tcl_MutexUnlock( &tmMutex );
+ return &tsdPtr->ltbuf;
+#endif
+#else
+ return localtime(clock);
+#endif
+}
+
+struct tm *
+TclpGmtime(time_t * clock)
+{
+#ifdef TCL_THREADS
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+#ifdef HAVE_GMTIME_R
+ return gmtime_r(clock, &tsdPtr->gtbuf);
+#else
+ Tcl_MutexLock( &tmMutex );
+ memcpy( (VOID *) &tsdPtr->gtbuf, (VOID *) gmtime( clock ), sizeof (struct tm) );
+ Tcl_MutexUnlock( &tmMutex );
+ return &tsdPtr->gtbuf;
+#endif
+#else
+ return gmtime(clock);
+#endif
+}
+
+char *
+TclpInetNtoa(struct in_addr addr)
+{
+#ifdef TCL_THREADS
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ union {
+ unsigned long l;
+ unsigned char b[4];
+ } u;
+
+ u.l = (unsigned long) addr.s_addr;
+ sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", u.b[0], u.b[1], u.b[2], u.b[3]);
+ return tsdPtr->nabuf;
+#else
+ return inet_ntoa(addr);
+#endif
+}
+
+#ifdef TCL_THREADS
+/*
+ * Additions by AOL for specialized thread memory allocator.
+ */
+#ifdef USE_THREAD_ALLOC
+static int initialized = 0;
+static pthread_key_t key;
+static pthread_once_t once = PTHREAD_ONCE_INIT;
+
+Tcl_Mutex *
+TclpNewAllocMutex(void)
+{
+ struct lock {
+ Tcl_Mutex tlock;
+ pthread_mutex_t plock;
+ } *lockPtr;
+
+ lockPtr = malloc(sizeof(struct lock));
+ if (lockPtr == NULL) {
+ panic("could not allocate lock");
+ }
+ lockPtr->tlock = (Tcl_Mutex) &lockPtr->plock;
+ pthread_mutex_init(&lockPtr->plock, NULL);
+ return &lockPtr->tlock;
+}
+
+static void
+InitKey(void)
+{
+ extern void TclFreeAllocCache(void *);
+
+ pthread_key_create(&key, TclFreeAllocCache);
+ initialized = 1;
+}
+
+void *
+TclpGetAllocCache(void)
+{
+ if (!initialized) {
+ pthread_once(&once, InitKey);
+ }
+ return pthread_getspecific(key);
+}
+
+void
+TclpSetAllocCache(void *arg)
+{
+ pthread_setspecific(key, arg);
+}
+
+#endif /* USE_THREAD_ALLOC */
+#endif /* TCL_THREADS */
#include "tclInt.h"
#include "tclPort.h"
+#include <locale.h>
#define TM_YEAR_BASE 1900
#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))
+
+/*
+ * TclpGetDate is coded to return a pointer to a 'struct tm'. For
+ * thread safety, this structure must be in thread-specific data.
+ * The 'tmKey' variable is the key to this buffer.
+ */
+
+static Tcl_ThreadDataKey tmKey;
+
+/*
+ * If we fall back on the thread-unsafe versions of gmtime and localtime,
+ * use this mutex to try to protect them.
+ */
+
+#if !defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R)
+TCL_DECLARE_MUTEX(tmMutex)
+#endif
+
+/*
+ * Forward declarations for procedures defined later in this file.
+ */
+
+static struct tm *ThreadSafeGMTime _ANSI_ARGS_(( CONST time_t* ));
+static struct tm *ThreadSafeLocalTime _ANSI_ARGS_(( CONST time_t* ));
\f
/*
*-----------------------------------------------------------------------------
#if defined(HAVE_TM_TZADJ)
# define TCL_GOT_TIMEZONE
time_t curTime = (time_t) currentTime;
- struct tm *timeDataPtr = localtime(&curTime);
+ struct tm *timeDataPtr = ThreadSafeLocalTime(&curTime);
int timeZone;
timeZone = timeDataPtr->tm_tzadj / 60;
#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
# define TCL_GOT_TIMEZONE
time_t curTime = (time_t) currentTime;
- struct tm *timeDataPtr = localtime(&curTime);
+ struct tm *timeDataPtr = ThreadSafeLocalTime(&curTime);
int timeZone;
timeZone = -(timeDataPtr->tm_gmtoff / 60);
time_t tt;
struct tm *stm;
tt = 849268800L; /* 1996-11-29 12:00:00 GMT */
- stm = localtime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */
+ stm = ThreadSafeLocalTime(&tt); /* eg 1996-11-29 6:00:00 CST6CDT */
/* The calculation below assumes a max of +12 or -12 hours from GMT */
timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min);
return timeZone; /* eg +360 for CST6CDT */
/*
*----------------------------------------------------------------------
*
- * TclpGetTime --
+ * Tcl_GetTime --
*
* Gets the current system time in seconds and microseconds
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
*/
void
-TclpGetTime(timePtr)
+Tcl_GetTime(timePtr)
Tcl_Time *timePtr; /* Location to store time information. */
{
struct timeval tv;
CONST time_t *tp = (CONST time_t *)time;
if (useGMT) {
- return gmtime(tp);
+ return ThreadSafeGMTime(tp);
} else {
- return localtime(tp);
+ return ThreadSafeLocalTime(tp);
}
}
\f
*
* TclpStrftime --
*
- * On Unix, we can safely call the native strftime implementation.
+ * On Unix, we can safely call the native strftime implementation,
+ * and also ignore the useGMT parameter.
*
* Results:
* The normal strftime result.
*/
size_t
-TclpStrftime(s, maxsize, format, t)
+TclpStrftime(s, maxsize, format, t, useGMT)
char *s;
size_t maxsize;
CONST char *format;
CONST struct tm *t;
+ int useGMT;
{
if (format[0] == '%' && format[1] == 'Q') {
/* Format as a stardate */
(((t->tm_hour * 60) + t->tm_min)/144));
return(strlen(s));
}
+ setlocale(LC_TIME, "");
return strftime(s, maxsize, format, t);
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ThreadSafeGMTime --
+ *
+ * Wrapper around the 'gmtime' library function to make it thread
+ * safe.
+ *
+ * Results:
+ * Returns a pointer to a 'struct tm' in thread-specific data.
+ *
+ * Side effects:
+ * Invokes gmtime or gmtime_r as appropriate.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static struct tm *
+ThreadSafeGMTime(timePtr)
+ CONST time_t *timePtr; /* Pointer to the number of seconds
+ * since the local system's epoch
+ */
+
+{
+ /*
+ * Get a thread-local buffer to hold the returned time.
+ */
+
+ struct tm *tmPtr = (struct tm *)
+ Tcl_GetThreadData(&tmKey, sizeof(struct tm));
+#ifdef HAVE_GMTIME_R
+ gmtime_r(timePtr, tmPtr);
+#else
+ Tcl_MutexLock(&tmMutex);
+ memcpy((VOID *) tmPtr, (VOID *) gmtime(timePtr), sizeof(struct tm));
+ Tcl_MutexUnlock(&tmMutex);
+#endif
+ return tmPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ThreadSafeLocalTime --
+ *
+ * Wrapper around the 'localtime' library function to make it thread
+ * safe.
+ *
+ * Results:
+ * Returns a pointer to a 'struct tm' in thread-specific data.
+ *
+ * Side effects:
+ * Invokes localtime or localtime_r as appropriate.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static struct tm *
+ThreadSafeLocalTime(timePtr)
+ CONST time_t *timePtr; /* Pointer to the number of seconds
+ * since the local system's epoch
+ */
+
+{
+ /*
+ * Get a thread-local buffer to hold the returned time.
+ */
+
+ struct tm *tmPtr = (struct tm *)
+ Tcl_GetThreadData(&tmKey, sizeof(struct tm));
+#ifdef HAVE_LOCALTIME_R
+ localtime_r(timePtr, tmPtr);
+#else
+ Tcl_MutexLock(&tmMutex);
+ memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm));
+ Tcl_MutexUnlock(&tmMutex);
+#endif
+ return tmPtr;
+}
#include "tcl.h"
static int TesteventloopCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+ Tcl_Interp *interp, int argc, CONST char **argv));
extern void InitNotifier _ANSI_ARGS_((void));
\f
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ CONST char **argv; /* Argument strings. */
{
static int *framePtr = NULL; /* Pointer to integer on stack frame of
* innermost invocation of the "wait"
}
return TCL_OK;
}
-
# when installing files.
INSTALL_ROOT =
-# Directory from which applications will reference the libary of Tcl
+# Directory from which applications will reference the library of Tcl
# scripts (note: you can set the TCL_LIBRARY environment variable at
# run-time to override this value):
+
+# REDHAT LOCAL
+#TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION)
TCL_LIBRARY = @datadir@/tcl$(VERSION)
+# END REDHAT LOCAL
# Path to use at runtime to refer to LIB_INSTALL_DIR:
LIB_RUNTIME_DIR = $(libdir)
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
-# To enable compilation debugging reverse the comment characters on
-# one of the following lines.
-COMPILE_DEBUG_FLAGS =
-#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG
-#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
-
-# The default switches for optimization or debugging
-LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
-LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
-
# To change the compiler switches, for example to change from optimization to
# debugging symbols, change the following line:
#CFLAGS = $(CFLAGS_DEBUG)
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@
+# To enable compilation debugging reverse the comment characters on
+# one of the following lines.
+COMPILE_DEBUG_FLAGS =
+#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG
+#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+
# Special compiler flags to use when building man2tcl on Windows.
MAN2TCLFLAGS = @MAN2TCLFLAGS@
WIN_DIR = @srcdir@
COMPAT_DIR = @srcdir@/../compat
-# This converts a POSIX path to a Windows native path
+# Converts a POSIX path to a Windows native path.
CYGPATH = @CYGPATH@
-GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)')
-WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)')
-ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)')
+GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)')
+WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)')
+ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)')
LIBRARY_DIR = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' )
-VENDORPREFIX = @VENDORPREFIX@
DLLSUFFIX = @DLLSUFFIX@
LIBSUFFIX = @LIBSUFFIX@
EXESUFFIX = @EXESUFFIX@
-LIBPREFIX = @LIBPREFIX@
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
TCL_DLL_FILE = @TCL_DLL_FILE@
TCL_LIB_FILE = @TCL_LIB_FILE@
-TCL_DLL_BASE = @TCL_DLL_BASE@
-GNU_TCL_LIB_FILE = @GNU_TCL_LIB_FILE@
-MSVC_TCL_LIB_FILE = @MSVC_TCL_LIB_FILE@
-DDE_DLL_FILE = @DDE_DLL_FILE@
-DDE_LIB_FILE = @DDE_LIB_FILE@
-DDE_DLL_BASE = @DDE_DLL_BASE@
-REG_DLL_FILE = @REG_DLL_FILE@
-REG_LIB_FILE = @REG_LIB_FILE@
-REG_DLL_BASE = @REG_DLL_BASE@
-PIPE_DLL_FILE = @PIPE_DLL_FILE@
+DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX}
+DDE_LIB_FILE = tcldde$(DDEVER)${LIBSUFFIX}
+REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
+REG_LIB_FILE = tclreg$(REGVER)${LIBSUFFIX}
+PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX}
SHARED_LIBRARIES = $(TCL_DLL_FILE) $(TCL_STUB_LIB_FILE) \
$(DDE_DLL_FILE) $(REG_DLL_FILE) $(PIPE_DLL_FILE)
STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE)
+# TCL_EXE is the name of a tclsh executable that is available *BEFORE*
+# running make for the first time. Certain build targets (make genstubs)
+# need it to be available on the PATH. This executable should *NOT* be
+# required just to do a normal build although it can be required to run
+# make dist.
+TCL_EXE = tclsh
+
TCLSH = tclsh$(VER)${EXESUFFIX}
TCLTEST = tcltest${EXEEXT}
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(EXEEXT)
-SET_MAKE=@SET_MAKE@
+@SET_MAKE@
# Setting the VPATH variable to a list of paths will cause the
# makefile to look into these paths when resolving .c to .obj
RES = @RES@
AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@
CPPFLAGS = @CPPFLAGS@
+LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
+LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS@ @LDFLAGS_DEFAULT@
LDFLAGS_CONSOLE = @LDFLAGS_CONSOLE@
LDFLAGS_WINDOW = @LDFLAGS_WINDOW@
SHLIB_SUFFIX = @SHLIB_SUFFIX@
VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@
DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@
+DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@
+DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@
+REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@
+REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@
LIBS = @LIBS@
RMDIR = rm -rf
tclStubInit.$(OBJEXT) \
tclStubLib.$(OBJEXT) \
tclThread.$(OBJEXT) \
+ tclThreadAlloc.$(OBJEXT) \
+ tclThreadJoin.$(OBJEXT) \
tclTimer.$(OBJEXT) \
tclUtf.$(OBJEXT) \
tclUtil.$(OBJEXT) \
tclWinTime.$(OBJEXT)
COMPAT_OBJS = \
- strftime.$(OBJEXT)
+ strftime.$(OBJEXT) strtoll.$(OBJEXT) strtoull.$(OBJEXT)
PIPE_OBJS = stub16.$(OBJEXT)
$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c
$(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c
-$(TCLSH): $(TCL_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES)
+$(TCLSH): $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(LIBS) \
- tclsh.$(RES) $(CC_EXENAME)
+ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(TCLTEST): $(TCL_LIB_FILE) $(TCLTEST_OBJS) $(CAT32) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \
- tclsh.$(RES) $(CC_EXENAME)
+ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
@MAKE_LIB@ ${STUB_OBJS}
@POST_MAKE_LIB@
-${GNU_TCL_LIB_FILE}: ${TCL_DLL_FILE}
-
${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES)
@$(RM) ${TCL_DLL_FILE}
- @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) $(TCL_DLL_BASE)
+ @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
-${MSVC_TCL_LIB_FILE}: ${TCL_OBJS} ${TCL_DLL_FILE}
+${TCL_LIB_FILE}: ${TCL_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS}
@POST_MAKE_LIB@
${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE}
@$(RM) ${DDE_DLL_FILE}
- @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) \
- $(DDE_DLL_BASE)
+ @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
${DDE_LIB_FILE}: ${DDE_OBJS} ${TCL_LIB_FILE}
@$(RM) ${DDE_LIB_FILE}
${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE}
@$(RM) ${REG_DLL_FILE}
- @MAKE_DLL@ ${REG_OBJS} ${TCL_STUB_LIB_FILE} $(SHLIB_LD_LIBS) \
- $(REG_DLL_BASE)
+ @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE}
@$(RM) ${REG_LIB_FILE}
${PIPE_DLL_FILE}: ${PIPE_OBJS}
@$(RM) ${PIPE_DLL_FILE}
- @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS)
+ @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS) $(LDFLAGS_CONSOLE)
# Add the object extension to the implicit rules. By default .obj is not
# automatically added.
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME)
.rc.$(RES):
- $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
+ $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@
install: all install-binaries install-libraries install-doc
-install-binaries:
- @$(MKDIR) -p "$(BIN_INSTALL_DIR)"
- @$(MKDIR) -p "$(LIB_INSTALL_DIR)"
- $(COPY) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
- @for i in dde1.1 reg1.0; \
+install-binaries: binaries
+ @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \
+ do \
+ if [ ! -d $$i ] ; then \
+ echo "Making directory $$i"; \
+ $(MKDIR) $$i; \
+ chmod 755 $$i; \
+ else true; \
+ fi; \
+ done;
+ @for i in dde1.2 reg1.1; \
do \
if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
@for i in $(TCL_DLL_FILE) $(TCLSH) $(PIPE_DLL_FILE); \
do \
if [ -f $$i ]; then \
- echo "Installing $$i"; \
+ echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
$(COPY) $$i "$(BIN_INSTALL_DIR)"; \
fi; \
done
- @for i in $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
+ @for i in tclConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
do \
if [ -f $$i ]; then \
- echo "Installing $$i"; \
+ echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \
$(COPY) $$i "$(LIB_INSTALL_DIR)"; \
fi; \
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo installing $(DDE_DLL_FILE); \
- $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.1; \
- $(COPY) $(ROOT_DIR)/library/dde1.1/pkgIndex.tcl $(LIB_INSTALL_DIR)/dde1.1; \
+ $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.2; \
+ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
+ $(LIB_INSTALL_DIR)/dde1.2; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo installing $(DDE_LIB_FILE); \
- $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.1; \
+ $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.2; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo installing $(REG_DLL_FILE); \
- $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.0; \
- $(COPY) $(ROOT_DIR)/library/reg1.0/pkgIndex.tcl $(LIB_INSTALL_DIR)/reg1.0; \
+ $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.1; \
+ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \
+ $(LIB_INSTALL_DIR)/reg1.1; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo installing $(REG_LIB_FILE); \
- $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.0; \
+ $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.1; \
fi
-install-libraries:
+install-libraries: libraries
@for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \
$(SCRIPT_INSTALL_DIR); \
do \
else true; \
fi; \
done;
- @for i in http1.0 http2.3 opt0.4 encoding msgcat1.0 tcltest1.0; \
+ @for i in http1.0 http2.4 opt0.4 encoding msgcat1.3 tcltest2.2; \
do \
if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
fi; \
done;
@echo "Installing header files";
- @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" ; \
+ @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \
+ "$(GENERIC_DIR)/tclPlatDecls.h" ; \
do \
$(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \
done;
do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
- @for i in http2.3 http1.0 opt0.4 msgcat1.0 tcltest1.0; \
+ @echo "Installing library http1.0 directory";
+ @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \
+ do \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
+ done;
+ @echo "Installing library http2.4 directory";
+ @for j in $(ROOT_DIR)/library/http/*.tcl; \
do \
- echo "Installing library $$i directory"; \
- for j in $(ROOT_DIR)/library/$$i/*.tcl; \
- do \
- $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/$$i"; \
- done; \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http2.4"; \
done;
- @echo "Installing encodings"
+ @echo "Installing library opt0.4 directory";
+ @for j in $(ROOT_DIR)/library/opt/*.tcl; \
+ do \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
+ done;
+ @echo "Installing library msgcat1.3 directory";
+ @for j in $(ROOT_DIR)/library/msgcat/*.tcl; \
+ do \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/msgcat1.3"; \
+ done;
+ @echo "Installing library tcltest2.2 directory";
+ @for j in $(ROOT_DIR)/library/tcltest/*.tcl; \
+ do \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/tcltest2.2"; \
+ done;
+ @echo "Installing encodings";
@for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
done;
-install-doc:
+install-doc: doc
+
+# Specifying TESTFLAGS on the command line is the standard way to pass
+# args to tcltest, ie:
+# % make test TESTFLAGS="-verbose bps -file fileName.test"
test: binaries $(TCLTEST)
TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
| ./$(CAT32)
# Useful target to launch a built tcltest with the proper path,...
-runtest: tcltest
+runtest: binaries $(TCLTEST)
@TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./tcltest
+ ./$(TCLTEST) $(TESTFLAGS) $(SCRIPT)
-depend:
+# This target can be used to run tclsh from the build directory
+# via `make shell SCRIPT=foo.tcl`
+shell: binaries
+ @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
+ ./$(TCLSH) $(SCRIPT)
+
+# This target can be used to run tclsh inside either gdb or insight
+gdb: binaries
+ @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run
+ gdb ./tclsh --command=gdb.run
+ rm gdb.run
-Makefile: $(SRC_DIR)/Makefile.in config.status
- $(SHELL) config.status
+depend:
-config.status: $(WIN_DIR)/configure
- $(SHELL) config.status --recheck
+Makefile: $(SRC_DIR)/Makefile.in
+ ./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
# Regenerate the stubs files.
#
-# FIXME: We can't depend on TCLSH here since it is not yet built!
-
$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls
- @TCL_LIBRARY="$(ROOT_DIR_NATIVE)/library"; export TCL_LIBRARY; \
- $(TCLSH) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
- "$(GENERIC_DIR_NATIVE)" \
- "$(GENERIC_DIR_NATIVE)\tcl.decls" \
- "$(GENERIC_DIR_NATIVE)\tclInt.decls"
+ @echo "Warning: tclStubInit.c may be out of date."
+ @echo "Developers may want to run \"make genstubs\" to regenerate."
+ @echo "This warning can be safely ignored, do not report as a bug!"
genstubs:
- @TCL_LIBRARY="$(ROOT_DIR_NATIVE)/library"; export TCL_LIBRARY; \
- $(TCLSH) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
+ $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)\tcl.decls" \
"$(GENERIC_DIR_NATIVE)\tclInt.decls"
-Tcl 8.3 for Windows
-
-by Scott Stanton
-Scriptics Corporation
-scott.stanton@scriptics.com
+Tcl 8.4 for Windows
RCS: @(#) $Id$
that are specific to Microsoft Windows.
The information in this file is maintained on the web at:
- http://dev.scriptics.com/doc/howto/compile.html#win
+ http://www.tcl.tk/doc/howto/compile.html#win
+
+The above URL includes a lengthy discussion of compiler macros necessary
+when compiling Tcl extensions that will be dynamically loaded.
2. Compiling Tcl
----------------
-In order to compile Tcl for Windows, you need the following items:
+In order to compile Tcl for Windows, you need the following:
+
+ Tcl 8.4 Source Distribution (plus any patches)
+
+ and
+
+ Visual C++ 5 or newer
+
+ or
+
+ Msys + Mingw 1.1
+
+ http://prdownloads.sourceforge.net/tcl/msys_mingw2.zip
+
+ This Msys + Mingw download is the minimal environment
+ needed to build Tcl/Tk under Windows. It includes a
+ shell environment and gcc. The release is designed to
+ make it as easy a possible to build Tcl/Tk. To install,
+ you just download the zip file and extract the files
+ into a directory. The README.TXT file describes how
+ to launch the msys shell, you then run the configure
+ script in the tcl/win directory.
+
+ or
+
+ Cygwin 1.1 or newer (See http://sources.redhat.com/cygwin)
- Tcl 8.3 Source Distribution (plus any patches)
+ Mingw 1.1 (http://prdownloads.sourceforge.net/mingw/MinGW-1.1.tar.gz)
- Visual C++ 2.x/4.x/5.x
+ Extract the contents of the archive file into /usr/local/mingw
+ and place /usr/local/mingw/bin at the front of your PATH env var
+ before running the configure script in the tcl/win directory.
-In practice, this release is built with Visual C++ 5.0
-In the "win" subdirectory of the source release, you will find
-"makefile.vc". This is the makefile Visual C++ compiler. You should
-update the paths at the top of the file to reflect your system
-configuration. Now you can use "make" (or "nmake" for VC++) to build
-the tcl libraries and the tclsh executable.
+In practice, this release is built with Visual C++ 6.0 and the TEA
+Makefile.
+
+If you are building with Visual C++, in the "win" subdirectory of the
+source release, you will find "makefile.vc". This is the makefile for
+the Visual C++ compiler and uses the stock NMAKE tool. Detailed
+directions for using it, are in the comments of "makefile.vc". A quick
+example would be:
+ C:\tcl_source\win\>nmake -f makefile.vc
+
+There is also a Developer Studio workspace and project file, too, if you
+would like to use them.
+
+If you are building with Msys or Cygwin, you can use the configure script
+that lives in the win subdirectory. The Msys or Cygwin based configure/build
+process works just like the UNIX one, so you will want to refer to
+../unix/README for available configure options. An error will be
+generated by the configure script if you try to compile Tcl with
+the Cygwin version of gcc instead of the Mingw version. Check your
+PATH if you get this error. Be aware that gcc will generate
+lots of compile time warnings when building Tcl. Warnings are
+not errors, so please don't file a bug report about them.
In order to use the binaries generated by these makefiles, you will
need to place the Tcl script library files someplace where Tcl can
1) The path specified in the environment variable "TCL_LIBRARY".
- 2) In the lib\tcl8.3 directory under the installation directory
- as specified in the registry:
+ 2) Relative to the directory containing the current .exe.
+ Tcl will look for a directory "..\lib\tcl8.4" relative to the
+ directory containing the currently running .exe.
- HKEY_LOCAL_MACHINE\SOFTWARE\Scriptics\Tcl\8.3
-
- 3) Relative to the directory containing the current .exe.
- Tcl will look for a directory "..\lib\tcl8.3" relative to the
- directory containing the currently running .exe.
-
-Note that in order to run tclsh83.exe, you must ensure that tcl83.dll
-and tclpip83.dll are on your path, in the system directory, or in the
-directory containing tclsh83.exe.
+Note that in order to run tclsh84.exe, you must ensure that tcl84.dll
+and tclpip84.dll are on your path, in the system directory, or in the
+directory containing tclsh84.exe.
Note: Tcl no longer provides support for Win32s.
-This page includes a lengthy discussion of compiler macros necessary
-when compiling Tcl extensions that will be dynamically loaded.
-
3. Test suite
-------------
the tests are timing dependent and will fail from time to time. If a
test is failing consistently, please send us a bug report with as much
detail as you can manage. Please use the online database at
- http://dev.scriptics.com/ticket/
+ http://tcl.sourceforge.net/
In order to run the test suite, you build the "test" target using the
appropriate makefile for your compiler.
-
-
-
-
builtin(include,tcl.m4)
-builtin(include,../cygtcl.m4)
;\r
-; This file defines the virtual base addresses for Dynamic Link Libraries (DLL)\r
+; This file defines the virtual base addresses for the Dynamic Link Libraries\r
; that are part of the Tcl system. The first token on a line is the key (or name\r
; of the DLL) and the second token is the virtual base address, in hexidecimal.\r
; The third token is the maximum size of the DLL image file, including symbols.\r
expect 0x10480000 0x00080000\r
itcl 0x10500000 0x00080000\r
itk 0x10580000 0x00080000\r
+bltlite 0x10600000 0x00080000\r
+blt 0x10680000 0x00080000\r
\r
ac_help="$ac_help
--enable-shared build and link with shared libraries [--enable-shared]"
ac_help="$ac_help
+ --enable-64bit enable 64bit support (where applicable)"
+ac_help="$ac_help
--enable-symbols build with debugging symbols [--disable-symbols]"
# Initialize some variables set by options.
-TCL_VERSION=8.3
+
+TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=3
-TCL_PATCH_LEVEL=".2"
+TCL_MINOR_VERSION=4
+TCL_PATCH_LEVEL=".1"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
+TCL_DDE_VERSION=1.2
+TCL_DDE_MAJOR_VERSION=1
+TCL_DDE_MINOR_VERSION=2
+TCL_DDE_PATCH_LEVEL=""
+DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
+
+TCL_REG_VERSION=1.1
+TCL_REG_MAJOR_VERSION=1
+TCL_REG_MINOR_VERSION=1
+TCL_REG_PATCH_LEVEL=""
+REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
+
+#------------------------------------------------------------------------
+# Handle the --prefix=... option
+#------------------------------------------------------------------------
+
if test "${prefix}" = "NONE"; then
prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
exec_prefix=$prefix
fi
+# libdir must be a fully qualified path (not ${exec_prefix}/lib)
+eval libdir="$libdir"
#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------
+# If the user did not set CFLAGS, set it now to keep
+# the AC_PROG_CC macro from adding "-g -O2".
+if test "${CFLAGS+set}" != "set" ; then
+ CFLAGS=""
+fi
+
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:552: checking for $ac_word" >&5
+echo "configure:579: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:582: checking for $ac_word" >&5
+echo "configure:609: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
# Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:633: checking for $ac_word" >&5
+echo "configure:660: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
-echo "configure:665: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
+echo "configure:692: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
cat > conftest.$ac_ext << EOF
-#line 676 "configure"
+#line 703 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
-if { (eval echo configure:681: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
+if { (eval echo configure:708: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
ac_cv_prog_cc_works=yes
# If we can't run a trivial program, we are probably using a cross compiler.
if (./conftest; exit) 2>/dev/null; then
{ echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
-echo "configure:707: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
+echo "configure:734: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
-echo "configure:712: checking whether we are using GNU C" >&5
+echo "configure:739: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
yes;
#endif
EOF
-if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:721: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:748: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
-echo "configure:740: checking whether ${CC-cc} accepts -g" >&5
+echo "configure:767: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
-ac_aux_dir=
-for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
- if test -f $ac_dir/install-sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install-sh -c"
- break
- elif test -f $ac_dir/install.sh; then
- ac_aux_dir=$ac_dir
- ac_install_sh="$ac_aux_dir/install.sh -c"
- break
- fi
-done
-if test -z "$ac_aux_dir"; then
- { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
-fi
-ac_config_guess=$ac_aux_dir/config.guess
-ac_config_sub=$ac_aux_dir/config.sub
-ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
-
-
-# Make sure we can run config.sub.
-if ${CONFIG_SHELL-/bin/sh} $ac_config_sub sun4 >/dev/null 2>&1; then :
-else { echo "configure: error: can not run $ac_config_sub" 1>&2; exit 1; }
-fi
-
-echo $ac_n "checking host system type""... $ac_c" 1>&6
-echo "configure:798: checking host system type" >&5
-
-host_alias=$host
-case "$host_alias" in
-NONE)
- case $nonopt in
- NONE)
- if host_alias=`${CONFIG_SHELL-/bin/sh} $ac_config_guess`; then :
- else { echo "configure: error: can not guess host type; you must specify one" 1>&2; exit 1; }
- fi ;;
- *) host_alias=$nonopt ;;
- esac ;;
-esac
-
-host=`${CONFIG_SHELL-/bin/sh} $ac_config_sub $host_alias`
-host_cpu=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
-host_vendor=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
-host_os=`echo $host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
-echo "$ac_t""$host" 1>&6
-
-echo $ac_n "checking build system type""... $ac_c" 1>&6
-echo "configure:819: checking build system type" >&5
-
-build_alias=$build
-case "$build_alias" in
-NONE)
- case $nonopt in
- NONE) build_alias=$host_alias ;;
- *) build_alias=$nonopt ;;
- esac ;;
-esac
-
-build=`${CONFIG_SHELL-/bin/sh} $ac_config_sub $build_alias`
-build_cpu=`echo $build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'`
-build_vendor=`echo $build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'`
-build_os=`echo $build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'`
-echo "$ac_t""$build" 1>&6
-
-if test $host != $build; then
- ac_tool_prefix=${host_alias}-
-else
- ac_tool_prefix=
-fi
-
-# Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args.
-set dummy ${ac_tool_prefix}ar; ac_word=$2
-echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:845: checking for $ac_word" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test -n "$AR"; then
- ac_cv_prog_AR="$AR" # Let the user override the test.
-else
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
- ac_dummy="$PATH"
- for ac_dir in $ac_dummy; do
- test -z "$ac_dir" && ac_dir=.
- if test -f $ac_dir/$ac_word; then
- ac_cv_prog_AR="${ac_tool_prefix}ar"
- break
- fi
- done
- IFS="$ac_save_ifs"
-fi
-fi
-AR="$ac_cv_prog_AR"
-if test -n "$AR"; then
- echo "$ac_t""$AR" 1>&6
-else
- echo "$ac_t""no" 1>&6
-fi
-
+# To properly support cross-compilation, one would
+# need to use these tool checks instead of
+# the ones below and reconfigure with
+# autoconf 2.50. You can also just set
+# the CC, AR, RANLIB, and RC environment
+# variables if you want to cross compile.
-if test -z "$ac_cv_prog_AR"; then
-if test -n "$ac_tool_prefix"; then
- # Extract the first word of "ar", so it can be a program name with args.
+if test "${GCC}" = "yes" ; then
+ # Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:877: checking for $ac_word" >&5
+echo "configure:810: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
done
IFS="$ac_save_ifs"
- test -z "$ac_cv_prog_AR" && ac_cv_prog_AR=":"
fi
fi
AR="$ac_cv_prog_AR"
echo "$ac_t""no" 1>&6
fi
-else
- AR=":"
-fi
-fi
-
-# Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args.
-set dummy ${ac_tool_prefix}ranlib; ac_word=$2
-echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:912: checking for $ac_word" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test -n "$RANLIB"; then
- ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
-else
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
- ac_dummy="$PATH"
- for ac_dir in $ac_dummy; do
- test -z "$ac_dir" && ac_dir=.
- if test -f $ac_dir/$ac_word; then
- ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib"
- break
- fi
- done
- IFS="$ac_save_ifs"
-fi
-fi
-RANLIB="$ac_cv_prog_RANLIB"
-if test -n "$RANLIB"; then
- echo "$ac_t""$RANLIB" 1>&6
-else
- echo "$ac_t""no" 1>&6
-fi
-
-
-if test -z "$ac_cv_prog_RANLIB"; then
-if test -n "$ac_tool_prefix"; then
- # Extract the first word of "ranlib", so it can be a program name with args.
+ # Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:944: checking for $ac_word" >&5
+echo "configure:839: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
done
IFS="$ac_save_ifs"
- test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
fi
fi
RANLIB="$ac_cv_prog_RANLIB"
echo "$ac_t""no" 1>&6
fi
-else
- RANLIB=":"
-fi
-fi
-
-# Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args.
-set dummy ${ac_tool_prefix}windres; ac_word=$2
-echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:979: checking for $ac_word" >&5
-if eval "test \"`echo '$''{'ac_cv_prog_RC'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- if test -n "$RC"; then
- ac_cv_prog_RC="$RC" # Let the user override the test.
-else
- IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
- ac_dummy="$PATH"
- for ac_dir in $ac_dummy; do
- test -z "$ac_dir" && ac_dir=.
- if test -f $ac_dir/$ac_word; then
- ac_cv_prog_RC="${ac_tool_prefix}windres"
- break
- fi
- done
- IFS="$ac_save_ifs"
-fi
-fi
-RC="$ac_cv_prog_RC"
-if test -n "$RC"; then
- echo "$ac_t""$RC" 1>&6
-else
- echo "$ac_t""no" 1>&6
-fi
-
-
-if test -z "$ac_cv_prog_RC"; then
-if test -n "$ac_tool_prefix"; then
- # Extract the first word of "windres", so it can be a program name with args.
+ # Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1011: checking for $ac_word" >&5
+echo "configure:868: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
fi
done
IFS="$ac_save_ifs"
- test -z "$ac_cv_prog_RC" && ac_cv_prog_RC=":"
fi
fi
RC="$ac_cv_prog_RC"
echo "$ac_t""no" 1>&6
fi
-else
- RC=":"
fi
-fi
-
#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
#--------------------------------------------------------------------
echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
-echo "configure:1049: checking whether ${MAKE-make} sets \${MAKE}" >&5
+echo "configure:901: checking whether ${MAKE-make} sets \${MAKE}" >&5
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
#--------------------------------------------------------------------
-# These two macros perform additinal compiler test.
+# Perform additinal compiler tests.
#--------------------------------------------------------------------
echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6
-echo "configure:1081: checking for Cygwin environment" >&5
+echo "configure:933: checking for Cygwin environment" >&5
if eval "test \"`echo '$''{'ac_cv_cygwin'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1086 "configure"
+#line 938 "configure"
#include "confdefs.h"
int main() {
return __CYGWIN__;
; return 0; }
EOF
-if { (eval echo configure:1097: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:949: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_cygwin=yes
else
CYGWIN=
test "$ac_cv_cygwin" = yes && CYGWIN=yes
-case "${host}" in
-*-*-cygwin*)
- touch ac$$.c
- if ${CC} -c -mwin32 ac$$.c >/dev/null 2>&1; then
- case "$EXTRA_CFLAGS" in
- *-mwin32*) ;;
- *) EXTRA_CFLAGS="-mwin32 $EXTRA_CFLAGS" ;;
- esac
- fi
- rm -f ac$$.o ac$$.c
- ;;
-esac
+#if test "$ac_cv_cygwin" = "yes" ; then
+# AC_MSG_ERROR([Compiling with the Cygwin version of gcc is not supported.
+# Use the Mingw version of gcc from www.mingw.org instead.])
+#fi
+
+
+echo $ac_n "checking for SEH support in compiler""... $ac_c" 1>&6
+echo "configure:973: checking for SEH support in compiler" >&5
+if eval "test \"`echo '$''{'tcl_cv_seh'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ if test "$cross_compiling" = yes; then
+ tcl_cv_seh=no
+else
+ cat > conftest.$ac_ext <<EOF
+#line 981 "configure"
+#include "confdefs.h"
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+int main(int argc, char** argv) {
+ int a, b = 0;
+ __try {
+ a = 666 / b;
+ }
+ __except (EXCEPTION_EXECUTE_HANDLER) {
+ return 0;
+ }
+ return 1;
+}
+
+EOF
+if { (eval echo configure:1000: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
+then
+ tcl_cv_seh=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -fr conftest*
+ tcl_cv_seh=no
+fi
+rm -fr conftest*
+fi
+
+
+fi
+
+echo "$ac_t""$tcl_cv_seh" 1>&6
+if test "$tcl_cv_seh" = "no" ; then
+ cat >> confdefs.h <<\EOF
+#define HAVE_NO_SEH 1
+EOF
+
+fi
+
+#
+# Check to see if the excpt.h include file provided contains the
+# definition for EXCEPTION_DISPOSITION; if not, which is the case
+# with Cygwin's version as of 2002-04-10, define it to be int,
+# sufficient for getting the current code to work.
+#
+echo $ac_n "checking for EXCEPTION_DISPOSITION support in include files""... $ac_c" 1>&6
+echo "configure:1030: checking for EXCEPTION_DISPOSITION support in include files" >&5
+if eval "test \"`echo '$''{'tcl_cv_eh_disposition'+set}'`\" = set"; then
+ echo $ac_n "(cached) $ac_c" 1>&6
+else
+ cat > conftest.$ac_ext <<EOF
+#line 1035 "configure"
+#include "confdefs.h"
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+int main() {
+
+ EXCEPTION_DISPOSITION x;
+
+; return 0; }
+EOF
+if { (eval echo configure:1048: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+ rm -rf conftest*
+ tcl_cv_eh_disposition=yes
+else
+ echo "configure: failed program was:" >&5
+ cat conftest.$ac_ext >&5
+ rm -rf conftest*
+ tcl_cv_eh_disposition=no
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$tcl_cv_eh_disposition" 1>&6
+if test "$tcl_cv_eh_disposition" = "no" ; then
+ cat >> confdefs.h <<\EOF
+#define EXCEPTION_DISPOSITION int
+EOF
+
+fi
#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------
echo $ac_n "checking for object suffix""... $ac_c" 1>&6
-echo "configure:1132: checking for object suffix" >&5
+echo "configure:1074: checking for object suffix" >&5
if eval "test \"`echo '$''{'ac_cv_objext'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
rm -f conftest*
echo 'int i = 1;' > conftest.$ac_ext
-if { (eval echo configure:1138: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1080: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
for ac_file in conftest.*; do
case $ac_file in
*.c) ;;
ac_objext=$ac_cv_objext
echo $ac_n "checking for mingw32 environment""... $ac_c" 1>&6
-echo "configure:1156: checking for mingw32 environment" >&5
+echo "configure:1098: checking for mingw32 environment" >&5
if eval "test \"`echo '$''{'ac_cv_mingw32'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1161 "configure"
+#line 1103 "configure"
#include "confdefs.h"
int main() {
return __MINGW32__;
; return 0; }
EOF
-if { (eval echo configure:1168: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+if { (eval echo configure:1110: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_mingw32=yes
else
echo $ac_n "checking for executable suffix""... $ac_c" 1>&6
-echo "configure:1187: checking for executable suffix" >&5
+echo "configure:1129: checking for executable suffix" >&5
if eval "test \"`echo '$''{'ac_cv_exeext'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
rm -f conftest*
echo 'int main () { return 0; }' > conftest.$ac_ext
ac_cv_exeext=
- if { (eval echo configure:1197: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+ if { (eval echo configure:1139: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
for file in conftest.*; do
case $file in
*.c | *.o | *.obj) ;;
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
-echo "configure:1224: checking for building with threads" >&5
+echo "configure:1166: checking for building with threads" >&5
# Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
enableval="$enable_threads"
#define TCL_THREADS 1
EOF
+ # USE_THREAD_ALLOC tells us to try the special thread-based
+ # allocator that significantly reduces lock contention
+ cat >> confdefs.h <<\EOF
+#define USE_THREAD_ALLOC 1
+EOF
+
else
TCL_THREADS=0
echo "$ac_t""no (default)" 1>&6
fi
+
#--------------------------------------------------------------------
echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
-echo "configure:1254: checking how to build libraries" >&5
+echo "configure:1203: checking how to build libraries" >&5
# Check whether --enable-shared or --disable-shared was given.
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
#--------------------------------------------------------------------
- TCL_LIB_VERSIONS_OK=nodots
+
+ # Step 0: Enable 64 bit support?
+
+ echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
+echo "configure:1244: checking if 64bit support is requested" >&5
+ # Check whether --enable-64bit or --disable-64bit was given.
+if test "${enable_64bit+set}" = set; then
+ enableval="$enable_64bit"
+ do64bit=$enableval
+else
+ do64bit=no
+fi
+
+ echo "$ac_t""$do64bit" 1>&6
+
+ # Set some defaults (may get changed below)
+ EXTRA_CFLAGS=""
# Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
-echo "configure:1296: checking for $ac_word" >&5
+echo "configure:1261: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CYGPATH'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
# path when using the Cygwin toolchain.
if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then
- conftest=/tmp/conftest.rc
- echo "STRINGTABLE BEGIN" > $conftest
- echo "101 \"name\"" >> $conftest
- echo "END" >> $conftest
-
- echo $ac_n "checking for Windows native path bug in windres""... $ac_c" 1>&6
-echo "configure:1338: checking for Windows native path bug in windres" >&5
- cyg_conftest=`$CYGPATH $conftest`
- if { ac_try='$RC -o conftest.res.o $cyg_conftest'; { (eval echo configure:1340: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } ; then
- echo "$ac_t""no" 1>&6
- else
- echo "$ac_t""yes" 1>&6
- CYGPATH=echo
- fi
- conftest=
- cyg_conftest=
+ conftest=/tmp/conftest.rc
+ echo "STRINGTABLE BEGIN" > $conftest
+ echo "101 \"name\"" >> $conftest
+ echo "END" >> $conftest
+
+ echo $ac_n "checking for Windows native path bug in windres""... $ac_c" 1>&6
+echo "configure:1303: checking for Windows native path bug in windres" >&5
+ cyg_conftest=`$CYGPATH $conftest`
+ if { ac_try='$RC -o conftest.res.o $cyg_conftest'; { (eval echo configure:1305: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } ; then
+ echo "$ac_t""no" 1>&6
+ else
+ echo "$ac_t""yes" 1>&6
+ CYGPATH=echo
+ fi
+ conftest=
+ cyg_conftest=
fi
if test "$CYGPATH" = "echo" || test "$ac_cv_cygwin" = "yes"; then
DEPARG='"$(shell $(CYGPATH) $<)"'
fi
- # CYGNUS LOCAL
- VENDORPREFIX="rh"
- # END CYGNUS LOCAL
-
# set various compiler flags depending on whether we are using gcc or cl
echo $ac_n "checking compiler flags""... $ac_c" 1>&6
-echo "configure:1363: checking compiler flags" >&5
+echo "configure:1324: checking compiler flags" >&5
if test "${GCC}" = "yes" ; then
-
- # CYGNUS LOCAL
- if test "$ac_cv_cygwin" = "yes" ; then
- VENDORPREFIX="cyg"
+ if test "$do64bit" = "yes" ; then
+ echo "configure: warning: "64bit mode not supported with GCC on Windows"" 1>&2
fi
- # END CYGNUS LOCAL
-
SHLIB_LD=""
SHLIB_LD_LIBS=""
LIBS=""
- LIBS_GUI="-lgdi32 -lcomdlg32"
- STLIB_LD="${AR} cr"
+ LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32"
+ STLIB_LD='${AR} cr'
RC_OUT=-o
RC_TYPE=
RC_INCLUDE=--include
+ RC_DEFINE=--define
RES=res.o
MAKE_LIB="\${STLIB_LD} \$@"
POST_MAKE_LIB="\${RANLIB} \$@"
MAKE_EXE="\${CC} -o \$@"
- LIBPREFIX="lib${VENDORPREFIX}"
+ LIBPREFIX="lib"
+
+ #if test "$ac_cv_cygwin" = "yes"; then
+ # extra_cflags="-mno-cygwin"
+ # extra_ldflags="-mno-cygwin"
+ #else
+ # extra_cflags=""
+ # extra_ldflags=""
+ #fi
+
+ if test "$ac_cv_cygwin" = "yes"; then
+ touch ac$$.c
+ if ${CC} -c -mwin32 ac$$.c >/dev/null 2>&1; then
+ case "$extra_cflags" in
+ *-mwin32*) ;;
+ *) extra_cflags="-mwin32 $extra_cflags" ;;
+ esac
+ case "$extra_ldflags" in
+ *-mwin32*) ;;
+ *) extra_ldflags="-mwin32 $extra_ldflags" ;;
+ esac
+ fi
+ rm -f ac$$.o ac$$.c
+ else
+ extra_cflags=''
+ extra_ldflags=''
+ fi
if test "${SHARED_BUILD}" = "0" ; then
# static
LIBSUFFIX="s\${DBGX}.a"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
- DLLSUFFIX=""
else
# dynamic
echo "$ac_t""using shared flags" 1>&6
# ad-hoc check to see if CC supports -shared.
if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
{ echo "configure: error: ${CC} does not support the -shared option.
- You will need to upgrade to a newer version of the toolchain." 1>&2; exit 1; }
+ You will need to upgrade to a newer version of the toolchain." 1>&2; exit 1; }
fi
runtime=
# Link with gcc since ld does not link to default libs like
- # -luser32 and -lmsvcrt. We also need to add CFLAGS so important
- # flags like -mno-cygwin get passed in to CC.
+ # -luser32 and -lmsvcrt by default. Make sure CFLAGS is
+ # included so -mno-cygwin passed the correct libs to the linker.
SHLIB_LD='${CC} -shared ${CFLAGS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)"
- TCL_DLL_BASE="-Wl,--image-base=0x66000000"
- DDE_DLL_BASE="-Wl,--image-base=0x66100000"
- REG_DLL_BASE="-Wl,--image-base=0x66200000"
LIBSUFFIX="\${DBGX}.a"
- DLLSUFFIX="\${DBGX}.dll"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
+ # DLLSUFFIX is separate because it is the building block for
+ # users of tclConfig.sh that may build shared or static.
+ DLLSUFFIX="\${DBGX}.dll"
+
+ EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE=-O
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
+ #
+ # ORIGINAL COMMENT:
+ # We need to pass -e _WinMain@16 so that ld will use
+ # WinMain() instead of main() as the entry point. We can't
+ # use autoconf to check for this case since it would need
+ # to run an executable and that does not work when
+ # cross compiling. Remove this -e workaround once we
+ # require a gcc that does not have this bug.
+ #
+ # MK NOTE: Tk should use a different mechanism. This causes
+ # interesting problems, such as wish dying at startup.
+ #LDFLAGS_WINDOW="-mwindows -e _WinMain@16 ${extra_ldflags}"
LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}"
LDFLAGS_WINDOW="-mwindows ${extra_ldflags}"
else
- SHLIB_LD="link -dll -nologo"
- SHLIB_LD_LIBS="user32.lib advapi32.lib"
- LIBS="user32.lib advapi32.lib"
- LIBS_GUI="gdi32.lib comdlg32.lib"
- STLIB_LD="lib -nologo"
- RC="rc"
- RC_OUT=-fo
- RC_TYPE=-r
- RC_INCLUDE=-i
- RES=res
- MAKE_LIB="\${STLIB_LD} -out:\$@"
- POST_MAKE_LIB=
- MAKE_EXE="\${CC} -Fe\$@"
- LIBPREFIX=${VENDORPREFIX}
-
if test "${SHARED_BUILD}" = "0" ; then
# static
echo "$ac_t""using static flags" 1>&6
LIBSUFFIX="s\${DBGX}.lib"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
- DLLSUFFIX=""
else
# dynamic
echo "$ac_t""using shared flags" 1>&6
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
LIBSUFFIX="\${DBGX}.lib"
- DLLSUFFIX="\${DBGX}.dll"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
+ # DLLSUFFIX is separate because it is the building block for
+ # users of tclConfig.sh that may build shared or static.
+ DLLSUFFIX="\${DBGX}.dll"
+
+ # This is a 2-stage check to make sure we have the 64-bit SDK
+ # We have to know where the SDK is installed.
+ if test "$do64bit" = "yes" ; then
+ if test "x${MSSDK}x" = "xx" ; then
+ MSSDK="C:/Progra~1/Microsoft SDK"
+ fi
+ # In order to work in the tortured autoconf environment,
+ # we need to ensure that this path has no spaces
+ MSSDK=$(cygpath -w -s "$MSSDK" | sed -e 's!\\!/!g')
+ if test ! -d "${MSSDK}/bin/win64" ; then
+ echo "configure: warning: "could not find 64-bit SDK to enable 64bit mode"" 1>&2
+ do64bit="no"
+ fi
+ fi
+
+ if test "$do64bit" = "yes" ; then
+ # All this magic is necessary for the Win64 SDK RC1 - hobbs
+ CC="${MSSDK}/Bin/Win64/cl.exe \
+ -I${MSSDK}/Include/prerelease \
+ -I${MSSDK}/Include/Win64/crt \
+ -I${MSSDK}/Include/Win64/crt/sys \
+ -I${MSSDK}/Include"
+ RC="${MSSDK}/bin/rc.exe"
+ CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
+ CFLAGS_OPTIMIZE="-nologo -O2 -Gs ${runtime}"
+ lflags="-MACHINE:IA64 -LIBPATH:${MSSDK}/Lib/IA64 \
+ -LIBPATH:${MSSDK}/Lib/Prerelease/IA64"
+ STLIB_LD="${MSSDK}/bin/win64/lib.exe -nologo ${lflags}"
+ LINKBIN="${MSSDK}/bin/win64/link.exe ${lflags}"
+ else
+ RC="rc"
+ CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
+ CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
+ STLIB_LD="lib -nologo"
+ LINKBIN="link -link50compat"
+ fi
+
+ SHLIB_LD="${LINKBIN} -dll -nologo -incremental:no"
+ SHLIB_LD_LIBS="user32.lib advapi32.lib"
+ LIBS="user32.lib advapi32.lib"
+ LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib"
+ RC_OUT=-fo
+ RC_TYPE=-r
+ RC_INCLUDE=-i
+ RC_DEFINE=-d
+ RES=res
+ MAKE_LIB="\${STLIB_LD} -out:\$@"
+ POST_MAKE_LIB=
+ MAKE_EXE="\${CC} -Fe\$@"
+ LIBPREFIX=""
EXTRA_CFLAGS="-YX"
- CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
-# CFLAGS_OPTIMIZE="-nologo -O2 -Gs -GD ${runtime}"
- CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
CFLAGS_WARNING="-W3"
- LDFLAGS_DEBUG="-debug:full -debugtype:cv"
+ LDFLAGS_DEBUG="-debug:full -debugtype:both"
LDFLAGS_OPTIMIZE="-release"
-
+
# Specify the CC output file names based on the target name
CC_OBJNAME="-Fo\$@"
CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\""
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
- LDFLAGS_CONSOLE="-link -subsystem:console"
- LDFLAGS_WINDOW="-link -subsystem:windows"
+ LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}"
+ LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}"
fi
- # Define the same variables as used in tclConfig.sh so that macros
- # that depend on these variables work for both Tcl and extensions.
- TCL_LIB_SUFFIX=$LIBSUFFIX
- TCL_VENDOR_PREFIX=$VENDORPREFIX
+ # DL_LIBS is empty, but then we match the Unix version
+
+
+
+
#--------------------------------------------------------------------
echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
-echo "configure:1506: checking for build with symbols" >&5
+echo "configure:1537: checking for build with symbols" >&5
# Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
enableval="$enable_symbols"
tcl_ok=no
fi
-
- if test "$tcl_ok" = "yes"; then
- CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
- LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
- DBGX=d
- echo "$ac_t""yes" 1>&6
- else
+# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
+ if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
echo "$ac_t""no" 1>&6
+ else
+ CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
+ LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
+ DBGX=g
+ if test "$tcl_ok" = "yes"; then
+ echo "$ac_t""yes (standard debugging)" 1>&6
+ fi
+ fi
+
+
+
+ if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
+ cat >> confdefs.h <<\EOF
+#define TCL_MEM_DEBUG 1
+EOF
+
+ fi
+
+ if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
+ cat >> confdefs.h <<\EOF
+#define TCL_COMPILE_DEBUG 1
+EOF
+
+ cat >> confdefs.h <<\EOF
+#define TCL_COMPILE_STATS 1
+EOF
+
+ fi
+
+ if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
+ if test "$tcl_ok" = "all"; then
+ echo "$ac_t""enabled symbols mem compile debugging" 1>&6
+ else
+ echo "$ac_t""enabled $tcl_ok debugging" 1>&6
+ fi
fi
-#------------------------------------------------------------------------------
-# Find out all about time handling differences.
-#------------------------------------------------------------------------------
+TCL_DBGX=${DBGX}
+
+#--------------------------------------------------------------------
+# man2tcl needs this so that it can use errno.h
+#--------------------------------------------------------------------
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
-echo "configure:1534: checking how to run the C preprocessor" >&5
+echo "configure:1597: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
-#line 1549 "configure"
+#line 1612 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1555: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1618: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
-#line 1566 "configure"
+#line 1629 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1572: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1635: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
rm -rf conftest*
CPP="${CC-cc} -nologo -E"
cat > conftest.$ac_ext <<EOF
-#line 1583 "configure"
+#line 1646 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1589: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1652: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
fi
echo "$ac_t""$CPP" 1>&6
-echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6
-echo "configure:1614: checking whether struct tm is in sys/time.h or time.h" >&5
-if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1619 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <time.h>
-int main() {
-struct tm *tp; tp->tm_sec;
-; return 0; }
-EOF
-if { (eval echo configure:1627: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_struct_tm=time.h
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_struct_tm=sys/time.h
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_struct_tm" 1>&6
-if test $ac_cv_struct_tm = sys/time.h; then
- cat >> confdefs.h <<\EOF
-#define TM_IN_SYS_TIME 1
-EOF
-
-fi
-
-
- for ac_hdr in sys/time.h
-do
-ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
-echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
-echo "configure:1652: checking for $ac_hdr" >&5
+ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
+echo $ac_n "checking for errno.h""... $ac_c" 1>&6
+echo "configure:1678: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
-#line 1657 "configure"
+#line 1683 "configure"
#include "confdefs.h"
-#include <$ac_hdr>
+#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:1662: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
-ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
-if test -z "$ac_err"; then
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=yes"
-else
- echo "$ac_err" >&5
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_header_$ac_safe=no"
-fi
-rm -f conftest*
-fi
-if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- ac_tr_hdr=HAVE_`echo $ac_hdr | sed 'y%abcdefghijklmnopqrstuvwxyz./-%ABCDEFGHIJKLMNOPQRSTUVWXYZ___%'`
- cat >> confdefs.h <<EOF
-#define $ac_tr_hdr 1
-EOF
-
-else
- echo "$ac_t""no" 1>&6
-fi
-done
-
- echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
-echo "configure:1689: checking whether time.h and sys/time.h may both be included" >&5
-if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1694 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <sys/time.h>
-#include <time.h>
-int main() {
-struct tm *tp;
-; return 0; }
-EOF
-if { (eval echo configure:1703: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_header_time=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_header_time=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_header_time" 1>&6
-if test $ac_cv_header_time = yes; then
- cat >> confdefs.h <<\EOF
-#define TIME_WITH_SYS_TIME 1
-EOF
-
-fi
-
- echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6
-echo "configure:1724: checking for tm_zone in struct tm" >&5
-if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1729 "configure"
-#include "confdefs.h"
-#include <sys/types.h>
-#include <$ac_cv_struct_tm>
-int main() {
-struct tm tm; tm.tm_zone;
-; return 0; }
-EOF
-if { (eval echo configure:1737: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- ac_cv_struct_tm_zone=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_struct_tm_zone=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_struct_tm_zone" 1>&6
-if test "$ac_cv_struct_tm_zone" = yes; then
- cat >> confdefs.h <<\EOF
-#define HAVE_TM_ZONE 1
-EOF
-
-else
- echo $ac_n "checking for tzname""... $ac_c" 1>&6
-echo "configure:1757: checking for tzname" >&5
-if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 1762 "configure"
-#include "confdefs.h"
-#include <time.h>
-#ifndef tzname /* For SGI. */
-extern char *tzname[]; /* RS6000 and others reject char **tzname. */
-#endif
-int main() {
-atoi(*tzname);
-; return 0; }
-EOF
-if { (eval echo configure:1772: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
- rm -rf conftest*
- ac_cv_var_tzname=yes
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- ac_cv_var_tzname=no
-fi
-rm -f conftest*
-fi
-
-echo "$ac_t""$ac_cv_var_tzname" 1>&6
- if test $ac_cv_var_tzname = yes; then
- cat >> confdefs.h <<\EOF
-#define HAVE_TZNAME 1
-EOF
-
- fi
-fi
-
-
- echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
-echo "configure:1795: checking tm_tzadj in struct tm" >&5
- cat > conftest.$ac_ext <<EOF
-#line 1797 "configure"
-#include "confdefs.h"
-#include <time.h>
-int main() {
-struct tm tm; tm.tm_tzadj;
-; return 0; }
-EOF
-if { (eval echo configure:1804: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- cat >> confdefs.h <<\EOF
-#define HAVE_TM_TZADJ 1
-EOF
-
- echo "$ac_t""yes" 1>&6
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- echo "$ac_t""no" 1>&6
-fi
-rm -f conftest*
-
- echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6
-echo "configure:1820: checking tm_gmtoff in struct tm" >&5
- cat > conftest.$ac_ext <<EOF
-#line 1822 "configure"
-#include "confdefs.h"
-#include <time.h>
-int main() {
-struct tm tm; tm.tm_gmtoff;
-; return 0; }
-EOF
-if { (eval echo configure:1829: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- cat >> confdefs.h <<\EOF
-#define HAVE_TM_GMTOFF 1
-EOF
-
- echo "$ac_t""yes" 1>&6
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- echo "$ac_t""no" 1>&6
-fi
-rm -f conftest*
-
- #
- # Its important to include time.h in this check, as some systems
- # (like convex) have timezone functions, etc.
- #
- have_timezone=no
- echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
-echo "configure:1850: checking long timezone variable" >&5
- cat > conftest.$ac_ext <<EOF
-#line 1852 "configure"
-#include "confdefs.h"
-#include <time.h>
-int main() {
-extern long timezone;
- timezone += 1;
- exit (0);
-; return 0; }
-EOF
-if { (eval echo configure:1861: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- have_timezone=yes
- cat >> confdefs.h <<\EOF
-#define HAVE_TIMEZONE_VAR 1
-EOF
-
- echo "$ac_t""yes" 1>&6
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- echo "$ac_t""no" 1>&6
-fi
-rm -f conftest*
-
- #
- # On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
- #
- if test "$have_timezone" = no; then
- echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
-echo "configure:1882: checking time_t timezone variable" >&5
- cat > conftest.$ac_ext <<EOF
-#line 1884 "configure"
-#include "confdefs.h"
-#include <time.h>
-int main() {
-extern time_t timezone;
- timezone += 1;
- exit (0);
-; return 0; }
-EOF
-if { (eval echo configure:1893: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
- rm -rf conftest*
- cat >> confdefs.h <<\EOF
-#define HAVE_TIMEZONE_VAR 1
-EOF
-
- echo "$ac_t""yes" 1>&6
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- echo "$ac_t""no" 1>&6
-fi
-rm -f conftest*
- fi
-
- #
- # On some systems (eg Solaris 2.5.1), timezone is not declared in
- # time.h unless you jump through hoops. Instead of that, we just
- # declare it ourselves when necessary.
- #
- if test "$have_timezone" = yes; then
- echo $ac_n "checking for timezone declaration""... $ac_c" 1>&6
-echo "configure:1916: checking for timezone declaration" >&5
-
- tzrx='^[ ]*extern.*timezone'
-
- cat > conftest.$ac_ext <<EOF
-#line 1921 "configure"
-#include "confdefs.h"
-#include <time.h>
-EOF
-if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
- egrep "$tzrx" >/dev/null 2>&1; then
- rm -rf conftest*
-
- cat >> confdefs.h <<\EOF
-#define HAVE_TIMEZONE_DECL 1
-EOF
-
- echo "$ac_t""found" 1>&6
-else
- rm -rf conftest*
- echo "$ac_t""missing" 1>&6
-fi
-rm -f conftest*
-
- fi
-
- #
- # AIX does not have a timezone field in struct tm. When the AIX bsd
- # library is used, the timezone global and the gettimeofday methods are
- # to be avoided for timezone deduction instead, we deduce the timezone
- # by comparing the localtime result on a known GMT value.
- #
-
- if test "`uname -s`" = "AIX" ; then
- echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6
-echo "configure:1951: checking for gettimeofday in -lbsd" >&5
-ac_lib_var=`echo bsd'_'gettimeofday | sed 'y%./+-%__p_%'`
-if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- ac_save_LIBS="$LIBS"
-LIBS="-lbsd $LIBS"
-cat > conftest.$ac_ext <<EOF
-#line 1959 "configure"
-#include "confdefs.h"
-/* Override any gcc2 internal prototype to avoid an error. */
-/* We use char because int might match the return type of a gcc2
- builtin and then its argument prototype would still apply. */
-char gettimeofday();
-
-int main() {
-gettimeofday()
-; return 0; }
-EOF
-if { (eval echo configure:1970: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=yes"
-else
- echo "configure: failed program was:" >&5
- cat conftest.$ac_ext >&5
- rm -rf conftest*
- eval "ac_cv_lib_$ac_lib_var=no"
-fi
-rm -f conftest*
-LIBS="$ac_save_LIBS"
-
-fi
-if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
- echo "$ac_t""yes" 1>&6
- libbsd=yes
-else
- echo "$ac_t""no" 1>&6
-fi
-
- if test $libbsd = yes; then
- cat >> confdefs.h <<\EOF
-#define USE_DELTA_FOR_TZ 1
-EOF
-
- fi
- fi
-
-
-TCL_DBGX=${DBGX}
-
-#--------------------------------------------------------------------
-# man2tcl needs this so that it can use errno.h
-#--------------------------------------------------------------------
-
-ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
-echo $ac_n "checking for errno.h""... $ac_c" 1>&6
-echo "configure:2007: checking for errno.h" >&5
-if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
- echo $ac_n "(cached) $ac_c" 1>&6
-else
- cat > conftest.$ac_ext <<EOF
-#line 2012 "configure"
-#include "confdefs.h"
-#include <errno.h>
-EOF
-ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
-{ (eval echo configure:2017: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+{ (eval echo configure:1688: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
TCL_SHARED_BUILD=${SHARED_BUILD}
-DL_LIBS=
-MATH_LIBS=-lm
-
-
-
#--------------------------------------------------------------------
# Perform final evaluations of variables with possible substitutions.
#--------------------------------------------------------------------
-NODOT_VERSION=${VER}
-
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
+eval "TCL_SRC_DIR=\"`cd $srcdir/..; pwd`\""
- val="`cd $srcdir/..; pwd`"
+eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_SRC_DIR" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_SRC_DIR=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_SRC_DIR="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_SRC_DIR=$val
- ;;
- esac
+eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
+# FIMXE: These variables decls are missing
+#TCL_LIB_FLAG
+TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VER}${TCL_DBGX}"
+#TCL_LIB_SPEC
+eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
+eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${TCL_DBGX}\""
+eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`pwd` ${TCL_STUB_LIB_FLAG}\""
+eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
+eval "TCL_BUILD_STUB_LIB_PATH=\"`pwd`/${TCL_STUB_LIB_FILE}\""
+eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
+# Install time header dir can be set via --includedir
+eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
- libname=tcl
- suffix=${TCL_UNSHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- else
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- fi
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- TCL_LIB_FILE=$long_libname
-
-
- libname=tcl
- suffix=${TCL_SHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32* | *cygwin*)
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
+eval "DLLSUFFIX=${DLLSUFFIX}"
+eval "LIBPREFIX=${LIBPREFIX}"
+eval "LIBSUFFIX=${LIBSUFFIX}"
+eval "EXESUFFIX=${EXESUFFIX}"
- TCL_DLL_FILE=$long_libname
+CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}
+CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}
+CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
+#--------------------------------------------------------------------
+# Adjust the defines for how the resources are built depending
+# on symbols and static vs. shared.
+#--------------------------------------------------------------------
-if test "$GCC" = "yes"; then
- GNU_TCL_LIB_FILE=${TCL_LIB_FILE}
- MSVC_TCL_LIB_FILE=
+if test ${SHARED_BUILD} = 0 ; then
+ if test "${DBGX}" = "d"; then
+ RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG"
+ else
+ RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
+ fi
else
- GNU_TCL_LIB_FILE=
- MSVC_TCL_LIB_FILE=${TCL_LIB_FILE}
+ if test "${DBGX}" = "d"; then
+ RC_DEFINES="${RC_DEFINE} DEBUG"
+ else
+ RC_DEFINES=""
+ fi
fi
-TCL_BIN_DIR=`pwd`
-
-
- libname=tcl
- version=$TCL_VERSION
-
- if test "$TCL_LIB_SUFFIX" = "" ; then
- { echo "configure: error: The TCL_LIB_SUFFIX variable is not defined" 1>&2; exit 1; }
- fi
- # If the . character is not allowed in lib name, remove it from version
- if test "${TCL_LIB_VERSIONS_OK}" != "ok"; then
- version=`echo $version | tr -d .`
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "short_libname=\"${TCL_VENDOR_PREFIX}${libname}${version}${TCL_LIB_SUFFIX}\""
- else
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}${TCL_DBGX}"
- fi
- ;;
- *)
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}\${TCL_DBGX}"
- ;;
- esac
-
- TCL_LIB_FLAG=$short_libname
-
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="`pwd`/${TCL_LIB_FLAG}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_BUILD_LIB_SPEC" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_BUILD_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_BUILD_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_BUILD_LIB_SPEC=$val
- ;;
- esac
-
- else
-
- val=`pwd`
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
-
- TCL_BUILD_LIB_SPEC="-L${dirname} ${TCL_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
- ;;
- esac
-
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="${exec_prefix}/lib/${TCL_LIB_FLAG}"
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_LIB_SPEC" 1>&2; exit 1; }
- fi
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_LIB_SPEC=$val
- ;;
- esac
- else
-
- val=${exec_prefix}/lib
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
- TCL_LIB_SPEC="-L${dirname} ${TCL_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_LIB_SPEC="-L${exec_prefix}/lib ${TCL_LIB_FLAG}"
- ;;
- esac
-
- val="`pwd`/${TCL_LIB_FILE}"
+# empty on win
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_LIB_FULL_PATH" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_LIB_FULL_PATH=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_LIB_FULL_PATH="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_LIB_FULL_PATH=$val
- ;;
- esac
-
-
-
-
-
- libname=tclstub
- suffix=${TCL_UNSHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- else
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- fi
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- TCL_STUB_LIB_FILE=$long_libname
-
-
- libname=tclstub
- version=$TCL_VERSION
-
- if test "$TCL_LIB_SUFFIX" = "" ; then
- { echo "configure: error: The TCL_LIB_SUFFIX variable is not defined" 1>&2; exit 1; }
- fi
-
- # If the . character is not allowed in lib name, remove it from version
- if test "${TCL_LIB_VERSIONS_OK}" != "ok"; then
- version=`echo $version | tr -d .`
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "short_libname=\"${TCL_VENDOR_PREFIX}${libname}${version}${TCL_LIB_SUFFIX}\""
- else
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}${TCL_DBGX}"
- fi
- ;;
- *)
- short_libname="-l${TCL_VENDOR_PREFIX}${libname}${version}\${TCL_DBGX}"
- ;;
- esac
-
- TCL_STUB_LIB_FLAG=$short_libname
-
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="`pwd`/${TCL_STUB_LIB_FLAG}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_BUILD_STUB_LIB_SPEC" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_BUILD_STUB_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_BUILD_STUB_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_BUILD_STUB_LIB_SPEC=$val
- ;;
- esac
-
- else
-
- val=`pwd`
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
-
- TCL_BUILD_STUB_LIB_SPEC="-L${dirname} ${TCL_STUB_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
- ;;
- esac
-
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
-
- val="${exec_prefix}/lib/${TCL_STUB_LIB_FLAG}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_STUB_LIB_SPEC" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_STUB_LIB_SPEC=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_STUB_LIB_SPEC="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_STUB_LIB_SPEC=$val
- ;;
- esac
-
- else
-
- val=${exec_prefix}/lib
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable dirname" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- dirname=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- dirname="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- dirname=$val
- ;;
- esac
-
- TCL_STUB_LIB_SPEC="-L${dirname} ${TCL_STUB_LIB_FLAG}"
- fi
- ;;
- *)
- TCL_STUB_LIB_SPEC="-L${exec_prefix}/lib ${TCL_STUB_LIB_FLAG}"
- ;;
- esac
-
-
-
- val="`pwd`/${TCL_STUB_LIB_FILE}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_BUILD_STUB_LIB_PATH" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_BUILD_STUB_LIB_PATH=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_BUILD_STUB_LIB_PATH="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_BUILD_STUB_LIB_PATH=$val
- ;;
- esac
-
-
-
-
- val="${exec_prefix}/lib/${TCL_STUB_LIB_FILE}"
-
- if test "$val" = "" ; then
- { echo "configure: error: Empty value for variable TCL_STUB_LIB_PATH" 1>&2; exit 1; }
- fi
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "${CYGPATH}" = ""; then
- { echo "configure: error: CYGPATH variable is not defined." 1>&2; exit 1; }
- elif test "${CYGPATH}" = "echo"; then
- # No cygpath when cross compiling
- TCL_STUB_LIB_PATH=$val
- else
- # store literal argument text in a variable
- val=$val
- # Convert Cygwin to Windows path (/tmp/foo -> C:\Tmp\foo)
- val="`${CYGPATH} $val`"
- # Convert path like C:\Tmp\foo to C:/Tmp/foo
- TCL_STUB_LIB_PATH="`echo $val | sed -e s#\\\\\\\\#/#g`"
- fi
- ;;
- *)
- # Default to a no-op under Unix or Cygwin gcc
- TCL_STUB_LIB_PATH=$val
- ;;
- esac
-
-
-
-
-
- libname=tcldde
- suffix=${TCL_SHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32* | *cygwin*)
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- DDE_DLL_FILE=$long_libname
-
-
- libname=tcldde
- suffix=${TCL_UNSHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- else
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- fi
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- DDE_LIB_FILE=$long_libname
-
-
-
- libname=tclreg
- suffix=${TCL_SHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32* | *cygwin*)
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- REG_DLL_FILE=$long_libname
-
-
- libname=tclreg
- suffix=${TCL_UNSHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32*)
- if test "$GCC" != yes; then
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- else
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- fi
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- REG_LIB_FILE=$long_libname
-
-
-
- libname=tclpip
- suffix=${TCL_SHARED_LIB_SUFFIX}
-
- case "${host}" in
- *windows32* | *mingw32* | *cygwin*)
- eval "long_libname=\"${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- *)
- eval "long_libname=\"lib${TCL_VENDOR_PREFIX}${libname}${suffix}\""
- ;;
- esac
-
- eval "long_libname=${long_libname}"
-
- # Trick to replace DBGX with TCL_DBGX
- DBGX='${TCL_DBGX}'
- eval "long_libname=${long_libname}"
-
- PIPE_DLL_FILE=$long_libname
-
-
-
-eval "DLLSUFFIX=${DLLSUFFIX}"
-eval "LIBPREFIX=${LIBPREFIX}"
-eval "LIBSUFFIX=${LIBSUFFIX}"
-eval "EXESUFFIX=${EXESUFFIX}"
-
-CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}
-CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}
-CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
+# win/tcl.m4 doesn't set (CFLAGS)
+# win/tcl.m4 doesn't set (LDFLAGS)
+# empty on win, but needs sub'ing
+# win only
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g
s%@CC@%$CC%g
-s%@host@%$host%g
-s%@host_alias@%$host_alias%g
-s%@host_cpu@%$host_cpu%g
-s%@host_vendor@%$host_vendor%g
-s%@host_os@%$host_os%g
-s%@build@%$build%g
-s%@build_alias@%$build_alias%g
-s%@build_cpu@%$build_cpu%g
-s%@build_vendor@%$build_vendor%g
-s%@build_os@%$build_os%g
s%@AR@%$AR%g
s%@RANLIB@%$RANLIB%g
s%@RC@%$RC%g
s%@SET_MAKE@%$SET_MAKE%g
s%@OBJEXT@%$OBJEXT%g
s%@EXEEXT@%$EXEEXT%g
+s%@TCL_THREADS@%$TCL_THREADS%g
s%@CYGPATH@%$CYGPATH%g
+s%@DL_LIBS@%$DL_LIBS%g
+s%@CFLAGS_DEBUG@%$CFLAGS_DEBUG%g
+s%@CFLAGS_OPTIMIZE@%$CFLAGS_OPTIMIZE%g
+s%@CFLAGS_WARNING@%$CFLAGS_WARNING%g
+s%@CFLAGS_DEFAULT@%$CFLAGS_DEFAULT%g
+s%@LDFLAGS_DEFAULT@%$LDFLAGS_DEFAULT%g
s%@CPP@%$CPP%g
s%@MAN2TCLFLAGS@%$MAN2TCLFLAGS%g
-s%@DL_LIBS@%$DL_LIBS%g
-s%@MATH_LIBS@%$MATH_LIBS%g
s%@TCL_VERSION@%$TCL_VERSION%g
s%@TCL_MAJOR_VERSION@%$TCL_MAJOR_VERSION%g
s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g
-s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g
s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g
s%@TCL_LIB_FILE@%$TCL_LIB_FILE%g
-s%@GNU_TCL_LIB_FILE@%$GNU_TCL_LIB_FILE%g
-s%@MSVC_TCL_LIB_FILE@%$MSVC_TCL_LIB_FILE%g
-s%@TCL_DLL_FILE@%$TCL_DLL_FILE%g
-s%@TCL_DLL_BASE@%$TCL_DLL_BASE%g
s%@TCL_LIB_FLAG@%$TCL_LIB_FLAG%g
-s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g
s%@TCL_LIB_SPEC@%$TCL_LIB_SPEC%g
-s%@TCL_LIB_FULL_PATH@%$TCL_LIB_FULL_PATH%g
s%@TCL_STUB_LIB_FILE@%$TCL_STUB_LIB_FILE%g
s%@TCL_STUB_LIB_FLAG@%$TCL_STUB_LIB_FLAG%g
-s%@TCL_BUILD_STUB_LIB_SPEC@%$TCL_BUILD_STUB_LIB_SPEC%g
s%@TCL_STUB_LIB_SPEC@%$TCL_STUB_LIB_SPEC%g
-s%@TCL_BUILD_STUB_LIB_PATH@%$TCL_BUILD_STUB_LIB_PATH%g
s%@TCL_STUB_LIB_PATH@%$TCL_STUB_LIB_PATH%g
-s%@DDE_DLL_FILE@%$DDE_DLL_FILE%g
-s%@DDE_DLL_BASE@%$DDE_DLL_BASE%g
-s%@DDE_LIB_FILE@%$DDE_LIB_FILE%g
-s%@REG_DLL_FILE@%$REG_DLL_FILE%g
-s%@REG_DLL_BASE@%$REG_DLL_BASE%g
-s%@REG_LIB_FILE@%$REG_LIB_FILE%g
-s%@PIPE_DLL_FILE@%$PIPE_DLL_FILE%g
+s%@TCL_INCLUDE_SPEC@%$TCL_INCLUDE_SPEC%g
+s%@TCL_BUILD_STUB_LIB_SPEC@%$TCL_BUILD_STUB_LIB_SPEC%g
+s%@TCL_BUILD_STUB_LIB_PATH@%$TCL_BUILD_STUB_LIB_PATH%g
+s%@TCL_DLL_FILE@%$TCL_DLL_FILE%g
s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g
s%@TCL_BIN_DIR@%$TCL_BIN_DIR%g
s%@TCL_DBGX@%$TCL_DBGX%g
s%@CFG_TCL_SHARED_LIB_SUFFIX@%$CFG_TCL_SHARED_LIB_SUFFIX%g
s%@CFG_TCL_UNSHARED_LIB_SUFFIX@%$CFG_TCL_UNSHARED_LIB_SUFFIX%g
s%@CFG_TCL_EXPORT_FILE_SUFFIX@%$CFG_TCL_EXPORT_FILE_SUFFIX%g
-s%@TCL_SHARED_BUILD@%$TCL_SHARED_BUILD%g
-s%@DEPARG@%$DEPARG%g
-s%@CFLAGS_DEFAULT@%$CFLAGS_DEFAULT%g
-s%@CFLAGS_DEBUG@%$CFLAGS_DEBUG%g
-s%@CFLAGS_OPTIMIZE@%$CFLAGS_OPTIMIZE%g
-s%@CFLAGS_WARNING@%$CFLAGS_WARNING%g
s%@EXTRA_CFLAGS@%$EXTRA_CFLAGS%g
-s%@STLIB_LD@%$STLIB_LD%g
-s%@SHLIB_LD@%$SHLIB_LD%g
-s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g
-s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g
+s%@DEPARG@%$DEPARG%g
s%@CC_OBJNAME@%$CC_OBJNAME%g
s%@CC_EXENAME@%$CC_EXENAME%g
-s%@TCL_LD_SEARCH_FLAGS@%$TCL_LD_SEARCH_FLAGS%g
-s%@LDFLAGS_DEFAULT@%$LDFLAGS_DEFAULT%g
s%@LDFLAGS_DEBUG@%$LDFLAGS_DEBUG%g
s%@LDFLAGS_OPTIMIZE@%$LDFLAGS_OPTIMIZE%g
s%@LDFLAGS_CONSOLE@%$LDFLAGS_CONSOLE%g
s%@LDFLAGS_WINDOW@%$LDFLAGS_WINDOW%g
-s%@RC_OUT@%$RC_OUT%g
-s%@RC_TYPE@%$RC_TYPE%g
-s%@RC_INCLUDE@%$RC_INCLUDE%g
-s%@RES@%$RES%g
+s%@STLIB_LD@%$STLIB_LD%g
+s%@SHLIB_LD@%$SHLIB_LD%g
+s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g
+s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g
+s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g
+s%@TCL_SHARED_BUILD@%$TCL_SHARED_BUILD%g
s%@LIBS_GUI@%$LIBS_GUI%g
s%@DLLSUFFIX@%$DLLSUFFIX%g
-s%@VENDORPREFIX@%$VENDORPREFIX%g
s%@LIBPREFIX@%$LIBPREFIX%g
s%@LIBSUFFIX@%$LIBSUFFIX%g
s%@EXESUFFIX@%$EXESUFFIX%g
s%@POST_MAKE_LIB@%$POST_MAKE_LIB%g
s%@MAKE_DLL@%$MAKE_DLL%g
s%@MAKE_EXE@%$MAKE_EXE%g
+s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g
+s%@TCL_LD_SEARCH_FLAGS@%$TCL_LD_SEARCH_FLAGS%g
+s%@TCL_NEEDS_EXP_FILE@%$TCL_NEEDS_EXP_FILE%g
+s%@TCL_BUILD_EXP_FILE@%$TCL_BUILD_EXP_FILE%g
+s%@TCL_EXP_FILE@%$TCL_EXP_FILE%g
+s%@LIBOBJS@%$LIBOBJS%g
+s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g
+s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g
+s%@TCL_DDE_VERSION@%$TCL_DDE_VERSION%g
+s%@TCL_DDE_MAJOR_VERSION@%$TCL_DDE_MAJOR_VERSION%g
+s%@TCL_DDE_MINOR_VERSION@%$TCL_DDE_MINOR_VERSION%g
+s%@TCL_DDE_PATCH_LEVEL@%$TCL_DDE_PATCH_LEVEL%g
+s%@TCL_REG_VERSION@%$TCL_REG_VERSION%g
+s%@TCL_REG_MAJOR_VERSION@%$TCL_REG_MAJOR_VERSION%g
+s%@TCL_REG_MINOR_VERSION@%$TCL_REG_MINOR_VERSION%g
+s%@TCL_REG_PATCH_LEVEL@%$TCL_REG_PATCH_LEVEL%g
+s%@RC_OUT@%$RC_OUT%g
+s%@RC_TYPE@%$RC_TYPE%g
+s%@RC_INCLUDE@%$RC_INCLUDE%g
+s%@RC_DEFINE@%$RC_DEFINE%g
+s%@RC_DEFINES@%$RC_DEFINES%g
+s%@RES@%$RES%g
CEOF
EOF
rm -fr confdefs* $ac_clean_files
test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
-
+#! /bin/bash -norc
# This file is an input file used by the GNU "autoconf" program to
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
# RCS: @(#) $Id$
AC_INIT(../generic/tcl.h)
+AC_PREREQ(2.13)
-TCL_VERSION=8.3
+TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=3
-TCL_PATCH_LEVEL=".2"
+TCL_MINOR_VERSION=4
+TCL_PATCH_LEVEL=".1"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
+TCL_DDE_VERSION=1.2
+TCL_DDE_MAJOR_VERSION=1
+TCL_DDE_MINOR_VERSION=2
+TCL_DDE_PATCH_LEVEL=""
+DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
+
+TCL_REG_VERSION=1.1
+TCL_REG_MAJOR_VERSION=1
+TCL_REG_MINOR_VERSION=1
+TCL_REG_PATCH_LEVEL=""
+REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
+
+#------------------------------------------------------------------------
+# Handle the --prefix=... option
+#------------------------------------------------------------------------
+
if test "${prefix}" = "NONE"; then
prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
exec_prefix=$prefix
fi
+# libdir must be a fully qualified path (not ${exec_prefix}/lib)
+eval libdir="$libdir"
#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------
+# If the user did not set CFLAGS, set it now to keep
+# the AC_PROG_CC macro from adding "-g -O2".
+if test "${CFLAGS+set}" != "set" ; then
+ CFLAGS=""
+fi
+
AC_PROG_CC
-AC_CHECK_TOOL(AR, ar, :)
-AC_CHECK_TOOL(RANLIB, ranlib, :)
-AC_CHECK_TOOL(RC, windres, :)
+# To properly support cross-compilation, one would
+# need to use these tool checks instead of
+# the ones below and reconfigure with
+# autoconf 2.50. You can also just set
+# the CC, AR, RANLIB, and RC environment
+# variables if you want to cross compile.
+dnl AC_CHECK_TOOL(AR, ar, :)
+dnl AC_CHECK_TOOL(RANLIB, ranlib, :)
+dnl AC_CHECK_TOOL(RC, windres, :)
+
+if test "${GCC}" = "yes" ; then
+ AC_CHECK_PROG(AR, ar, ar)
+ AC_CHECK_PROG(RANLIB, ranlib, ranlib)
+ AC_CHECK_PROG(RC, windres, windres)
+fi
#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
AC_PROG_MAKE_SET
#--------------------------------------------------------------------
-# These two macros perform additinal compiler test.
+# Perform additinal compiler tests.
#--------------------------------------------------------------------
AC_CYGWIN
-case "${host}" in
-*-*-cygwin*)
- touch ac$$.c
- if ${CC} -c -mwin32 ac$$.c >/dev/null 2>&1; then
- case "$EXTRA_CFLAGS" in
- *-mwin32*) ;;
- *) EXTRA_CFLAGS="-mwin32 $EXTRA_CFLAGS" ;;
- esac
- fi
- rm -f ac$$.o ac$$.c
- ;;
-esac
+#if test "$ac_cv_cygwin" = "yes" ; then
+# AC_MSG_ERROR([Compiling with the Cygwin version of gcc is not supported.
+# Use the Mingw version of gcc from www.mingw.org instead.])
+#fi
+
+
+AC_CACHE_CHECK(for SEH support in compiler,
+ tcl_cv_seh,
+AC_TRY_RUN([
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+int main(int argc, char** argv) {
+ int a, b = 0;
+ __try {
+ a = 666 / b;
+ }
+ __except (EXCEPTION_EXECUTE_HANDLER) {
+ return 0;
+ }
+ return 1;
+}
+],
+ tcl_cv_seh=yes,
+ tcl_cv_seh=no,
+ tcl_cv_seh=no)
+)
+if test "$tcl_cv_seh" = "no" ; then
+ AC_DEFINE(HAVE_NO_SEH, 1,
+ [Defined when mingw does not support SEH])
+fi
+
+#
+# Check to see if the excpt.h include file provided contains the
+# definition for EXCEPTION_DISPOSITION; if not, which is the case
+# with Cygwin's version as of 2002-04-10, define it to be int,
+# sufficient for getting the current code to work.
+#
+AC_CACHE_CHECK(for EXCEPTION_DISPOSITION support in include files,
+ tcl_cv_eh_disposition,
+AC_TRY_COMPILE([
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+],
+[
+ EXCEPTION_DISPOSITION x;
+],
+ tcl_cv_eh_disposition=yes,
+ tcl_cv_eh_disposition=no)
+)
+if test "$tcl_cv_eh_disposition" = "no" ; then
+ AC_DEFINE(EXCEPTION_DISPOSITION, int,
+ [Defined when cygwin/mingw does not support EXCEPTION DISPOSITION])
+fi
#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
SC_ENABLE_SYMBOLS
-#------------------------------------------------------------------------------
-# Find out all about time handling differences.
-#------------------------------------------------------------------------------
-
-SC_TIME_HANDLER
-
TCL_DBGX=${DBGX}
#--------------------------------------------------------------------
TCL_SHARED_BUILD=${SHARED_BUILD}
-DL_LIBS=
-MATH_LIBS=-lm
-AC_SUBST(DL_LIBS)
-AC_SUBST(MATH_LIBS)
-
#--------------------------------------------------------------------
# Perform final evaluations of variables with possible substitutions.
#--------------------------------------------------------------------
-NODOT_VERSION=${VER}
-
TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}"
TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
-TCL_TOOL_PATH(TCL_SRC_DIR, "`cd $srcdir/..; pwd`")
+eval "TCL_SRC_DIR=\"`cd $srcdir/..; pwd`\""
-dnl CYGNUS LOCAL - Can't conflict with installed tcl package
+eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
-TCL_TOOL_STATIC_LIB_LONGNAME(TCL_LIB_FILE, tcl, ${TCL_UNSHARED_LIB_SUFFIX})
-TCL_TOOL_SHARED_LIB_LONGNAME(TCL_DLL_FILE, tcl, ${TCL_SHARED_LIB_SUFFIX})
+eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
+# FIMXE: These variables decls are missing
+#TCL_LIB_FLAG
+TCL_BUILD_LIB_SPEC="-L`pwd` -ltcl${VER}${TCL_DBGX}"
+#TCL_LIB_SPEC
-if test "$GCC" = "yes"; then
- GNU_TCL_LIB_FILE=${TCL_LIB_FILE}
- MSVC_TCL_LIB_FILE=
-else
- GNU_TCL_LIB_FILE=
- MSVC_TCL_LIB_FILE=${TCL_LIB_FILE}
-fi
-TCL_BIN_DIR=`pwd`
+eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
+eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${TCL_DBGX}\""
+eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`pwd` ${TCL_STUB_LIB_FLAG}\""
+eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
+eval "TCL_BUILD_STUB_LIB_PATH=\"`pwd`/${TCL_STUB_LIB_FILE}\""
+eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
-TCL_TOOL_LIB_SHORTNAME(TCL_LIB_FLAG, tcl, $TCL_VERSION)
-TCL_TOOL_LIB_SPEC(TCL_BUILD_LIB_SPEC, `pwd`, ${TCL_LIB_FLAG})
-TCL_TOOL_LIB_SPEC(TCL_LIB_SPEC, ${exec_prefix}/lib, ${TCL_LIB_FLAG})
-TCL_TOOL_LIB_PATH(TCL_LIB_FULL_PATH, `pwd`, ${TCL_LIB_FILE})
-
-
-TCL_TOOL_STATIC_LIB_LONGNAME(TCL_STUB_LIB_FILE, tclstub, ${TCL_UNSHARED_LIB_SUFFIX})
-TCL_TOOL_LIB_SHORTNAME(TCL_STUB_LIB_FLAG, tclstub, $TCL_VERSION)
-TCL_TOOL_LIB_SPEC(TCL_BUILD_STUB_LIB_SPEC, `pwd`, ${TCL_STUB_LIB_FLAG})
-TCL_TOOL_LIB_SPEC(TCL_STUB_LIB_SPEC, ${exec_prefix}/lib, ${TCL_STUB_LIB_FLAG})
-TCL_TOOL_LIB_PATH(TCL_BUILD_STUB_LIB_PATH, `pwd`, ${TCL_STUB_LIB_FILE})
-TCL_TOOL_LIB_PATH(TCL_STUB_LIB_PATH, ${exec_prefix}/lib, ${TCL_STUB_LIB_FILE})
-
-
-TCL_TOOL_SHARED_LIB_LONGNAME(DDE_DLL_FILE, tcldde, ${TCL_SHARED_LIB_SUFFIX})
-TCL_TOOL_STATIC_LIB_LONGNAME(DDE_LIB_FILE, tcldde, ${TCL_UNSHARED_LIB_SUFFIX})
-
-TCL_TOOL_SHARED_LIB_LONGNAME(REG_DLL_FILE, tclreg, ${TCL_SHARED_LIB_SUFFIX})
-TCL_TOOL_STATIC_LIB_LONGNAME(REG_LIB_FILE, tclreg, ${TCL_UNSHARED_LIB_SUFFIX})
-
-TCL_TOOL_SHARED_LIB_LONGNAME(PIPE_DLL_FILE, tclpip, ${TCL_SHARED_LIB_SUFFIX})
+# Install time header dir can be set via --includedir
+eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
eval "DLLSUFFIX=${DLLSUFFIX}"
CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}
CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}
+#--------------------------------------------------------------------
+# Adjust the defines for how the resources are built depending
+# on symbols and static vs. shared.
+#--------------------------------------------------------------------
+
+if test ${SHARED_BUILD} = 0 ; then
+ if test "${DBGX}" = "d"; then
+ RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG"
+ else
+ RC_DEFINES="${RC_DEFINE} STATIC_BUILD"
+ fi
+else
+ if test "${DBGX}" = "d"; then
+ RC_DEFINES="${RC_DEFINE} DEBUG"
+ else
+ RC_DEFINES=""
+ fi
+fi
+
+
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_MAJOR_VERSION)
AC_SUBST(TCL_MINOR_VERSION)
-AC_SUBST(TCL_LIB_VERSIONS_OK)
AC_SUBST(TCL_PATCH_LEVEL)
+
AC_SUBST(TCL_LIB_FILE)
-AC_SUBST(GNU_TCL_LIB_FILE)
-AC_SUBST(MSVC_TCL_LIB_FILE)
-AC_SUBST(TCL_DLL_FILE)
-AC_SUBST(TCL_DLL_BASE)
AC_SUBST(TCL_LIB_FLAG)
-AC_SUBST(TCL_BUILD_LIB_SPEC)
+# empty on win
AC_SUBST(TCL_LIB_SPEC)
-AC_SUBST(TCL_LIB_FULL_PATH)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
-AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_SPEC)
-AC_SUBST(TCL_BUILD_STUB_LIB_PATH)
AC_SUBST(TCL_STUB_LIB_PATH)
-
-AC_SUBST(DDE_DLL_FILE)
-AC_SUBST(DDE_DLL_BASE)
-AC_SUBST(DDE_LIB_FILE)
-AC_SUBST(REG_DLL_FILE)
-AC_SUBST(REG_DLL_BASE)
-AC_SUBST(REG_LIB_FILE)
-AC_SUBST(PIPE_DLL_FILE)
+AC_SUBST(TCL_INCLUDE_SPEC)
+AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
+AC_SUBST(TCL_BUILD_STUB_LIB_PATH)
+AC_SUBST(TCL_DLL_FILE)
AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX)
-AC_SUBST(TCL_SHARED_BUILD)
-AC_SUBST(CYGPATH)
-AC_SUBST(DEPARG)
+# win/tcl.m4 doesn't set (CFLAGS)
AC_SUBST(CFLAGS_DEFAULT)
-AC_SUBST(CFLAGS_DEBUG)
-AC_SUBST(CFLAGS_OPTIMIZE)
-AC_SUBST(CFLAGS_WARNING)
AC_SUBST(EXTRA_CFLAGS)
-AC_SUBST(STLIB_LD)
-AC_SUBST(SHLIB_LD)
-AC_SUBST(SHLIB_LD_LIBS)
-AC_SUBST(SHLIB_CFLAGS)
+AC_SUBST(CYGPATH)
+AC_SUBST(DEPARG)
AC_SUBST(CC_OBJNAME)
AC_SUBST(CC_EXENAME)
-AC_SUBST(TCL_LD_SEARCH_FLAGS)
+
+# win/tcl.m4 doesn't set (LDFLAGS)
AC_SUBST(LDFLAGS_DEFAULT)
AC_SUBST(LDFLAGS_DEBUG)
AC_SUBST(LDFLAGS_OPTIMIZE)
AC_SUBST(LDFLAGS_WINDOW)
AC_SUBST(AR)
AC_SUBST(RANLIB)
-AC_SUBST(RC)
-AC_SUBST(RC_OUT)
-AC_SUBST(RC_TYPE)
-AC_SUBST(RC_INCLUDE)
-AC_SUBST(RES)
+
+AC_SUBST(STLIB_LD)
+AC_SUBST(SHLIB_LD)
+AC_SUBST(SHLIB_LD_LIBS)
+AC_SUBST(SHLIB_CFLAGS)
+AC_SUBST(SHLIB_SUFFIX)
+AC_SUBST(TCL_SHARED_BUILD)
+
AC_SUBST(LIBS)
AC_SUBST(LIBS_GUI)
AC_SUBST(DLLSUFFIX)
-AC_SUBST(VENDORPREFIX)
AC_SUBST(LIBPREFIX)
AC_SUBST(LIBSUFFIX)
AC_SUBST(EXESUFFIX)
AC_SUBST(MAKE_DLL)
AC_SUBST(MAKE_EXE)
-AC_OUTPUT(Makefile tclConfig.sh tcl.hpj)
+# empty on win, but needs sub'ing
+AC_SUBST(TCL_BUILD_LIB_SPEC)
+AC_SUBST(TCL_LD_SEARCH_FLAGS)
+AC_SUBST(TCL_NEEDS_EXP_FILE)
+AC_SUBST(TCL_BUILD_EXP_FILE)
+AC_SUBST(TCL_EXP_FILE)
+AC_SUBST(DL_LIBS)
+AC_SUBST(LIBOBJS)
+AC_SUBST(TCL_LIB_VERSIONS_OK)
+AC_SUBST(TCL_PACKAGE_PATH)
+
+# win only
+AC_SUBST(TCL_DDE_VERSION)
+AC_SUBST(TCL_DDE_MAJOR_VERSION)
+AC_SUBST(TCL_DDE_MINOR_VERSION)
+AC_SUBST(TCL_DDE_PATCH_LEVEL)
+AC_SUBST(TCL_REG_VERSION)
+AC_SUBST(TCL_REG_MAJOR_VERSION)
+AC_SUBST(TCL_REG_MINOR_VERSION)
+AC_SUBST(TCL_REG_PATCH_LEVEL)
+AC_SUBST(RC)
+AC_SUBST(RC_OUT)
+AC_SUBST(RC_TYPE)
+AC_SUBST(RC_INCLUDE)
+AC_SUBST(RC_DEFINE)
+AC_SUBST(RC_DEFINES)
+AC_SUBST(RES)
+
+AC_OUTPUT(Makefile tclConfig.sh tcl.hpj)
This software is copyrighted by the Regents of the University of
-California, Sun Microsystems, Inc., Scriptics Corporation,
-and other parties. The following terms apply to all files associated
-with the software unless explicitly disclaimed in individual files.
+California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState
+Corporation and other parties. The following terms apply to all files
+associated with the software unless explicitly disclaimed in
+individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.
-
-
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# RCS: @(#) $Id$
-#
-# Borland C++ 4.5 makefile
-#
-
-#
-# Project directories
-#
-# ROOT = top of source tree
-# TMPDIR = location where .obj files should be stored during build
-# TOOLS = location of compiler and other development tools
-#
-
-ROOT = ..
-TMPDIR = .
-TOOLS = c:\bc45
-
-# uncomment the following line to compile with symbols
-#DEBUG=1
-
-# uncomment one of the following lines to compile with TCL_MEM_DEBUG,
-# TCL_COMPILE_DEBUG, or TCL_COMPILE_STATS
-#DEBUGDEFINES =TCL_MEM_DEBUG
-#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG
-#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_STATS
-#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG;TCL_COMPILE_STATS
-
-
-######################################################################
-# Do not modify below this line
-######################################################################
-
-STACKSIZE = 1f0001
-
-VERSION = 80
-
-TCLLIB = tcl$(VERSION).lib
-TCLDLL = tcl$(VERSION).dll
-TCL16DLL = tcl16$(VERSION).dll
-TCLSH = tclsh$(VERSION).exe
-TCLTEST = tcltest.exe
-DUMPEXTS = dumpexts.exe
-TCLPIPEDLL = tclpip$(VERSION).dll
-TCLREGDLL = tclreg$(VERSION).dll
-CAT16 = cat16.exe
-CAT32 = cat32.exe
-
-TCLSHOBJS = \
- $(TMPDIR)\tclAppInit.obj
-
-TCLTESTOBJS = \
- $(TMPDIR)\tclTest.obj \
- $(TMPDIR)\tclTestObj.obj \
- $(TMPDIR)\tclWinTest.obj \
- $(TMPDIR)\testMain.obj
-
-TCLOBJS = \
- $(TMPDIR)\panic.obj \
- $(TMPDIR)\regexp.obj \
- $(TMPDIR)\strftime.obj \
- $(TMPDIR)\tclAlloc.obj \
- $(TMPDIR)\tclAsync.obj \
- $(TMPDIR)\tclBasic.obj \
- $(TMPDIR)\tclBinary.obj \
- $(TMPDIR)\tclCkalloc.obj \
- $(TMPDIR)\tclClock.obj \
- $(TMPDIR)\tclCmdAH.obj \
- $(TMPDIR)\tclCmdIL.obj \
- $(TMPDIR)\tclCmdMZ.obj \
- $(TMPDIR)\tclCompExpr.obj \
- $(TMPDIR)\tclCompile.obj \
- $(TMPDIR)\tclDate.obj \
- $(TMPDIR)\tclEnv.obj \
- $(TMPDIR)\tclEvent.obj \
- $(TMPDIR)\tclExecute.obj \
- $(TMPDIR)\tclFCmd.obj \
- $(TMPDIR)\tclFileName.obj \
- $(TMPDIR)\tclGet.obj \
- $(TMPDIR)\tclHash.obj \
- $(TMPDIR)\tclHistory.obj \
- $(TMPDIR)\tclIndexObj.obj \
- $(TMPDIR)\tclInterp.obj \
- $(TMPDIR)\tclIO.obj \
- $(TMPDIR)\tclIOCmd.obj \
- $(TMPDIR)\tclIOSock.obj \
- $(TMPDIR)\tclIOUtil.obj \
- $(TMPDIR)\tclLink.obj \
- $(TMPDIR)\tclListObj.obj \
- $(TMPDIR)\tclLoad.obj \
- $(TMPDIR)\tclMain.obj \
- $(TMPDIR)\tclNamesp.obj \
- $(TMPDIR)\tclNotify.obj \
- $(TMPDIR)\tclObj.obj \
- $(TMPDIR)\tclParse.obj \
- $(TMPDIR)\tclPipe.obj \
- $(TMPDIR)\tclPkg.obj \
- $(TMPDIR)\tclPosixStr.obj \
- $(TMPDIR)\tclPreserve.obj \
- $(TMPDIR)\tclProc.obj \
- $(TMPDIR)\tclResolve.obj \
- $(TMPDIR)\tclStringObj.obj \
- $(TMPDIR)\tclTimer.obj \
- $(TMPDIR)\tclUtil.obj \
- $(TMPDIR)\tclVar.obj \
- $(TMPDIR)\tclWin32Dll.obj \
- $(TMPDIR)\tclWinChan.obj \
- $(TMPDIR)\tclWinError.obj \
- $(TMPDIR)\tclWinFCmd.obj \
- $(TMPDIR)\tclWinFile.obj \
- $(TMPDIR)\tclWinInit.obj \
- $(TMPDIR)\tclWinLoad.obj \
- $(TMPDIR)\tclWinMtherr.obj \
- $(TMPDIR)\tclWinNotify.obj \
- $(TMPDIR)\tclWinPipe.obj \
- $(TMPDIR)\tclWinSock.obj \
- $(TMPDIR)\tclWinTime.obj
-
-cc32 = $(TOOLS)\bin\bcc32.exe
-link32 = $(TOOLS)\bin\tlink32.exe
-rc32 = $(TOOLS)\bin\brcc32.exe
-implib = $(TOOLS)\bin\implib.exe
-
-cc16 = $(TOOLS)\bin\bcc.exe
-link16 = $(TOOLS)\bin\tlink.exe
-rc16 = $(TOOLS)\bin\brcc32.exe -31
-
-CP = copy
-RM = del
-
-WINDIR = $(ROOT)\win
-GENERICDIR = $(ROOT)\generic
-
-INCLUDES = $(TOOLS)\include;$(WINDIR);$(GENERICDIR)
-LIBDIRS = $(TOOLS)\lib;$(WINDIR)
-
-CON_CFLAGS = +cfgexe.cfg -WC
-TEST_CFLAGS = +cfgtest.cfg
-DLL16_CFLAGS = $(PROJECTCCFLAGS) -I$(INCLUDES) -D$(DEFINES) -WD -ml -c \
- -3 -d -w
-TCL_CFLAGS = +cfgdll.cfg
-
-CON_LFLAGS = -Tpe -ap -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0x32
-DLL_LFLAGS = -Tpd -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0d32
-GUI_LFLAGS = -Tpe -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0w32
-DLL16_LFLAGS = -Twd -c -C -A=16 $(DEBUGLDFLAGS16) $(TOOLS)\lib\c0dl
-
-DLL_LIBS = import32 cw32mti
-CON_LIBS = $(TCLLIB) import32 cw32mti
-DLL16_LIBS = import cwl
-
-!ifndef DEBUG
-
-# these macros cause maximum optimization and no symbols
-DEBUGLDFLAGS =
-DEBUGCCFLAGS = -v- -vi- -O2
-DEBUGLDFLAGS16 = -Oc -Oi -Oa -Or
-!else
-
-# these macros enable debugging
-DEBUGLDFLAGS = -v
-DEBUGCCFLAGS = -k -Od -v
-DEBUGLDFLAGS16 =
-
-!endif
-
-DEFINES = MT;_RTLDLL;$(DEBUGDEFINES)
-PROJECTCCFLAGS = $(DEBUGCCFLAGS) -w-par -w-stu
-
-
-#
-# Global makefile settings
-#
-
-.AUTODEPEND
-.CACHEAUTODEPEND
-
-.suffixes:
-
-#.path.c=$(ROOT)\win;$(ROOT)\generic;$(ROOT)\compat
-#.path.obj=$(TMPDIR)
-#.path.dll=$(ROOT)\win
-
-#
-# Targets
-#
-
-release: $(TCLSH) dlls
-all: $(TCLSH) dlls $(CAT16) $(CAT32)
-tcltest: $(TCLTEST) dlls $(CAT16) $(CAT32)
-dlls: $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL)
-
-test: tcltest
- $(TCLTEST) &&|
- cd ../tests
- source all
-|
-
-
-$(DUMPEXTS): cfgexe.cfg $(WINDIR)\winDumpExts.c
- $(cc32) $(CON_CFLAGS) $(WINDIR)\winDumpExts.c
- $(link32) $(CON_LFLAGS) \
- $(TMPDIR)\winDumpExts.obj,$@,,import32 cw32mti,,
-
-$(TCLLIB): $(TCLDLL)
- $(implib) -c $@ $(TCLDLL)
-
-$(TCLDLL): cfgdll.cfg $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res
- $(link32) $(DLL_LFLAGS) @&&|
- $(TCLOBJS)
-$@
--x
-$(DLL_LIBS)
-|, $(TMPDIR)\tcl.def, $(TMPDIR)\tcl.res
-
-
-$(TCLSH): cfgexe.cfg $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&|
- $(TCLSHOBJS)
-$@
--x
-$(CON_LIBS)
-|, &&|
-EXETYPE WINDOWS
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE MULTIPLE
-|, $(TMPDIR)\tclsh.res
-
-$(TCLTEST): cfgtest.cfg $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&|
- $(TCLTESTOBJS)
-$@
--x
-$(CON_LIBS)
-|, &&|
-EXETYPE WINDOWS
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE MULTIPLE
-|, $(TMPDIR)\tclsh.res
-
-
-$(TCL16DLL): tcl16.rc $(ROOT)\win\tclWin16.c
- $(cc16) @&&|
-$(DLL16_CFLAGS) -n$(TMPDIR)
-| $(ROOT)\win\tclWin16.c
- $(rc16) @&&|
--i$(INCLUDES) -d__WIN32__;$(DEFINES) -fo$(TMPDIR)\tcl16.res
-| tcl16.rc
- @copy >nul &&|
-LIBRARY $&;dll
-EXETYPE WINDOWS
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE SINGLE
-HEAPSIZE 1024
-EXPORTS
- WEP @1 RESIDENTNAME
- UTPROC @2
-| $(TMPDIR)\tclWin16.def
- $(link16) $(DLL16_LFLAGS) @&&|
-$(TMPDIR)\tclWin16.obj
-$@
-nul
-$(DLL16_LIBS)
-$(TMPDIR)\tclWin16.def
-|
- $(TOOLS)\bin\rlink $(TMPDIR)\tcl16.res $@
-
-$(TCLPIPEDLL): cfgexe.cfg stub16.c
- $(cc32) -c -tWC stub16.c
- $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \
- stub16.obj,$@,,import32 cw32,,
-
-$(TCLREGDLL): extdll.cfg $(TMPDIR)\tclWinReg.obj
- $(link32) $(DLL_LFLAGS) @&&|
- $(TMPDIR)\tclWinReg.obj
-$@
--x
-$(DLL_LIBS) $(TCLLIB)
-|,,
-
-#
-# Special test targets
-#
-
-$(CAT32): cat.c
- $(cc32) -c -Ox -tWC -ocat32.obj cat.c
- $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \
- cat32.obj,$@,,import32 cw32,,
-
-$(CAT16): cat.c
- $(cc16) -W- -ml -Ox -c -ocat16.obj cat.c
- $(link16) -Tde -c -L$(TOOLS)\lib $(TOOLS)\lib\c0l.obj cat16.obj,cat16.exe,,cl.lib,,
-
-#######################################################################
-# Implicit Targets
-#######################################################################
-
-
-{$(WINDIR)}.c{$(TMPDIR)}.obj:
- @$(cc32) $(TCL_CFLAGS) {$< }
-
-{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
- @$(cc32) $(TCL_CFLAGS) {$< }
-
-{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
- @$(cc32) $(TCL_CFLAGS) {$< }
-
-{$(WINDIR)}.rc{$(TMPDIR)}.res:
- $(rc32) -i$(INCLUDES) -fo$@ @&&|
--d__WIN32__;$(DEFINES) $<
-|
-
-#
-# Special case object file targets
-#
-
-$(TMPDIR)\tclWinReg.obj : extdll.cfg $(ROOT)\win\tclWinReg.c
- $(cc32) +extdll.cfg -o$@ $(ROOT)\win\tclWinReg.c
-
-$(TMPDIR)\tclAppInit.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c
- $(cc32) $(CON_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c
-
-$(TMPDIR)\testMain.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c
- $(cc32) $(TEST_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c
-
-$(TMPDIR)\tclWin16.obj : $(ROOT)\win\tclWin16.c
- $(cc16) $(DLL16_CFLAGS) -o$@ $(ROOT)\win\tclWin16.c
-
-#
-# Configuration file targets - these files are implicitly used by the compiler
-#
-
-cfgdll.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -WM
- -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS)
-| cfgdll.cfg >NUL
-
-extdll.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -WD
- -D_RTLDLL;$(DEBUGDEFINES) -3 -d -w $(PROJECTCCFLAGS)
-| extdll.cfg >NUL
-
-cfgexe.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -W
- -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS)
-| cfgexe.cfg >NUL
-
-cfgtest.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -W
- -D$(DEFINES);TCL_TEST -3 -d -w $(PROJECTCCFLAGS)
-| cfgtest.cfg >NUL
-
-cfgcln:
- -@$(RM) *.cfg
-
-
-# The following rule automatically generates a tcl.def file containing
-# an export entry for every public symbol in the tcl.dll library.
-
-$(TMPDIR)\tcl.def: $(TCLOBJS) $(DUMPEXTS)
- $(DUMPEXTS) -o $(TMPDIR)\tcl.def $(TCLDLL) @&&|
- $(TCLOBJS)
-|
-
-
-# the following two rules are a hack to get around the fact that the
-# 16-bit compiler doesn't handle long file names :-(
-
-$(ROOT)\win\tclWinIn.h: $(ROOT)\win\tclWinInt.h
- $(CP) $(ROOT)\win\tclWinInt.h $(ROOT)\win\tclWinIn.h
-
-$(ROOT)\win\tclWin16.c: $(ROOT)\win\tclWinIn.h
-
-# remove all generated files
-
-clean:
- -@$(RM) *.exe
- -@$(RM) *.lib
- -@$(RM) *.dll
- -@$(RM) $(TMPDIR)\*.res
- -@$(RM) $(TMPDIR)\*.def
- -@$(RM) $(TMPDIR)\*.obj
- -@$(RM) $(TMPDIR)\*.cfg
- -@$(RM) $(ROOT)\win\tclWinIn.h
+#\r
+# Makefile for Borland C++ 5.5 (or C++ Builder 5), adapted from the makefile\r
+# for Visual C++ that came with tcl 8.3.3\r
+#\r
+# See the file "license.terms" for information on usage and redistribution\r
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.\r
+#\r
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.\r
+# Copyright (c) 1998-1999 by Scriptics Corporation.\r
+#\r
+# Have a look at the complete description on how to build and test Tcl with\r
+# the current Borland compilers at www.ratiosoft.com/tcl/borland.\r
+#\r
+# Usage:\r
+# - Adapt the paths below to match your compiler's location\r
+# - Make sure the compiler's bin directory is on your path\r
+# - Open a console\r
+# - To make a debug version enter\r
+# make -fmakefile.bc -DNODEBUG=0 xxx\r
+# where 'xxx' is the target you want (e.g. 'all', 'test', ...)\r
+# Please note: I omitted the 'd' suffix for debug versions because Tcl\r
+# will always call tclpip83.dll and not tclpip83d.dll, causing an error.\r
+# ^\r
+# Besides, the debug version goes into a separate directory, so there\r
+# should be no problem having DLLs and EXEs with the same name.\r
+# If you prefer your debug version having the 'd' suffix just uncomment\r
+# the line\r
+# #DBGX = d\r
+#\r
+# - To make a 'normal' version enter\r
+# make -fmakefile.bc xxx\r
+# where 'xxx' is the target you want (e.g. 'all', 'test', ...)\r
+#\r
+# DISCLAIMER:\r
+# This makefile has an experimental status - that is those targets which\r
+# have been modified do in fact compile and link with Borland's C++\r
+# Builder 5 and with the free Borland compiler (Borland C++ 5.5).\r
+# However the author assumes no responsiblity for any effect which the use of\r
+# this makefile or of the resulting programs might have on your system.\r
+#\r
+# Not yet modified:\r
+# - The 'plug-in-DLL' and the associated shell.\r
+# - The programs to create the windows help files.\r
+#\r
+# Suggestions and / or improvements are always welcome.\r
+#\r
+# May 2001, H. Giese (hgiese@ratiosoft.com)\r
+#\r
+\r
+# Does not depend on the presence of any environment variables in\r
+# order to compile tcl; all needed information is derived from\r
+# location of the compiler directories.\r
+\r
+#\r
+# Project directories\r
+#\r
+# ROOT = top of source tree\r
+#\r
+# TOOLS32 = location of Borland development tools.\r
+#\r
+# INSTALLDIR = where the install-targets should copy the binaries and\r
+# support files\r
+#\r
+\r
+ROOT = ..\r
+INSTALLDIR = c:\program files\tcl\r
+\r
+# If you have C++ Builder 5 or the free Borland C++ 5.5 compiler\r
+# adapt the following paths as appropriate for your system\r
+TOOLS32 = c:\dev\bcc55\r
+TOOLS32_rc = c:\dev\bcc55\r
+#TOOLS32 = c:\bc55\r
+#TOOLS32_rc = c:\bc55\r
+\r
+cc32 = "$(TOOLS32)\bin\bcc32.exe"\r
+link32 = "$(TOOLS32)\bin\ilink32.exe"\r
+lib32 = "$(TOOLS32)\bin\tlib.exe"\r
+rc32 = "$(TOOLS32_rc)\bin\brcc32.exe"\r
+include32 = -I"$(TOOLS32)\include"\r
+libpath32 = -L"$(TOOLS32)\lib"\r
+\r
+# Uncomment the following line to compile with thread support\r
+#THREADDEFINES = -DTCL_THREADS=1\r
+\r
+# Allow definition of NDEBUG via command line\r
+# Set NODEBUG to 0 to compile with symbols\r
+!if !defined(NODEBUG)\r
+NODEBUG = 1\r
+!endif\r
+\r
+# The following defines can be used to control the amount of debugging\r
+# code that is added to the compilation.\r
+#\r
+# -DTCL_MEM_DEBUG Enables the debugging memory allocator.\r
+# -DTCL_COMPILE_DEBUG Enables byte compilation logging.\r
+# -DTCL_COMPILE_STATS Enables byte compilation statistics gathering.\r
+# -DUSE_TCLALLOC=0 Disables the Tcl memory allocator in favor\r
+# of the native malloc implementation. This is\r
+# needed when using Purify.\r
+#\r
+#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS\r
+#DEBUGDEFINES = -DUSE_TCLALLOC=0\r
+\r
+######################################################################\r
+# Do not modify below this line\r
+######################################################################\r
+\r
+NAMEPREFIX = tcl\r
+STUBPREFIX = $(NAMEPREFIX)stub\r
+DOTVERSION = 8.4\r
+VERSION = 84\r
+\r
+DDEVERSION = 12\r
+DDEDOTVERSION = 1.2\r
+\r
+REGVERSION = 11\r
+REGDOTVERSION = 1.1\r
+\r
+BINROOT = ..\r
+!IF "$(NODEBUG)" == "1"\r
+TMPDIRNAME = Release\r
+DBGX =\r
+!ELSE\r
+TMPDIRNAME = Debug\r
+#DBGX = d\r
+DBGX =\r
+!ENDIF\r
+TMPDIR = $(BINROOT)\$(TMPDIRNAME)\r
+OUTDIRNAME = $(TMPDIRNAME)\r
+OUTDIR = $(TMPDIR)\r
+\r
+TCLLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)$(DBGX).lib\r
+TCLDLLNAME = $(NAMEPREFIX)$(VERSION)$(DBGX).dll\r
+TCLDLL = $(OUTDIR)\$(TCLDLLNAME)\r
+\r
+TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION)$(DBGX).lib\r
+TCLSTUBLIB = $(OUTDIR)\$(TCLSTUBLIBNAME)\r
+\r
+TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib\r
+TCLPLUGINDLLNAME = $(NAMEPREFIX)$(VERSION)p$(DBGX).dll\r
+TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME)\r
+TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe\r
+TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe\r
+TCLPIPEDLLNAME = $(NAMEPREFIX)pip$(VERSION)$(DBGX).dll\r
+TCLPIPEDLL = $(OUTDIR)\$(TCLPIPEDLLNAME)\r
+TCLREGDLLNAME = $(NAMEPREFIX)reg$(REGVERSION)$(DBGX).dll\r
+TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME)\r
+TCLDDEDLLNAME = $(NAMEPREFIX)dde$(DDEVERSION)$(DBGX).dll\r
+TCLDDEDLL = $(OUTDIR)\$(TCLDDEDLLNAME)\r
+TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe\r
+CAT32 = $(TMPDIR)\cat32.exe\r
+RMDIR = .\rmd.bat\r
+MKDIR = .\mkd.bat\r
+RM = del\r
+\r
+LIB_INSTALL_DIR = $(INSTALLDIR)\lib\r
+BIN_INSTALL_DIR = $(INSTALLDIR)\bin\r
+SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\tcl$(DOTVERSION)\r
+INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include\r
+\r
+TCLSHOBJS = \\r
+ $(TMPDIR)\tclAppInit.obj\r
+\r
+TCLTESTOBJS = \\r
+ $(TMPDIR)\tclTest.obj \\r
+ $(TMPDIR)\tclTestObj.obj \\r
+ $(TMPDIR)\tclTestProcBodyObj.obj \\r
+ $(TMPDIR)\tclThreadTest.obj \\r
+ $(TMPDIR)\tclWinTest.obj \\r
+ $(TMPDIR)\testMain.obj\r
+\r
+TCLOBJS = \\r
+ $(TMPDIR)\regcomp.obj \\r
+ $(TMPDIR)\regexec.obj \\r
+ $(TMPDIR)\regfree.obj \\r
+ $(TMPDIR)\regerror.obj \\r
+ $(TMPDIR)\strftime.obj \\r
+ $(TMPDIR)\strtoll.obj \\r
+ $(TMPDIR)\strtoull.obj \\r
+ $(TMPDIR)\tclAlloc.obj \\r
+ $(TMPDIR)\tclAsync.obj \\r
+ $(TMPDIR)\tclBasic.obj \\r
+ $(TMPDIR)\tclBinary.obj \\r
+ $(TMPDIR)\tclCkalloc.obj \\r
+ $(TMPDIR)\tclClock.obj \\r
+ $(TMPDIR)\tclCmdAH.obj \\r
+ $(TMPDIR)\tclCmdIL.obj \\r
+ $(TMPDIR)\tclCmdMZ.obj \\r
+ $(TMPDIR)\tclCompCmds.obj \\r
+ $(TMPDIR)\tclCompExpr.obj \\r
+ $(TMPDIR)\tclCompile.obj \\r
+ $(TMPDIR)\tclDate.obj \\r
+ $(TMPDIR)\tclEncoding.obj \\r
+ $(TMPDIR)\tclEnv.obj \\r
+ $(TMPDIR)\tclEvent.obj \\r
+ $(TMPDIR)\tclExecute.obj \\r
+ $(TMPDIR)\tclFCmd.obj \\r
+ $(TMPDIR)\tclFileName.obj \\r
+ $(TMPDIR)\tclGet.obj \\r
+ $(TMPDIR)\tclHash.obj \\r
+ $(TMPDIR)\tclHistory.obj \\r
+ $(TMPDIR)\tclIndexObj.obj \\r
+ $(TMPDIR)\tclInterp.obj \\r
+ $(TMPDIR)\tclIO.obj \\r
+ $(TMPDIR)\tclIOCmd.obj \\r
+ $(TMPDIR)\tclIOGT.obj \\r
+ $(TMPDIR)\tclIOSock.obj \\r
+ $(TMPDIR)\tclIOUtil.obj \\r
+ $(TMPDIR)\tclLink.obj \\r
+ $(TMPDIR)\tclLiteral.obj \\r
+ $(TMPDIR)\tclListObj.obj \\r
+ $(TMPDIR)\tclLoad.obj \\r
+ $(TMPDIR)\tclMain.obj \\r
+ $(TMPDIR)\tclNamesp.obj \\r
+ $(TMPDIR)\tclNotify.obj \\r
+ $(TMPDIR)\tclObj.obj \\r
+ $(TMPDIR)\tclPanic.obj \\r
+ $(TMPDIR)\tclParse.obj \\r
+ $(TMPDIR)\tclParseExpr.obj \\r
+ $(TMPDIR)\tclPipe.obj \\r
+ $(TMPDIR)\tclPkg.obj \\r
+ $(TMPDIR)\tclPosixStr.obj \\r
+ $(TMPDIR)\tclPreserve.obj \\r
+ $(TMPDIR)\tclProc.obj \\r
+ $(TMPDIR)\tclRegexp.obj \\r
+ $(TMPDIR)\tclResolve.obj \\r
+ $(TMPDIR)\tclResult.obj \\r
+ $(TMPDIR)\tclScan.obj \\r
+ $(TMPDIR)\tclStringObj.obj \\r
+ $(TMPDIR)\tclStubInit.obj \\r
+ $(TMPDIR)\tclStubLib.obj \\r
+ $(TMPDIR)\tclThread.obj \\r
+ $(TMPDIR)\tclThreadJoin.obj \\r
+ $(TMPDIR)\tclTimer.obj \\r
+ $(TMPDIR)\tclUtf.obj \\r
+ $(TMPDIR)\tclUtil.obj \\r
+ $(TMPDIR)\tclVar.obj \\r
+ $(TMPDIR)\tclWin32Dll.obj \\r
+ $(TMPDIR)\tclWinChan.obj \\r
+ $(TMPDIR)\tclWinConsole.obj \\r
+ $(TMPDIR)\tclWinSerial.obj \\r
+ $(TMPDIR)\tclWinError.obj \\r
+ $(TMPDIR)\tclWinFCmd.obj \\r
+ $(TMPDIR)\tclWinFile.obj \\r
+ $(TMPDIR)\tclWinInit.obj \\r
+ $(TMPDIR)\tclWinLoad.obj \\r
+ $(TMPDIR)\tclWinMtherr.obj \\r
+ $(TMPDIR)\tclWinNotify.obj \\r
+ $(TMPDIR)\tclWinPipe.obj \\r
+ $(TMPDIR)\tclWinSock.obj \\r
+ $(TMPDIR)\tclWinThrd.obj \\r
+ $(TMPDIR)\tclWinTime.obj\r
+\r
+TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj\r
+\r
+WINDIR = $(ROOT)\win\r
+GENERICDIR = $(ROOT)\generic\r
+\r
+TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"\r
+TCL_DEFINES = $(DEBUGDEFINES) $(THREADDEFINES)\r
+\r
+######################################################################\r
+# Compiler flags\r
+######################################################################\r
+\r
+!IF "$(NODEBUG)" == "1"\r
+# these macros cause maximum optimization and no symbols\r
+cdebug = -v- -vi- -O2 -D_DEBUG\r
+!ELSE\r
+# these macros enable debugging\r
+cdebug = -k -Od -r- -v -vi- -y\r
+!ENDIF\r
+\r
+SYSDEFINES = _MT;NO_STRICT;_NO_VCL\r
+\r
+# declarations common to all compiler options\r
+cbase = -c -q -3 -a4 -g0 -tWM -Ve -Vx -X-\r
+WARNINGS = -w-rch -w-pch -w-par -w-dup -w-pro -w-dpu\r
+\r
+ccons = -tWC\r
+\r
+INCLUDEPATH = $(include32) $(TCL_INCLUDES)\r
+\r
+CFLAGS = $(cdebug) $(cbase) $(INCLUDEPATH) $(WARNINGS) -D$(SYSDEFINES)\r
+TCL_CFLAGS = $(CFLAGS) $(TCL_DEFINES)\r
+CONS_CFLAGS = $(CFLAGS) $(TCL_DEFINES) $(ccons)\r
+\r
+######################################################################\r
+# Linker flags\r
+######################################################################\r
+\r
+!IF "$(NODEBUG)" == "1"\r
+ldebug =\r
+!ELSE\r
+ldebug = -v\r
+!ENDIF\r
+\r
+# declarations common to all linker options\r
+LNFLAGS = -D"" -Gn -I$(TMPDIR) -x $(ldebug) $(libpath32)\r
+# -Gi: create lib file (is -Gl in doc)\r
+# -aa: Windows app, -ap: Windows console app\r
+LNFLAGS_DLL = -ap -Gi -Tpd\r
+LNFLAGS_CONS = -ap -Tpe\r
+\r
+LNLIBS = import32 cw32mt\r
+\r
+\r
+######################################################################\r
+# Project specific targets\r
+######################################################################\r
+\r
+release: setup $(TCLSH) dlls\r
+dlls: setup $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL)\r
+all: setup $(TCLSH) dlls $(CAT32)\r
+tcltest: setup $(TCLTEST) dlls $(CAT32)\r
+plugin: setup $(TCLPLUGINDLL) $(TCLSHP)\r
+install: install-binaries install-libraries\r
+\r
+test: setup $(TCLTEST) dlls $(CAT32)\r
+ set TCL_LIBRARY=$(ROOT)/library\r
+ $(TCLTEST) $(ROOT)/tests/all.tcl\r
+\r
+setup:\r
+ @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) &\\r
+ echo *** Created directory '$(OUT_DIR)'\r
+ @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) &\\r
+ echo *** Created directory '$(TMP_DIR)'\r
+\r
+\r
+$(TCLLIB): $(TCLDLL)\r
+\r
+$(TCLDLL): $(TCLOBJS) $(TMPDIR)\$(NAMEPREFIX).res\r
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 @&&!\r
+ $(TCLOBJS), $@, -x, $(LNLIBS),, $(TMPDIR)\$(NAMEPREFIX).res\r
+!\r
+\r
+$(TCLSTUBLIB): $(TCLSTUBOBJS)\r
+ $(lib32) /u $@ $(TCLSTUBOBJS)\r
+\r
+$(TCLPLUGINLIB): $(TCLPLUGINDLL)\r
+\r
+$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\tcl.res\r
+ $(link32) $(ldebug) $(dlllflags) \\r
+ -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @&&!\r
+$(TCLOBJS)\r
+!\r
+\r
+$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res\r
+ $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&!\r
+ $(TCLSHOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res\r
+!\r
+\r
+$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res\r
+ $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \\r
+ -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)\r
+\r
+$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res\r
+ $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&!\r
+ $(TCLTESTOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res\r
+!\r
+\r
+$(TCLPIPEDLL): $(WINDIR)\stub16.c\r
+ $(cc32) $(CFLAGS) -o$(TMPDIR)\stub16.obj $(WINDIR)\stub16.c\r
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 \\r
+ $(TMPDIR)\stub16.obj, $@, -x, $(LNLIBS),, $(TMPDIR)\$(NAMEPREFIX).res\r
+\r
+$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB)\r
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 \\r
+ $(TMPDIR)\tclWinDde.obj, $@, -x, $(LNLIBS) $(TCLSTUBLIB),, \\r
+ $(TMPDIR)\$(NAMEPREFIX).res\r
+\r
+$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj $(TCLSTUBLIB)\r
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 \\r
+ $(TMPDIR)\tclWinReg.obj, $@, -x, $(LNLIBS) $(TCLSTUBLIB),, \\r
+ $(TMPDIR)\$(NAMEPREFIX).res\r
+\r
+$(CAT32): $(WINDIR)\cat.c\r
+ $(cc32) $(CONS_CFLAGS) -o$(TMPDIR)\cat.obj $?\r
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 \\r
+ $(TMPDIR)\cat.obj, $@, -x, $(LNLIBS),,\r
+\r
+install-binaries: $(TCLSH)\r
+ $(MKDIR) "$(BIN_INSTALL_DIR)"\r
+ $(MKDIR) "$(LIB_INSTALL_DIR)"\r
+ @echo installing $(TCLDLLNAME)\r
+ @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)"\r
+ @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)"\r
+ @echo installing "$(TCLSH)"\r
+ @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)"\r
+ @echo installing $(TCLPIPEDLLNAME)\r
+ @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)"\r
+ @echo installing $(TCLSTUBLIBNAME)\r
+ @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)"\r
+\r
+install-libraries:\r
+ -@$(MKDIR) "$(LIB_INSTALL_DIR)"\r
+ -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)"\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"\r
+ @echo installing http1.0\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"\r
+ -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"\r
+ -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"\r
+ @echo installing http2.4\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.4"\r
+ -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.4"\r
+ -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.4"\r
+ @echo installing opt0.4\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"\r
+ -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"\r
+ -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"\r
+ @echo installing msgcat1.3\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.3"\r
+ -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.3"\r
+ -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.3"\r
+ @echo installing tcltest2.2\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.2"\r
+ -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.2"\r
+ -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.2"\r
+ @echo installing $(TCLDDEDLLNAME)\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.1"\r
+ -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.1"\r
+ -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.1"\r
+ @echo installing $(TCLREGDLLNAME)\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.1"\r
+ -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.1"\r
+ -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.1"\r
+ @echo installing encoding files\r
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"\r
+ -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"\r
+ @echo installing library files\r
+ -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)"\r
+ -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)"\r
+ -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+ -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)"\r
+\r
+#\r
+# Regenerate the stubs files.\r
+#\r
+\r
+genstubs:\r
+ tclsh$(VERSION) $(ROOT)\tools\genStubs.tcl $(GENERICDIR) \\r
+ $(GENERICDIR)\tcl.decls $(GENERICDIR)\tclInt.decls\r
+\r
+#\r
+# Regenerate the windows help files.\r
+#\r
+\r
+TCLTOOLS = $(ROOT)/tools\r
+MAN2TCL = $(TCLTOOLS)/man2tcl\r
+TCLRTF = $(TCLTOOLS)/tcl.rtf\r
+TCLHPJ = $(TCLTOOLS)/tcl.hpj\r
+MAN2HELP = $(TCLTOOLS)/man2help.tcl\r
+HCRTF = $(TOOLS32)/bin/hcrtf.exe\r
+\r
+winhelp: $(TCLRTF)\r
+ cd $(TCLTOOLS)\r
+ start /wait $(HCRTF) -xn $(TCLHPJ)\r
+\r
+$(MAN2TCL).exe: $(MAN2TCL).obj\r
+ cd $(TCLTOOLS)\r
+ $(cc32) /nologo /G4 /ML /O2 $(MAN2TCL).c\r
+\r
+$(TCLRTF): $(MAN2TCL).exe $(TCLSH)\r
+ cd $(TCLTOOLS)\r
+ ..\win\$(TCLSH) $(MAN2HELP) $(NAMEPREFIX) $(VERSION) $(ROOT)/doc ../../tk$(DOTVERSION)/doc\r
+\r
+#\r
+# Special case object file targets\r
+#\r
+$(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c\r
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?\r
+\r
+$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c\r
+ $(cc32) $(TCL_CFLAGS) -DTCL_TEST -o$(TMPDIR)\testMain.obj $?\r
+\r
+$(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c\r
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?\r
+\r
+$(TMPDIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c\r
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?\r
+\r
+$(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c\r
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?\r
+\r
+$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c\r
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?\r
+\r
+# The following objects should be built using the stub interfaces\r
+\r
+# tclWinReg: Produces errors in ANSI mode\r
+$(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c\r
+ $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -o$(TMPDIR)\$@ $?\r
+\r
+# tclWinDde: Produces errors in ANSI mode\r
+$(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c\r
+ $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -o$(TMPDIR)\$@ $?\r
+\r
+\r
+# The following objects are part of the stub library and should not\r
+# be built as DLL objects but none of the symbols should be exported\r
+\r
+$(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c\r
+ $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?\r
+\r
+\r
+# Dedependency rules\r
+\r
+$(GENERICDIR)\regcomp.c: \\r
+ $(GENERICDIR)\regguts.h \\r
+ $(GENERICDIR)\regc_lex.c \\r
+ $(GENERICDIR)\regc_color.c \\r
+ $(GENERICDIR)\regc_nfa.c \\r
+ $(GENERICDIR)\regc_cvec.c \\r
+ $(GENERICDIR)\regc_locale.c\r
+\r
+$(GENERICDIR)\regcustom.h: \\r
+ $(GENERICDIR)\tclInt.h \\r
+ $(GENERICDIR)\tclPort.h \\r
+ $(GENERICDIR)\regex.h\r
+\r
+$(GENERICDIR)\regexec.c: \\r
+ $(GENERICDIR)\rege_dfa.c \\r
+ $(GENERICDIR)\regguts.h\r
+\r
+$(GENERICDIR)\regerror.c: $(GENERICDIR)\regguts.h\r
+$(GENERICDIR)\regfree.c: $(GENERICDIR)\regguts.h\r
+$(GENERICDIR)\regfronts.c: $(GENERICDIR)\regguts.h\r
+$(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h\r
+\r
+#\r
+# Implicit rules\r
+#\r
+\r
+{$(WINDIR)}.c{$(TMPDIR)}.obj:\r
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<\r
+\r
+{$(GENERICDIR)}.c{$(TMPDIR)}.obj:\r
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<\r
+\r
+{$(ROOT)\compat}.c{$(TMPDIR)}.obj:\r
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<\r
+\r
+{$(WINDIR)}.rc{$(TMPDIR)}.res:\r
+ $(rc32) $(INCLUDEPATH) -D$(USERDEFINES);$(SYSDEFINES) -fo$@ $<\r
+\r
+clean:\r
+ -@$(RM) $(OUTDIR)\*.exp\r
+ -@$(RM) $(OUTDIR)\*.lib\r
+ -@$(RM) $(OUTDIR)\*.dll\r
+ -@$(RM) $(OUTDIR)\*.exe\r
+ -@$(RM) $(OUTDIR)\*.pdb\r
+ -@$(RM) $(TMPDIR)\*.pch\r
+ -@$(RM) $(TMPDIR)\*.obj\r
+ -@$(RM) $(TMPDIR)\*.res\r
+ -@$(RM) $(TMPDIR)\*.exe\r
+ -@$(RMDIR) $(OUTDIR)\r
+ -@$(RMDIR) $(TMPDIR)\r
+\r
-# Visual C++ 2.x and 4.0 makefile
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-#
-# RCS: @(#) $Id$
-
-# Does not depend on the presence of any environment variables in
-# order to compile tcl; all needed information is derived from
-# location of the compiler directories.
-
-#
-# Project directories
-#
-# ROOT = top of source tree
-#
-# TOOLS32 = location of VC++ 32-bit development tools. Note that the
-# VC++ 2.0 header files are broken, so you need to use the
-# ones that come with the developer network CD's, or later
-# versions of VC++.
-#
-# INSTALLDIR = where the install- targets should copy the binaries and
-# support files
-#
-
-# Set this to the appropriate value of /MACHINE: for your platform
-MACHINE = IX86
-
-ROOT = ..
-INSTALLDIR = c:\Progra~1\Tcl
-
-!IF "$(MACHINE)" == "IA64"
-TOOLS32 = c:\ia64sdk17
-TOOLS32_rc = c:\ia64sdk17
-!ELSE
-TOOLS32 = c:\Progra~1\devstudio\vc
-TOOLS32_rc = c:\Progra~1\devstudio\sharedide
-!ENDIF
-
-# Uncomment the following line to compile with thread support
-#THREADDEFINES = -DTCL_THREADS=1
-
-# Set NODEBUG to 0 to compile with symbols
-NODEBUG = 1
-
-# The following defines can be used to control the amount of debugging
-# code that is added to the compilation.
-#
-# -DTCL_MEM_DEBUG Enables the debugging memory allocator.
-# -DTCL_COMPILE_DEBUG Enables byte compilation logging.
-# -DTCL_COMPILE_STATS Enables byte compilation statistics gathering.
-# -DUSE_TCLALLOC=0 Disables the Tcl memory allocator in favor
-# of the native malloc implementation. This is
-# needed when using Purify.
-#
-#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
-#DEBUGDEFINES = -DUSE_TCLALLOC=0
-
-######################################################################
-# Do not modify below this line
-######################################################################
-
-NAMEPREFIX = tcl
-STUBPREFIX = $(NAMEPREFIX)stub
-DOTVERSION = 8.3
-VERSION = 83
-
-BINROOT = .
-!IF "$(NODEBUG)" == "1"
-TMPDIRNAME = Release
-DBGX =
-!ELSE
-TMPDIRNAME = Debug
-DBGX = d
-!ENDIF
-TMPDIR = $(BINROOT)\$(TMPDIRNAME)
-OUTDIRNAME = $(TMPDIRNAME)
-OUTDIR = $(TMPDIR)
-
-TCLLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)$(DBGX).lib
-TCLDLLNAME = $(NAMEPREFIX)$(VERSION)$(DBGX).dll
-TCLDLL = $(OUTDIR)\$(TCLDLLNAME)
-
-TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION)$(DBGX).lib
-TCLSTUBLIB = $(OUTDIR)\$(TCLSTUBLIBNAME)
-
-TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib
-TCLPLUGINDLLNAME= $(NAMEPREFIX)$(VERSION)p$(DBGX).dll
-TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME)
-TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe
-TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe
-TCLPIPEDLLNAME = $(NAMEPREFIX)pip$(VERSION)$(DBGX).dll
-TCLPIPEDLL = $(OUTDIR)\$(TCLPIPEDLLNAME)
-TCLREGDLLNAME = $(NAMEPREFIX)reg$(VERSION)$(DBGX).dll
-TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME)
-TCLDDEDLLNAME = $(NAMEPREFIX)dde$(VERSION)$(DBGX).dll
-TCLDDEDLL = $(OUTDIR)\$(TCLDDEDLLNAME)
-TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe
-CAT32 = $(TMPDIR)\cat32.exe
-RMDIR = .\rmd.bat
-MKDIR = .\mkd.bat
-RM = del
-
-LIB_INSTALL_DIR = $(INSTALLDIR)\lib
-BIN_INSTALL_DIR = $(INSTALLDIR)\bin
-SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\tcl$(DOTVERSION)
-INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include
-
-TCLSHOBJS = \
- $(TMPDIR)\tclAppInit.obj
-
-TCLTESTOBJS = \
- $(TMPDIR)\tclTest.obj \
- $(TMPDIR)\tclTestObj.obj \
- $(TMPDIR)\tclTestProcBodyObj.obj \
- $(TMPDIR)\tclThreadTest.obj \
- $(TMPDIR)\tclWinTest.obj \
- $(TMPDIR)\testMain.obj
-
-TCLOBJS = \
- $(TMPDIR)\regcomp.obj \
- $(TMPDIR)\regexec.obj \
- $(TMPDIR)\regfree.obj \
- $(TMPDIR)\regerror.obj \
- $(TMPDIR)\strftime.obj \
- $(TMPDIR)\tclAlloc.obj \
- $(TMPDIR)\tclAsync.obj \
- $(TMPDIR)\tclBasic.obj \
- $(TMPDIR)\tclBinary.obj \
- $(TMPDIR)\tclCkalloc.obj \
- $(TMPDIR)\tclClock.obj \
- $(TMPDIR)\tclCmdAH.obj \
- $(TMPDIR)\tclCmdIL.obj \
- $(TMPDIR)\tclCmdMZ.obj \
- $(TMPDIR)\tclCompCmds.obj \
- $(TMPDIR)\tclCompExpr.obj \
- $(TMPDIR)\tclCompile.obj \
- $(TMPDIR)\tclDate.obj \
- $(TMPDIR)\tclEncoding.obj \
- $(TMPDIR)\tclEnv.obj \
- $(TMPDIR)\tclEvent.obj \
- $(TMPDIR)\tclExecute.obj \
- $(TMPDIR)\tclFCmd.obj \
- $(TMPDIR)\tclFileName.obj \
- $(TMPDIR)\tclGet.obj \
- $(TMPDIR)\tclHash.obj \
- $(TMPDIR)\tclHistory.obj \
- $(TMPDIR)\tclIndexObj.obj \
- $(TMPDIR)\tclInterp.obj \
- $(TMPDIR)\tclIO.obj \
- $(TMPDIR)\tclIOCmd.obj \
- $(TMPDIR)\tclIOGT.obj \
- $(TMPDIR)\tclIOSock.obj \
- $(TMPDIR)\tclIOUtil.obj \
- $(TMPDIR)\tclLink.obj \
- $(TMPDIR)\tclLiteral.obj \
- $(TMPDIR)\tclListObj.obj \
- $(TMPDIR)\tclLoad.obj \
- $(TMPDIR)\tclMain.obj \
- $(TMPDIR)\tclNamesp.obj \
- $(TMPDIR)\tclNotify.obj \
- $(TMPDIR)\tclObj.obj \
- $(TMPDIR)\tclPanic.obj \
- $(TMPDIR)\tclParse.obj \
- $(TMPDIR)\tclParseExpr.obj \
- $(TMPDIR)\tclPipe.obj \
- $(TMPDIR)\tclPkg.obj \
- $(TMPDIR)\tclPosixStr.obj \
- $(TMPDIR)\tclPreserve.obj \
- $(TMPDIR)\tclProc.obj \
- $(TMPDIR)\tclRegexp.obj \
- $(TMPDIR)\tclResolve.obj \
- $(TMPDIR)\tclResult.obj \
- $(TMPDIR)\tclScan.obj \
- $(TMPDIR)\tclStringObj.obj \
- $(TMPDIR)\tclStubInit.obj \
- $(TMPDIR)\tclStubLib.obj \
- $(TMPDIR)\tclThread.obj \
- $(TMPDIR)\tclTimer.obj \
- $(TMPDIR)\tclUtf.obj \
- $(TMPDIR)\tclUtil.obj \
- $(TMPDIR)\tclVar.obj \
- $(TMPDIR)\tclWin32Dll.obj \
- $(TMPDIR)\tclWinChan.obj \
- $(TMPDIR)\tclWinConsole.obj \
- $(TMPDIR)\tclWinSerial.obj \
- $(TMPDIR)\tclWinError.obj \
- $(TMPDIR)\tclWinFCmd.obj \
- $(TMPDIR)\tclWinFile.obj \
- $(TMPDIR)\tclWinInit.obj \
- $(TMPDIR)\tclWinLoad.obj \
- $(TMPDIR)\tclWinMtherr.obj \
- $(TMPDIR)\tclWinNotify.obj \
- $(TMPDIR)\tclWinPipe.obj \
- $(TMPDIR)\tclWinSock.obj \
- $(TMPDIR)\tclWinThrd.obj \
- $(TMPDIR)\tclWinTime.obj
-
-TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj \
-
-cc32 = "$(TOOLS32)\bin\cl.exe"
-link32 = "$(TOOLS32)\bin\link.exe"
-rc32 = "$(TOOLS32_rc)\bin\rc.exe"
-include32 = -I"$(TOOLS32)\include"
-libpath32 = /LIBPATH:"$(TOOLS32)\lib"
-lib32 = "$(TOOLS32)\bin\lib.exe"
-
-WINDIR = $(ROOT)\win
-GENERICDIR = $(ROOT)\generic
-
-TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
-TCL_DEFINES = $(DEBUGDEFINES) $(THREADDEFINES)
-
-######################################################################
-# Compile flags
-######################################################################
-
-!IF "$(NODEBUG)" == "1"
-# This cranks the optimization level to maximize speed
-cdebug = -O2 -Gs -GD
-!ELSE
-!IF "$(MACHINE)" == "IA64"
-cdebug = -Od -Zi
-!ELSE
-cdebug = -Z7 -Od -WX
-!ENDIF
-!ENDIF
-
-# declarations common to all compiler options
-cflags = -c -W3 -nologo -Fp$(TMPDIR)\ -YX
-cvarsdll = -MD$(DBGX)
-
-TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) \
- $(TCL_INCLUDES) $(TCL_DEFINES)
-CON_CFLAGS = $(cdebug) $(cflags) $(include32) -DCONSOLE
-
-######################################################################
-# Link flags
-######################################################################
-
-!IF "$(NODEBUG)" == "1"
-ldebug = /RELEASE
-!ELSE
-ldebug = -debug:full -debugtype:cv
-!ENDIF
-
-# declarations common to all linker options
-lflags = /NODEFAULTLIB /NOLOGO /MACHINE:$(MACHINE) $(libpath32)
-
-# declarations for use on Intel i386, i486, and Pentium systems
-!IF "$(MACHINE)" == "IX86"
-DLLENTRY = @12
-dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll
-!ELSE
-!IF "$(MACHINE)" == "IA64"
-DLLENTRY = @12
-dlllflags = $(lflags) -dll
-!ELSE
-dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll
-!ENDIF
-!ENDIF
-
-conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup
-guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup
-
-!IF "$(MACHINE)" == "PPC"
-libc = libc$(DBGX).lib
-libcdll = crtdll$(DBGX).lib
-!ELSE
-libc = libc$(DBGX).lib oldnames.lib
-libcdll = msvcrt$(DBGX).lib oldnames.lib
-!ENDIF
-
-baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib
-winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib
-
-guilibs = $(libc) $(winlibs)
-conlibs = $(libc) $(baselibs)
-guilibsdll = $(libcdll) $(winlibs)
-conlibsdll = $(libcdll) $(baselibs)
-
-######################################################################
-# Project specific targets
-######################################################################
-
-release: setup $(TCLSH) dlls
-dlls: setup $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL)
-all: setup $(TCLSH) dlls $(CAT32)
-tcltest: setup $(TCLTEST) dlls $(CAT32)
-plugin: setup $(TCLPLUGINDLL) $(TCLSHP)
-install: install-binaries install-libraries
-test: setup $(TCLTEST) dlls $(CAT32)
- set TCL_LIBRARY=$(ROOT)/library
- $(TCLTEST) $(ROOT)/tests/all.tcl
-
-setup:
- @$(MKDIR) $(TMPDIR)
- @$(MKDIR) $(OUTDIR)
-
-$(TCLLIB): $(TCLDLL)
-
-$(TCLDLL): $(TCLOBJS) $(TMPDIR)\tcl.res
- $(link32) $(ldebug) $(dlllflags) \
- -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<<
-$(TCLOBJS)
-<<
-
-$(TCLSTUBLIB): $(TCLSTUBOBJS)
- $(lib32) /out:$@ $(TCLSTUBOBJS)
-
-$(TCLPLUGINLIB): $(TCLPLUGINDLL)
-
-$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\tcl.res
- $(link32) $(ldebug) $(dlllflags) \
- -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<<
-$(TCLOBJS)
-<<
-
-$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS)
-
-$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res
- $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)
-
-$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS)
-
-$(TCLPIPEDLL): $(WINDIR)\stub16.c
- $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c
- $(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs)
-
-$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB)
- $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinDde.obj \
- $(conlibsdll) $(TCLSTUBLIB)
-
-$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj $(TCLSTUBLIB)
- $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \
- $(conlibsdll) $(TCLSTUBLIB)
-
-$(CAT32): $(WINDIR)\cat.c
- $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $?
- $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs)
-
-install-binaries: $(TCLSH)
- $(MKDIR) "$(BIN_INSTALL_DIR)"
- $(MKDIR) "$(LIB_INSTALL_DIR)"
- @echo installing $(TCLDLLNAME)
- @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)"
- @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)"
- @echo installing "$(TCLSH)"
- @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)"
- @echo installing $(TCLPIPEDLLNAME)
- @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)"
- @echo installing $(TCLSTUBLIBNAME)
- @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)"
-
-install-libraries:
- -@$(MKDIR) "$(LIB_INSTALL_DIR)"
- -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)"
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
- @echo installing http1.0
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
- -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
- -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
- @echo installing http2.3
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.3"
- -@copy "$(ROOT)\library\http2.3\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.3"
- -@copy "$(ROOT)\library\http2.3\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.3"
- @echo installing opt0.4
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
- -@copy "$(ROOT)\library\opt0.4\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
- -@copy "$(ROOT)\library\opt0.4\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
- @echo installing msgcat1.0
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
- -@copy "$(ROOT)\library\msgcat1.0\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
- -@copy "$(ROOT)\library\msgcat1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
- @echo installing $(TCLDDEDLLNAME)
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.1"
- -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.1"
- -@copy "$(ROOT)\library\dde1.1\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.1"
- @echo installing $(TCLREGDLLNAME)
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.0"
- -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.0"
- -@copy "$(ROOT)\library\reg1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.0"
- @echo installing encoding files
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"
- -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
- @echo installing library files
- -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)"
- -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)"
- -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)"
-
-#
-# Regenerate the stubs files.
-#
-
-genstubs:
- tclsh$(VERSION) $(ROOT)\tools\genStubs.tcl $(GENERICDIR) \
- $(GENERICDIR)\tcl.decls $(GENERICDIR)\tclInt.decls
-
-#
-# Regenerate the windows help files.
-#
-
-TCLTOOLS = $(ROOT)/tools
-MAN2TCL = $(TCLTOOLS)/man2tcl
-TCLRTF = $(TCLTOOLS)/tcl.rtf
-TCLHPJ = $(TCLTOOLS)/tcl.hpj
-MAN2HELP = $(TCLTOOLS)/man2help.tcl
-HCRTF = $(TOOLS32)/bin/hcrtf.exe
-
-winhelp: $(TCLRTF)
- cd $(TCLTOOLS)
- start /wait $(HCRTF) -xn $(TCLHPJ)
-
-$(MAN2TCL).exe: $(MAN2TCL).obj
- cd $(TCLTOOLS)
- $(cc32) /nologo /G4 /ML /O2 $(MAN2TCL).c
-
-$(TCLRTF): $(MAN2TCL).exe $(TCLSH)
- cd $(TCLTOOLS)
- ..\win\$(TCLSH) $(MAN2HELP) $(NAMEPREFIX) $(VERSION) $(ROOT)/doc ../../tk$(DOTVERSION)/doc
-
-#
-# Special case object file targets
-#
-
-$(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) $(EXTFLAGS) -Fo$(TMPDIR)\ $?
-
-$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$(TMPDIR)\testMain.obj $?
-
-$(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-$(TMPDIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-$(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-# The following objects should be built using the stub interfaces
-
-$(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c
- $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $?
-
-$(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c
- $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $?
-
-# The following objects are part of the stub library and should not
-# be built as DLL objects but none of the symbols should be exported
-
-$(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c
- $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -Fo$@ $?
-
-
-# Dedependency rules
-
-$(GENERICDIR)\regcomp.c: \
- $(GENERICDIR)\regguts.h \
- $(GENERICDIR)\regc_lex.c \
- $(GENERICDIR)\regc_color.c \
- $(GENERICDIR)\regc_nfa.c \
- $(GENERICDIR)\regc_cvec.c \
- $(GENERICDIR)\regc_locale.c
-$(GENERICDIR)\regcustom.h: \
- $(GENERICDIR)\tclInt.h \
- $(GENERICDIR)\tclPort.h \
- $(GENERICDIR)\regex.h
-$(GENERICDIR)\regexec.c: \
- $(GENERICDIR)\rege_dfa.c \
- $(GENERICDIR)\regguts.h
-$(GENERICDIR)\regerror.c: $(GENERICDIR)\regguts.h
-$(GENERICDIR)\regfree.c: $(GENERICDIR)\regguts.h
-$(GENERICDIR)\regfronts.c: $(GENERICDIR)\regguts.h
-$(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h
-
-#
-# Implicit rules
-#
-
-{$(WINDIR)}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
-
-{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
-
-{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
-
-{$(WINDIR)}.rc{$(TMPDIR)}.res:
- $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(WINDIR) -D__WIN32__ \
- $(TCL_DEFINES) $<
-
-clean:
- -@$(RM) $(OUTDIR)\*.exp
- -@$(RM) $(OUTDIR)\*.lib
- -@$(RM) $(OUTDIR)\*.dll
- -@$(RM) $(OUTDIR)\*.exe
- -@$(RM) $(OUTDIR)\*.pdb
- -@$(RM) $(TMPDIR)\*.pch
- -@$(RM) $(TMPDIR)\*.obj
- -@$(RM) $(TMPDIR)\*.res
- -@$(RM) $(TMPDIR)\*.exe
- -@$(RMDIR) $(OUTDIR)
- -@$(RMDIR) $(TMPDIR)
-
-
-
+#------------------------------------------------------------------------------\r
+# makefile.vc --\r
+#\r
+# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)\r
+#\r
+# See the file "license.terms" for information on usage and redistribution\r
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.\r
+# \r
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.\r
+# Copyright (c) 1998-2000 Ajuba Solutions.\r
+# Copyright (c) 2001 ActiveState Corporation.\r
+# Copyright (c) 2001-2002 David Gravereaux.\r
+#\r
+#------------------------------------------------------------------------------\r
+# RCS: @(#) $Id$\r
+#------------------------------------------------------------------------------\r
+\r
+!if "$(MSVCDIR)" == ""\r
+MSG = ^\r
+You'll need to run vcvars32.bat from Developer Studio, first, to setup^\r
+the environment. Jump to this line to read the new instructions.\r
+!error $(MSG)\r
+!endif\r
+\r
+#------------------------------------------------------------------------------\r
+# HOW TO USE this makefile:\r
+#\r
+# 1) It is now necessary to have MSVCDir set in the environment. This is used\r
+# as a check to see if vcvars32.bat had been run prior to running nmake or\r
+# during the installation of Microsoft Visual C++, MSVCDir had been set\r
+# globally and the PATH adjusted. Either way is valid.\r
+#\r
+# You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin\r
+# directory to setup the proper environment, if needed, for your current\r
+# setup. This is a needed bootstrap requirement and allows the swapping of\r
+# different environments to be easier.\r
+#\r
+# 2) To use the Platform SDK (not expressly needed), run setenv.bat after\r
+# vcvars32.bat according to the instructions for it. This can also turn on\r
+# the 64-bit compiler, if your SDK has it.\r
+#\r
+# 3) Targets are:\r
+# release -- Builds the core, the shell and the dlls. (default)\r
+# dlls -- Just builds the windows extensions and the 16-bit DOS\r
+# pipe/thunk helper app.\r
+# shell -- Just builds the shell and the core.\r
+# core -- Only builds the core [tclXX.(dll|lib)].\r
+# all -- Builds everything.\r
+# test -- Builds and runs the test suite.\r
+# tcltest -- Just builds the test shell.\r
+# install -- Installs the built binaries and libraries to $(INSTALLDIR)\r
+# as the root of the install tree.\r
+# tidy/clean/hose -- varying levels of cleaning.\r
+# genstubs -- Rebuilds the Stubs table and support files (dev only).\r
+# depend -- Generates an accurate set of source dependancies for this\r
+# makefile. Helpful to avoid problems when the sources are\r
+# refreshed and you rebuild, but can "overbuild" when common\r
+# headers like tclInt.h just get small changes.\r
+# winhelp -- Builds the windows .hlp file for Tcl from the troff man\r
+# files found in $(ROOT)\doc .\r
+#\r
+# 4) Macros usable on the commandline:\r
+# INSTALLDIR=<path>\r
+# Sets where to install Tcl from the built binaries.\r
+# C:\Progra~1\Tcl is assumed when not specified.\r
+#\r
+# OPTS=static,msvcrt,linkexten,threads,symbols,profile,loimpact,none\r
+# Sets special options for the core. The default is for none.\r
+# Any combination of the above may be used (comma separated).\r
+# 'none' will over-ride everything to nothing.\r
+#\r
+# static = Builds a static library of the core instead of a\r
+# dll. The shell will be static (and large), as well.\r
+# msvcrt = Effects the static option only to switch it from\r
+# using libcmt(d) as the C runtime [by default] to\r
+# msvcrt(d). This is useful for static embedding\r
+# support.\r
+# linkexten = Effects the static option only to switch\r
+# tclshXX.exe to have the dde and reg extension linked\r
+# inside it.\r
+# threads = Turns on full multithreading support.\r
+# symbols = Adds symbols for step debugging.\r
+# profile = Adds profiling hooks. Map file is assumed.\r
+# loimpact = Adds a flag for how NT treats the heap to keep memory\r
+# in use, low. This is said to impact alloc performance.\r
+#\r
+# STATS=memdbg,compdbg,none\r
+# Sets optional memory and bytecode compiler debugging code added\r
+# to the core. The default is for none. Any combination of the\r
+# above may be used (comma separated). 'none' will over-ride\r
+# everything to nothing.\r
+#\r
+# memdbg = Enables the debugging memory allocator.\r
+# compdbg = Enables byte compilation logging.\r
+#\r
+# MACHINE=(IX86|IA64|ALPHA)\r
+# Set the machine type used for the compiler, linker, and\r
+# resource compiler. This hook is needed to tell the tools\r
+# when alternate platforms are requested. IX86 is the default\r
+# when not specified.\r
+#\r
+# TMP_DIR=<path>\r
+# OUT_DIR=<path>\r
+# Hooks to allow the intermediate and output directories to be\r
+# changed. $(OUT_DIR) is assumed to be \r
+# $(BINROOT)\(Release|Debug) based on if symbols are requested.\r
+# $(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default.\r
+#\r
+# TESTPAT=<file>\r
+# Reads the tests requested to be run from this file.\r
+#\r
+# 5) Examples:\r
+#\r
+# Basic syntax of calling nmake looks like this:\r
+# nmake [-nologo] -f makefile.vc [target|macrodef [target|macrodef] [...]]\r
+#\r
+# Standard (no frills)\r
+# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat\r
+# Setting environment for using Microsoft Visual C++ tools.\r
+# c:\tcl_src\win\>nmake -f makefile.vc release\r
+# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl\r
+#\r
+# Building for Win64\r
+# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat\r
+# Setting environment for using Microsoft Visual C++ tools.\r
+# c:\tcl_src\win\>c:\progra~1\platfo~1\setenv.bat /pre64 /RETAIL\r
+# Targeting Windows pre64 RETAIL\r
+# c:\tcl_src\win\>nmake -f makefile.vc MACHINE=IA64\r
+#\r
+#------------------------------------------------------------------------------\r
+#==============================================================================\r
+###############################################################################\r
+\r
+\r
+# //==================================================================\\\r
+# >>[ -> Do not modify below this line. <- ]<<\r
+# >>[ Please, use the commandline macros to modify how Tcl is built. ]<<\r
+# >>[ If you need more features, send us a patch for more macros. ]<<\r
+# \\==================================================================//\r
+\r
+\r
+###############################################################################\r
+#==============================================================================\r
+#------------------------------------------------------------------------------\r
+\r
+!if !exist("makefile.vc")\r
+MSG = ^\r
+You must run this makefile only from the directory it is in.^\r
+Please `cd` to its location first.\r
+!error $(MSG)\r
+!endif\r
+\r
+PROJECT = tcl\r
+!include "rules.vc"\r
+\r
+STUBPREFIX = $(PROJECT)stub\r
+DOTVERSION = 8.4\r
+VERSION = $(DOTVERSION:.=)\r
+\r
+DDEDOTVERSION = 1.2\r
+DDEVERSION = $(DDEDOTVERSION:.=)\r
+\r
+REGDOTVERSION = 1.1\r
+REGVERSION = $(REGDOTVERSION:.=)\r
+\r
+BINROOT = .\r
+ROOT = ..\r
+\r
+TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib\r
+TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)\r
+TCLLIB = $(OUT_DIR)\$(TCLLIBNAME)\r
+\r
+TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib\r
+TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME)\r
+\r
+TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe\r
+TCLSH = $(OUT_DIR)\$(TCLSHNAME)\r
+TCLPIPEDLLNAME = $(PROJECT)pip$(VERSION).dll\r
+TCLPIPEDLL = $(OUT_DIR)\$(TCLPIPEDLLNAME)\r
+\r
+TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT)\r
+TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME)\r
+\r
+TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT)\r
+TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME)\r
+\r
+TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe\r
+CAT32 = $(OUT_DIR)\cat32.exe\r
+\r
+### Make sure we use backslash only.\r
+_INSTALLDIR = $(INSTALLDIR:/=\)\r
+LIB_INSTALL_DIR = $(_INSTALLDIR)\lib\r
+BIN_INSTALL_DIR = $(_INSTALLDIR)\bin\r
+DOC_INSTALL_DIR = $(_INSTALLDIR)\doc\r
+SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(DOTVERSION)\r
+INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include\r
+\r
+TCLSHOBJS = \\r
+ $(TMP_DIR)\tclAppInit.obj \\r
+!if $(TCL_LINKWITHEXTENSIONS)\r
+ $(TMP_DIR)\tclWinReg.obj \\r
+ $(TMP_DIR)\tclWinDde.obj \\r
+!endif\r
+ $(TMP_DIR)\tclsh.res\r
+\r
+TCLTESTOBJS = \\r
+ $(TMP_DIR)\tclTest.obj \\r
+ $(TMP_DIR)\tclTestObj.obj \\r
+ $(TMP_DIR)\tclTestProcBodyObj.obj \\r
+ $(TMP_DIR)\tclThreadTest.obj \\r
+ $(TMP_DIR)\tclWinTest.obj \\r
+!if $(TCL_LINKWITHEXTENSIONS)\r
+ $(TMP_DIR)\tclWinReg.obj \\r
+ $(TMP_DIR)\tclWinDde.obj \\r
+!endif\r
+ $(TMP_DIR)\testMain.obj\r
+\r
+TCLOBJS = \\r
+ $(TMP_DIR)\regcomp.obj \\r
+ $(TMP_DIR)\regerror.obj \\r
+ $(TMP_DIR)\regexec.obj \\r
+ $(TMP_DIR)\regfree.obj \\r
+ $(TMP_DIR)\strftime.obj \\r
+ $(TMP_DIR)\strtoll.obj \\r
+ $(TMP_DIR)\strtoull.obj \\r
+ $(TMP_DIR)\tclAlloc.obj \\r
+ $(TMP_DIR)\tclAsync.obj \\r
+ $(TMP_DIR)\tclBasic.obj \\r
+ $(TMP_DIR)\tclBinary.obj \\r
+ $(TMP_DIR)\tclCkalloc.obj \\r
+ $(TMP_DIR)\tclClock.obj \\r
+ $(TMP_DIR)\tclCmdAH.obj \\r
+ $(TMP_DIR)\tclCmdIL.obj \\r
+ $(TMP_DIR)\tclCmdMZ.obj \\r
+ $(TMP_DIR)\tclCompCmds.obj \\r
+ $(TMP_DIR)\tclCompExpr.obj \\r
+ $(TMP_DIR)\tclCompile.obj \\r
+ $(TMP_DIR)\tclDate.obj \\r
+ $(TMP_DIR)\tclEncoding.obj \\r
+ $(TMP_DIR)\tclEnv.obj \\r
+ $(TMP_DIR)\tclEvent.obj \\r
+ $(TMP_DIR)\tclExecute.obj \\r
+ $(TMP_DIR)\tclFCmd.obj \\r
+ $(TMP_DIR)\tclFileName.obj \\r
+ $(TMP_DIR)\tclGet.obj \\r
+ $(TMP_DIR)\tclHash.obj \\r
+ $(TMP_DIR)\tclHistory.obj \\r
+ $(TMP_DIR)\tclIndexObj.obj \\r
+ $(TMP_DIR)\tclInterp.obj \\r
+ $(TMP_DIR)\tclIO.obj \\r
+ $(TMP_DIR)\tclIOCmd.obj \\r
+ $(TMP_DIR)\tclIOGT.obj \\r
+ $(TMP_DIR)\tclIOSock.obj \\r
+ $(TMP_DIR)\tclIOUtil.obj \\r
+ $(TMP_DIR)\tclLink.obj \\r
+ $(TMP_DIR)\tclListObj.obj \\r
+ $(TMP_DIR)\tclLiteral.obj \\r
+ $(TMP_DIR)\tclLoad.obj \\r
+ $(TMP_DIR)\tclMain.obj \\r
+ $(TMP_DIR)\tclNamesp.obj \\r
+ $(TMP_DIR)\tclNotify.obj \\r
+ $(TMP_DIR)\tclObj.obj \\r
+ $(TMP_DIR)\tclPanic.obj \\r
+ $(TMP_DIR)\tclParse.obj \\r
+ $(TMP_DIR)\tclParseExpr.obj \\r
+ $(TMP_DIR)\tclPipe.obj \\r
+ $(TMP_DIR)\tclPkg.obj \\r
+ $(TMP_DIR)\tclPosixStr.obj \\r
+ $(TMP_DIR)\tclPreserve.obj \\r
+ $(TMP_DIR)\tclProc.obj \\r
+ $(TMP_DIR)\tclRegexp.obj \\r
+ $(TMP_DIR)\tclResolve.obj \\r
+ $(TMP_DIR)\tclResult.obj \\r
+ $(TMP_DIR)\tclScan.obj \\r
+ $(TMP_DIR)\tclStringObj.obj \\r
+ $(TMP_DIR)\tclStubInit.obj \\r
+ $(TMP_DIR)\tclStubLib.obj \\r
+ $(TMP_DIR)\tclThread.obj \\r
+ $(TMP_DIR)\tclThreadAlloc.obj \\r
+ $(TMP_DIR)\tclThreadJoin.obj \\r
+ $(TMP_DIR)\tclTimer.obj \\r
+ $(TMP_DIR)\tclUtf.obj \\r
+ $(TMP_DIR)\tclUtil.obj \\r
+ $(TMP_DIR)\tclVar.obj \\r
+ $(TMP_DIR)\tclWin32Dll.obj \\r
+ $(TMP_DIR)\tclWinChan.obj \\r
+ $(TMP_DIR)\tclWinConsole.obj \\r
+ $(TMP_DIR)\tclWinSerial.obj \\r
+ $(TMP_DIR)\tclWinError.obj \\r
+ $(TMP_DIR)\tclWinFCmd.obj \\r
+ $(TMP_DIR)\tclWinFile.obj \\r
+ $(TMP_DIR)\tclWinInit.obj \\r
+ $(TMP_DIR)\tclWinLoad.obj \\r
+ $(TMP_DIR)\tclWinMtherr.obj \\r
+ $(TMP_DIR)\tclWinNotify.obj \\r
+ $(TMP_DIR)\tclWinPipe.obj \\r
+ $(TMP_DIR)\tclWinSock.obj \\r
+ $(TMP_DIR)\tclWinThrd.obj \\r
+ $(TMP_DIR)\tclWinTime.obj \\r
+!if !$(STATIC_BUILD)\r
+ $(TMP_DIR)\tcl.res\r
+!endif\r
+\r
+TCLSTUBOBJS = $(TMP_DIR)\tclStubLib.obj\r
+\r
+### The following paths CANNOT have spaces in them.\r
+COMPATDIR = $(ROOT)\compat\r
+DOCDIR = $(ROOT)\doc\r
+GENERICDIR = $(ROOT)\generic\r
+TOOLSDIR = $(ROOT)\tools\r
+WINDIR = $(ROOT)\win\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Compile flags\r
+#---------------------------------------------------------------------\r
+\r
+!if !$(DEBUG)\r
+!if $(OPTIMIZING)\r
+### This cranks the optimization level to maximize speed\r
+cdebug = -O2 -Op -Gs\r
+!else\r
+cdebug =\r
+!endif\r
+!else if "$(MACHINE)" == "IA64"\r
+### Warnings are too many, can't support warnings into errors.\r
+cdebug = -Z7 -Od\r
+!else\r
+cdebug = -Z7 -WX -Od\r
+!endif\r
+\r
+### Declarations common to all compiler options\r
+cflags = -nologo -c -W3 -YX -Fp$(TMP_DIR)^\\r
+\r
+!if $(PENT_0F_ERRATA)\r
+cflags = $(cflags) -QI0f\r
+!endif\r
+\r
+!if $(ITAN_B_ERRATA)\r
+cflags = $(cflags) -QIA64_Bx\r
+!endif\r
+\r
+### Turn on the thread allocator, too.\r
+!if $(TCL_THREADS)\r
+cflags = $(cflags) -DUSE_THREAD_ALLOC=1\r
+!endif\r
+\r
+!if $(MSVCRT)\r
+crt = -MD$(DBGX)\r
+!else\r
+crt = -MT$(DBGX)\r
+!endif\r
+\r
+TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"\r
+BASE_CLFAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES)\r
+CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE\r
+TCL_CFLAGS = $(BASE_CLFAGS) $(OPTDEFINES)\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Link flags\r
+#---------------------------------------------------------------------\r
+\r
+!if $(DEBUG)\r
+ldebug = -debug:full -debugtype:cv\r
+!else\r
+ldebug = -release -opt:ref -opt:icf,3\r
+!endif\r
+\r
+### Declarations common to all linker options\r
+lflags = -nologo -machine:$(MACHINE) $(ldebug)\r
+\r
+!if $(PROFILE)\r
+lflags = $(lflags) -profile\r
+!endif\r
+\r
+!if $(ALIGN98_HACK) && !$(STATIC_BUILD)\r
+### Align sections for PE size savings.\r
+lflags = $(lflags) -opt:nowin98\r
+!else if !$(ALIGN98_HACK) && $(STATIC_BUILD)\r
+### Align sections for speed in loading by choosing the virtual page size.\r
+lflags = $(lflags) -align:4096\r
+!endif\r
+\r
+!if $(LOIMPACT)\r
+lflags = $(lflags) -ws:aggressive\r
+!endif\r
+\r
+dlllflags = $(lflags) -dll\r
+conlflags = $(lflags) -subsystem:console\r
+guilflags = $(lflags) -subsystem:windows\r
+\r
+baselibs = kernel32.lib advapi32.lib user32.lib\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# TclTest flags\r
+#---------------------------------------------------------------------\r
+\r
+!IF "$(TESTPAT)" != ""\r
+TESTFLAGS = -file $(TESTPAT)\r
+!ENDIF\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Project specific targets\r
+#---------------------------------------------------------------------\r
+\r
+release: setup $(TCLSH) $(TCLSTUBLIB) dlls\r
+core: setup $(TCLLIB) $(TCLSTUBLIB)\r
+shell: setup $(TCLSH)\r
+dlls: setup $(TCLPIPEDLL) $(TCLREGLIB) $(TCLDDELIB)\r
+all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) \r
+tcltest: setup $(TCLTEST) dlls $(CAT32)\r
+install: install-binaries install-libraries install-docs\r
+\r
+\r
+test: setup $(TCLTEST) dlls $(CAT32)\r
+ set TCL_LIBRARY=$(ROOT)/library\r
+!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"\r
+ $(TCLTEST) $(ROOT)/tests/all.tcl $(TESTFLAGS)\r
+!else\r
+ $(TCLTEST) $(ROOT)/tests/all.tcl $(TESTFLAGS) > tests.log\r
+ type tests.log | more\r
+!endif\r
+\r
+runtest: setup $(TCLTEST) dlls $(CAT32)\r
+ set TCL_LIBRARY=$(ROOT)/library\r
+ $(TCLTEST)\r
+\r
+setup:\r
+ @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR)\r
+ @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR)\r
+\r
+!if !$(STATIC_BUILD)\r
+$(TCLIMPLIB): $(TCLLIB)\r
+!endif\r
+\r
+$(TCLLIB): $(TCLOBJS)\r
+!if $(STATIC_BUILD)\r
+ $(lib32) -nologo -out:$@ @<<\r
+$**\r
+<<\r
+!else\r
+ $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \\r
+ $(baselibs) @<<\r
+$**\r
+<<\r
+ -@del $*.exp\r
+!endif\r
+\r
+$(TCLSTUBLIB): $(TCLSTUBOBJS)\r
+ $(lib32) -nologo -out:$@ $(TCLSTUBOBJS)\r
+\r
+$(TCLSH): $(TCLSHOBJS) $(TCLIMPLIB)\r
+ $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**\r
+\r
+$(TCLTEST): $(TCLTESTOBJS) $(TCLIMPLIB)\r
+ $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**\r
+\r
+$(TCLPIPEDLL): $(WINDIR)\stub16.c\r
+ $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $(WINDIR)\stub16.c\r
+ $(link32) $(conlflags) -out:$@ $(TMP_DIR)\stub16.obj $(baselibs)\r
+\r
+!if $(STATIC_BUILD)\r
+$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj\r
+ $(lib32) -nologo -out:$@ $(TMP_DIR)\tclWinDde.obj\r
+!else\r
+$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB)\r
+ $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \\r
+ $** $(baselibs)\r
+ -@del $*.exp\r
+ -@del $*.lib\r
+!endif\r
+\r
+!if $(STATIC_BUILD)\r
+$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj\r
+ $(lib32) -nologo -out:$@ $(TMP_DIR)\tclWinReg.obj\r
+!else\r
+$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB)\r
+ $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \\r
+ $** $(baselibs)\r
+ -@del $*.exp\r
+ -@del $*.lib\r
+!endif\r
+\r
+$(CAT32): $(WINDIR)\cat.c\r
+ $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $?\r
+ $(link32) $(conlflags) -out:$@ -stack:16384 $(TMP_DIR)\cat.obj \\r
+ $(baselibs)\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Regenerate the stubs files. [Development use only]\r
+#---------------------------------------------------------------------\r
+\r
+genstubs:\r
+!if !exist($(TCLSH))\r
+ @echo Build tclsh first!\r
+!else\r
+ $(TCLSH) $(TOOLSDIR:\=/)\genStubs.tcl $(GENERICDIR:\=/) \\r
+ $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls\r
+!endif\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Generate the makefile depedancies.\r
+#---------------------------------------------------------------------\r
+\r
+depend:\r
+!if !exist($(TCLSH))\r
+ @echo Build tclsh first!\r
+!else\r
+ $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \\r
+ -passthru:"-DBUILD_tcl $(TCL_INCLUDES:"="")" $(GENERICDIR) \\r
+ $(COMPATDIR) $(WINDIR) @<<\r
+$(TCLOBJS)\r
+<<\r
+!endif\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Build the windows help file.\r
+#---------------------------------------------------------------------\r
+\r
+TCLHLPBASE = $(PROJECT)$(VERSION)\r
+HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp\r
+HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt\r
+DOCTMP_DIR = $(OUT_DIR)\$(PROJECT)_docs\r
+HELPRTF = $(DOCTMP_DIR)\$(PROJECT).rtf\r
+MAN2HELP = $(DOCTMP_DIR)\man2help.tcl\r
+MAN2HELP2 = $(DOCTMP_DIR)\man2help2.tcl\r
+INDEX = $(DOCTMP_DIR)\index.tcl\r
+BMP = $(DOCTMP_DIR)\feather.bmp\r
+BMP_NOPATH = feather.bmp\r
+MAN2TCL = $(DOCTMP_DIR)\man2tcl.exe\r
+\r
+winhelp: docsetup $(HELPFILE)\r
+\r
+docsetup:\r
+ @if not exist $(DOCTMP_DIR)\nul mkdir $(DOCTMP_DIR)\r
+\r
+$(MAN2HELP) $(MAN2HELP2) $(INDEX) $(BMP): $(TOOLSDIR)\$$(@F)\r
+ copy $(TOOLSDIR)\$(@F) $(@D)\r
+\r
+$(HELPFILE): $(HELPRTF) $(BMP)\r
+ cd $(DOCTMP_DIR)\r
+ start /wait hcrtf.exe -x <<$(PROJECT).hpj\r
+[OPTIONS]\r
+COMPRESS=12 Hall Zeck\r
+LCID=0x409 0x0 0x0 ; English (United States)\r
+TITLE=Tcl/Tk Reference Manual\r
+BMROOT=.\r
+CNT=$(@B).cnt\r
+HLP=$(@B).hlp\r
+\r
+[FILES]\r
+$(PROJECT).rtf\r
+\r
+[WINDOWS]\r
+main="Tcl/Tk Reference Manual",,27648,(r15263976),(r65535)\r
+\r
+[CONFIG]\r
+BrowseButtons()\r
+CreateButton(1, "Web", ExecFile("http://www.tcl.tk"))\r
+CreateButton(2, "SF", ExecFile("http://sf.net/projects/tcl"))\r
+CreateButton(3, "Wiki", ExecFile("http://wiki.tcl.tk"))\r
+CreateButton(4, "FAQ", ExecFile("http://www.purl.org/NET/Tcl-FAQ/"))\r
+<<\r
+ cd $(MAKEDIR)\r
+ copy "$(DOCTMP_DIR)\$(@B).hlp" "$(OUT_DIR)"\r
+ copy "$(DOCTMP_DIR)\$(@B).cnt" "$(OUT_DIR)"\r
+\r
+$(MAN2TCL): $(TOOLSDIR)\$$(@B).c\r
+ $(cc32) -nologo -G4 -ML -O2 -Fo$(@D)\ $(TOOLSDIR)\$(@B).c -link -out:$@\r
+\r
+$(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\*\r
+ $(TCLSH) $(MAN2HELP:\=/) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/)\r
+\r
+install-docs:\r
+!if exist($(HELPFILE))\r
+ @xcopy /i /y "$(HELPFILE)" "$(DOC_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(HELPCNT)" "$(DOC_INSTALL_DIR)\"\r
+!endif\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Special case object file targets\r
+#---------------------------------------------------------------------\r
+\r
+$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c\r
+!if $(TCL_LINKWITHEXTENSIONS)\r
+ $(cc32) $(TCL_CFLAGS) -DTCL_TEST -DTCL_LINKWITHEXTENSIONS -Fo$@ $?\r
+!else\r
+ $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$@ $?\r
+!endif\r
+\r
+$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c\r
+ $(cc32) $(TCL_CFLAGS) -Fo$@ $?\r
+\r
+$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c\r
+ $(cc32) $(TCL_CFLAGS) -Fo$@ $?\r
+\r
+$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c\r
+ $(cc32) $(TCL_CFLAGS) -Fo$@ $?\r
+\r
+$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c\r
+!if $(TCL_LINKWITHEXTENSIONS)\r
+ $(cc32) $(TCL_CFLAGS) -DTCL_LINKWITHEXTENSIONS -Fo$@ $?\r
+!else\r
+ $(cc32) $(TCL_CFLAGS) -Fo$@ $?\r
+!endif\r
+\r
+### The following objects should be built using the stub interfaces\r
+\r
+$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c\r
+!if $(STATIC_BUILD)\r
+ $(cc32) $(BASE_CLFAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $?\r
+!else\r
+ $(cc32) $(BASE_CLFAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $?\r
+!endif\r
+\r
+\r
+$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c\r
+!if $(STATIC_BUILD)\r
+ $(cc32) $(BASE_CLFAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $?\r
+!else\r
+ $(cc32) $(BASE_CLFAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $?\r
+!endif\r
+\r
+\r
+### The following objects are part of the stub library and should not\r
+### be built as DLL objects but none of the symbols should be exported\r
+\r
+$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c\r
+ $(cc32) $(cdebug) $(cflags) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Dedependency rules\r
+#---------------------------------------------------------------------\r
+\r
+$(GENERICDIR)\regcomp.c: \\r
+ $(GENERICDIR)\regguts.h \\r
+ $(GENERICDIR)\regc_lex.c \\r
+ $(GENERICDIR)\regc_color.c \\r
+ $(GENERICDIR)\regc_nfa.c \\r
+ $(GENERICDIR)\regc_cvec.c \\r
+ $(GENERICDIR)\regc_locale.c\r
+$(GENERICDIR)\regcustom.h: \\r
+ $(GENERICDIR)\tclInt.h \\r
+ $(GENERICDIR)\tclPort.h \\r
+ $(GENERICDIR)\regex.h\r
+$(GENERICDIR)\regexec.c: \\r
+ $(GENERICDIR)\rege_dfa.c \\r
+ $(GENERICDIR)\regguts.h\r
+$(GENERICDIR)\regerror.c: $(GENERICDIR)\regguts.h\r
+$(GENERICDIR)\regfree.c: $(GENERICDIR)\regguts.h\r
+$(GENERICDIR)\regfronts.c: $(GENERICDIR)\regguts.h\r
+$(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h\r
+\r
+!if exist("$(OUT_DIR)\depend.mk")\r
+!include "$(OUT_DIR)\depend.mk"\r
+!message *** Dependency rules in effect.\r
+!else\r
+!message *** Dependency rules are not being used.\r
+!endif\r
+\r
+### add a spacer in the output\r
+!message\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Implicit rules\r
+#---------------------------------------------------------------------\r
+\r
+{$(WINDIR)}.c{$(TMP_DIR)}.obj::\r
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<\r
+$<\r
+<<\r
+\r
+{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::\r
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<\r
+$<\r
+<<\r
+\r
+{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::\r
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<\r
+$<\r
+<<\r
+\r
+{$(WINDIR)}.rc{$(TMP_DIR)}.res:\r
+ $(rc32) -fo $@ -r -i "$(GENERICDIR)" -D__WIN32__ \\r
+!if $(DEBUG)\r
+ -d DEBUG \\r
+!endif\r
+!if $(TCL_THREADS)\r
+ -d TCL_THREADS \\r
+!endif\r
+!if $(STATIC_BUILD)\r
+ -d STATIC_BUILD \\r
+!endif\r
+ $<\r
+\r
+.SUFFIXES:\r
+.SUFFIXES:.c .rc\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Installation.\r
+#---------------------------------------------------------------------\r
+\r
+install-binaries:\r
+ @echo installing $(TCLLIBNAME)\r
+!if "$(TCLLIB)" != "$(TCLIMPLIB)"\r
+ @xcopy /i /y "$(TCLLIB)" "$(BIN_INSTALL_DIR)\"\r
+!endif\r
+ @xcopy /i /y "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\"\r
+!if exist($(TCLSH))\r
+ @echo installing $(TCLSHNAME)\r
+ @xcopy /i /y "$(TCLSH)" "$(BIN_INSTALL_DIR)\"\r
+!endif\r
+!if exist($(TCLPIPEDLL))\r
+ @echo installing $(TCLPIPEDLLNAME)\r
+ @xcopy /i /y "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)\"\r
+!endif\r
+ @echo installing $(TCLSTUBLIBNAME)\r
+ @xcopy /i /y "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\"\r
+\r
+install-libraries:\r
+ @echo installing http1.0\r
+ @xcopy /i /y "$(ROOT)\library\http1.0\*.tcl" \\r
+ "$(SCRIPT_INSTALL_DIR)\http1.0\"\r
+ @echo installing http2.4\r
+ @xcopy /i /y "$(ROOT)\library\http\*.tcl" \\r
+ "$(SCRIPT_INSTALL_DIR)\http2.4\"\r
+ @echo installing opt0.4\r
+ @xcopy /i /y "$(ROOT)\library\opt\*.tcl" \\r
+ "$(SCRIPT_INSTALL_DIR)\opt0.4\"\r
+ @echo installing msgcat1.3\r
+ @xcopy /i /y "$(ROOT)\library\msgcat\*.tcl" \\r
+ "$(SCRIPT_INSTALL_DIR)\msgcat1.3\"\r
+ @echo installing tcltest2.2 \r
+ @xcopy /i /y "$(ROOT)\library\tcltest\*.tcl" \\r
+ "$(SCRIPT_INSTALL_DIR)\tcltest2.2\"\r
+ @echo installing $(TCLDDELIBNAME)\r
+!if $(STATIC_BUILD)\r
+ @xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\"\r
+!else\r
+ @xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"\r
+ @xcopy /i /y "$(ROOT)\library\dde\pkgIndex.tcl" \\r
+ "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"\r
+!endif\r
+ @echo installing $(TCLREGLIBNAME)\r
+!if $(STATIC_BUILD)\r
+ @xcopy /i /y "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\"\r
+!else\r
+ @xcopy /i /y "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\"\r
+ @xcopy /i /y "$(ROOT)\library\reg\pkgIndex.tcl" \\r
+ "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\"\r
+!endif\r
+ @echo installing encoding files\r
+ @xcopy /i /y "$(ROOT)\library\encoding\*.enc" \\r
+ "$(SCRIPT_INSTALL_DIR)\encoding\"\r
+ @echo installing library files\r
+ @xcopy /i /y "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+ @xcopy /i /y "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\"\r
+\r
+\r
+#---------------------------------------------------------------------\r
+# Clean up\r
+#---------------------------------------------------------------------\r
+\r
+!if "$(OS)" == "Windows_NT"\r
+RMDIR = rmdir /S /Q\r
+!else\r
+RMDIR = deltree /Y\r
+!endif\r
+\r
+tidy:\r
+ if exist $(TCLLIB) del $(TCLLIB)\r
+ if exist $(TCLSH) del $(TCLSH)\r
+ if exist $(TCLTEST) del $(TCLTEST)\r
+ if exist $(TCLDDELIB) del $(TCLDDELIB)\r
+ if exist $(TCLREGLIB) del $(TCLREGLIB)\r
+\r
+clean:\r
+ if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR)\r
+\r
+hose:\r
+ if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)\r
+\r
+++ /dev/null
-@echo off
-rem RCS: @(#) $Id$
-
-if exist %1\. goto end
-
-if "%OS%" == "Windows_NT" goto winnt
-
-md %1
-if errorlevel 1 goto end
-
-goto success
-
-:winnt
-md %1
-if errorlevel 1 goto end
-
-:success
-echo created directory %1
-
-:end
-
-
+++ /dev/null
-# Tcl package index file, version 1.0
-# This file contains package information for Windows-specific extensions.
-#
-# Copyright (c) 1997 by Sun Microsystems, Inc.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id$
-
-package ifneeded registry 1.0 [list tclPkgSetup $dir registry 1.0 {{tclreg80.dll load registry}}]
+++ /dev/null
-@echo off
-rem RCS: @(#) $Id$
-
-if not exist %1\. goto end
-
-echo Removing directory %1
-
-if "%OS%" == "Windows_NT" goto winnt
-
-cd %1
-if errorlevel 1 goto end
-del *.*
-cd ..
-rmdir %1
-if errorlevel 1 goto end
-goto success
-
-:winnt
-rmdir %1 /s /q
-if errorlevel 1 goto end
-
-:success
-echo deleted directory %1
-
-:end
-
-
#include <windows.h>
#include <stdio.h>
-#include <string.h>
static HANDLE CreateTempFile(void);
CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE,
NULL);
}
-
-
LCID=0x409 0x0 0x0 ;English (United States)\r
REPORT=Yes\r
TITLE=Tcl/Tk Reference Manual\r
-CNT=tcl83.cnt\r
-COPYRIGHT=Copyright © 1999 Scriptics Corporation\r
-HLP=tcl83.hlp\r
+CNT=tcl84.cnt\r
+COPYRIGHT=Copyright © 2000 Ajuba Solutions\r
+HLP=tcl84.hlp\r
\r
[FILES]\r
tcl.rtf\r
\r
[CONFIG]\r
BrowseButtons()\r
+\r
AC_DEFUN(SC_PATH_TCLCONFIG, [
AC_MSG_CHECKING([the location of tclConfig.sh])
-# CYGNUS LOCAL
- if test -d ../../tcl8.1/win; then
- TCL_BIN_DIR_DEFAULT=../../tcl8.1/win
+ if test -d ../../tcl8.4$1/win; then
+ TCL_BIN_DIR_DEFAULT=../../tcl8.4$1/win
+ elif test -d ../../tcl8.4/win; then
+ TCL_BIN_DIR_DEFAULT=../../tcl8.4/win
else
TCL_BIN_DIR_DEFAULT=../../tcl/win
fi
-# END CYGNUS LOCAL
- AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.3 binaries from DIR],
+ AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.4 binaries from DIR],
TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DIR_DEFAULT; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist)
AC_DEFUN(SC_PATH_TKCONFIG, [
AC_MSG_CHECKING([the location of tkConfig.sh])
- if test -d ../../tk8.3$1/win; then
- TK_BIN_DIR_DEFAULT=../../tk8.3$1/win
+ if test -d ../../tk8.4$1/win; then
+ TK_BIN_DIR_DEFAULT=../../tk8.4$1/win
+ elif test -d ../../tk8.4/win; then
+ TK_BIN_DIR_DEFAULT=../../tk8.4/win
else
- TK_BIN_DIR_DEFAULT=../../tk8.3/win
+ TK_BIN_DIR_DEFAULT=../../tk/win
fi
- AC_ARG_WITH(tk, [ --with-tk=DIR use Tk 8.3 binaries from DIR],
+ AC_ARG_WITH(tk, [ --with-tk=DIR use Tk 8.4 binaries from DIR],
TK_BIN_DIR=$withval, TK_BIN_DIR=`cd $TK_BIN_DIR_DEFAULT; pwd`)
if test ! -d $TK_BIN_DIR; then
AC_MSG_ERROR(Tk directory $TK_BIN_DIR does not exist)
AC_MSG_RESULT([file not found])
fi
- # The eval is required to do the TCL_DBGX substitution in the
- # TCL_LIB_FILE variable.
+ #
+ # If the TCL_BIN_DIR is the build directory (not the install directory),
+ # then set the common variable name to the value of the build variables.
+ # For example, the variable TCL_LIB_SPEC will be set to the value
+ # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC
+ # instead of TCL_BUILD_LIB_SPEC since it will work with both an
+ # installed and uninstalled version of Tcl.
+ #
+
+ if test -f $TCL_BIN_DIR/Makefile ; then
+ TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
+ TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
+ TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
+ fi
+
+ #
+ # eval is required to do the TCL_DBGX substitution
+ #
- eval TCL_LIB_FILE=${TCL_LIB_FILE}
- eval TCL_LIB_FLAG=${TCL_LIB_FLAG}
+ eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
+ eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
+ eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""
+ eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
+ eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
+ eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
+
+ AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
+
AC_SUBST(TCL_LIB_FILE)
+ AC_SUBST(TCL_LIB_FLAG)
+ AC_SUBST(TCL_LIB_SPEC)
+
+ AC_SUBST(TCL_STUB_LIB_FILE)
+ AC_SUBST(TCL_STUB_LIB_FLAG)
+ AC_SUBST(TCL_STUB_LIB_SPEC)
])
#------------------------------------------------------------------------
#------------------------------------------------------------------------
AC_DEFUN(SC_LOAD_TKCONFIG, [
- AC_MSG_CHECKING([for existence of $TCLCONFIG])
+ AC_MSG_CHECKING([for existence of $TK_BIN_DIR/tkConfig.sh])
if test -f "$TK_BIN_DIR/tkConfig.sh" ; then
- AC_MSG_CHECKING([loading $TK_BIN_DIR/tkConfig.sh])
+ AC_MSG_RESULT([loading])
. $TK_BIN_DIR/tkConfig.sh
else
AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh])
AC_MSG_RESULT(yes)
TCL_THREADS=1
AC_DEFINE(TCL_THREADS)
+ # USE_THREAD_ALLOC tells us to try the special thread-based
+ # allocator that significantly reduces lock contention
+ AC_DEFINE(USE_THREAD_ALLOC)
else
TCL_THREADS=0
AC_MSG_RESULT([no (default)])
fi
+ AC_SUBST(TCL_THREADS)
])
#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
# Specify if debugging symbols should be used
+# Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging
+# can also be enabled.
#
# Arguments:
# none
# Requires the following vars to be set in the Makefile:
# CFLAGS_DEBUG
# CFLAGS_OPTIMIZE
-# LDFLAGS_DEBUG
-# LDFLAGS_OPTIMIZE
#
# Results:
#
# --enable-symbols
#
# Defines the following vars:
-# CFLAGS_DEFAULT Set to $(CFLAGS_DEBUG) if true
-# Set to $(CFLAGS_OPTIMIZE) if false
-# LDFLAGS_DEFAULT Set to $(LDFLAGS_DEBUG) if true
-# Set to $(LDFLAGS_OPTIMIZE) if false
+# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true
+# Sets to $(CFLAGS_OPTIMIZE) if false
+# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
+# Sets to $(LDFLAGS_OPTIMIZE) if false
# DBGX Debug library extension
#
#------------------------------------------------------------------------
AC_DEFUN(SC_ENABLE_SYMBOLS, [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
-
- if test "$tcl_ok" = "yes"; then
- CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
- LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
- DBGX=d
- AC_MSG_RESULT([yes])
- else
+# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
+ if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
AC_MSG_RESULT([no])
+ else
+ CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
+ LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
+ DBGX=g
+ if test "$tcl_ok" = "yes"; then
+ AC_MSG_RESULT([yes (standard debugging)])
+ fi
+ fi
+ AC_SUBST(CFLAGS_DEFAULT)
+ AC_SUBST(LDFLAGS_DEFAULT)
+
+ if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then
+ AC_DEFINE(TCL_MEM_DEBUG)
fi
-])
+ if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then
+ AC_DEFINE(TCL_COMPILE_DEBUG)
+ AC_DEFINE(TCL_COMPILE_STATS)
+ fi
+
+ if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then
+ if test "$tcl_ok" = "all"; then
+ AC_MSG_RESULT([enabled symbols mem compile debugging])
+ else
+ AC_MSG_RESULT([enabled $tcl_ok debugging])
+ fi
+ fi
+])
#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
# Results:
#
-# Can set the following vars:
+# Can the following vars:
# EXTRA_CFLAGS
# CFLAGS_DEBUG
# CFLAGS_OPTIMIZE
#
# LIBSUFFIX
# LIBPREFIX
-# VENDORPREFIX
# LIBRARIES
# EXESUFFIX
# DLLSUFFIX
#--------------------------------------------------------------------
AC_DEFUN(SC_CONFIG_CFLAGS, [
- TCL_LIB_VERSIONS_OK=nodots
+
+ # Step 0: Enable 64 bit support?
+
+ AC_MSG_CHECKING([if 64bit support is requested])
+ AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)], [do64bit=$enableval], [do64bit=no])
+ AC_MSG_RESULT($do64bit)
+
+ # Set some defaults (may get changed below)
+ EXTRA_CFLAGS=""
AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo)
# path when using the Cygwin toolchain.
if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then
- conftest=/tmp/conftest.rc
- echo "STRINGTABLE BEGIN" > $conftest
- echo "101 \"name\"" >> $conftest
- echo "END" >> $conftest
-
- AC_MSG_CHECKING([for Windows native path bug in windres])
- cyg_conftest=`$CYGPATH $conftest`
- if AC_TRY_COMMAND($RC -o conftest.res.o $cyg_conftest) ; then
- AC_MSG_RESULT([no])
- else
- AC_MSG_RESULT([yes])
- CYGPATH=echo
- fi
- conftest=
- cyg_conftest=
+ conftest=/tmp/conftest.rc
+ echo "STRINGTABLE BEGIN" > $conftest
+ echo "101 \"name\"" >> $conftest
+ echo "END" >> $conftest
+
+ AC_MSG_CHECKING([for Windows native path bug in windres])
+ cyg_conftest=`$CYGPATH $conftest`
+ if AC_TRY_COMMAND($RC -o conftest.res.o $cyg_conftest) ; then
+ AC_MSG_RESULT([no])
+ else
+ AC_MSG_RESULT([yes])
+ CYGPATH=echo
+ fi
+ conftest=
+ cyg_conftest=
fi
if test "$CYGPATH" = "echo" || test "$ac_cv_cygwin" = "yes"; then
DEPARG='"$(shell $(CYGPATH) $<)"'
fi
- # CYGNUS LOCAL
- VENDORPREFIX="rh"
- # END CYGNUS LOCAL
-
# set various compiler flags depending on whether we are using gcc or cl
AC_MSG_CHECKING([compiler flags])
if test "${GCC}" = "yes" ; then
-
- # CYGNUS LOCAL
- if test "$ac_cv_cygwin" = "yes" ; then
- VENDORPREFIX="cyg"
+ if test "$do64bit" = "yes" ; then
+ AC_MSG_WARN("64bit mode not supported with GCC on Windows")
fi
- # END CYGNUS LOCAL
-
SHLIB_LD=""
SHLIB_LD_LIBS=""
LIBS=""
- LIBS_GUI="-lgdi32 -lcomdlg32"
- STLIB_LD="${AR} cr"
+ LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32"
+ STLIB_LD='${AR} cr'
RC_OUT=-o
RC_TYPE=
RC_INCLUDE=--include
+ RC_DEFINE=--define
RES=res.o
MAKE_LIB="\${STLIB_LD} \[$]@"
POST_MAKE_LIB="\${RANLIB} \[$]@"
MAKE_EXE="\${CC} -o \[$]@"
- LIBPREFIX="lib${VENDORPREFIX}"
+ LIBPREFIX="lib"
+
+ #if test "$ac_cv_cygwin" = "yes"; then
+ # extra_cflags="-mno-cygwin"
+ # extra_ldflags="-mno-cygwin"
+ #else
+ # extra_cflags=""
+ # extra_ldflags=""
+ #fi
+
+ if test "$ac_cv_cygwin" = "yes"; then
+ touch ac$$.c
+ if ${CC} -c -mwin32 ac$$.c >/dev/null 2>&1; then
+ case "$extra_cflags" in
+ *-mwin32*) ;;
+ *) extra_cflags="-mwin32 $extra_cflags" ;;
+ esac
+ case "$extra_ldflags" in
+ *-mwin32*) ;;
+ *) extra_ldflags="-mwin32 $extra_ldflags" ;;
+ esac
+ fi
+ rm -f ac$$.o ac$$.c
+ else
+ extra_cflags=''
+ extra_ldflags=''
+ fi
if test "${SHARED_BUILD}" = "0" ; then
# static
LIBSUFFIX="s\${DBGX}.a"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
- DLLSUFFIX=""
else
# dynamic
AC_MSG_RESULT([using shared flags])
# ad-hoc check to see if CC supports -shared.
if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
AC_MSG_ERROR([${CC} does not support the -shared option.
- You will need to upgrade to a newer version of the toolchain.])
+ You will need to upgrade to a newer version of the toolchain.])
fi
runtime=
# Link with gcc since ld does not link to default libs like
- # -luser32 and -lmsvcrt. We also need to add CFLAGS so important
- # flags like -mno-cygwin get passed in to CC.
+ # -luser32 and -lmsvcrt by default. Make sure CFLAGS is
+ # included so -mno-cygwin passed the correct libs to the linker.
SHLIB_LD='${CC} -shared ${CFLAGS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)"
- TCL_DLL_BASE="-Wl,--image-base=0x66000000"
- DDE_DLL_BASE="-Wl,--image-base=0x66100000"
- REG_DLL_BASE="-Wl,--image-base=0x66200000"
LIBSUFFIX="\${DBGX}.a"
- DLLSUFFIX="\${DBGX}.dll"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
+ # DLLSUFFIX is separate because it is the building block for
+ # users of tclConfig.sh that may build shared or static.
+ DLLSUFFIX="\${DBGX}.dll"
+
+ EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE=-O
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
+ #
+ # ORIGINAL COMMENT:
+ # We need to pass -e _WinMain@16 so that ld will use
+ # WinMain() instead of main() as the entry point. We can't
+ # use autoconf to check for this case since it would need
+ # to run an executable and that does not work when
+ # cross compiling. Remove this -e workaround once we
+ # require a gcc that does not have this bug.
+ #
+ # MK NOTE: Tk should use a different mechanism. This causes
+ # interesting problems, such as wish dying at startup.
+ #LDFLAGS_WINDOW="-mwindows -e _WinMain@16 ${extra_ldflags}"
LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}"
LDFLAGS_WINDOW="-mwindows ${extra_ldflags}"
else
- SHLIB_LD="link -dll -nologo"
- SHLIB_LD_LIBS="user32.lib advapi32.lib"
- LIBS="user32.lib advapi32.lib"
- LIBS_GUI="gdi32.lib comdlg32.lib"
- STLIB_LD="lib -nologo"
- RC="rc"
- RC_OUT=-fo
- RC_TYPE=-r
- RC_INCLUDE=-i
- RES=res
- MAKE_LIB="\${STLIB_LD} -out:\[$]@"
- POST_MAKE_LIB=
- MAKE_EXE="\${CC} -Fe\[$]@"
- LIBPREFIX=${VENDORPREFIX}
-
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
LIBSUFFIX="s\${DBGX}.lib"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
- DLLSUFFIX=""
else
# dynamic
AC_MSG_RESULT([using shared flags])
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
LIBSUFFIX="\${DBGX}.lib"
- DLLSUFFIX="\${DBGX}.dll"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
+ # DLLSUFFIX is separate because it is the building block for
+ # users of tclConfig.sh that may build shared or static.
+ DLLSUFFIX="\${DBGX}.dll"
+
+ # This is a 2-stage check to make sure we have the 64-bit SDK
+ # We have to know where the SDK is installed.
+ if test "$do64bit" = "yes" ; then
+ if test "x${MSSDK}x" = "xx" ; then
+ MSSDK="C:/Progra~1/Microsoft SDK"
+ fi
+ # In order to work in the tortured autoconf environment,
+ # we need to ensure that this path has no spaces
+ MSSDK=$(cygpath -w -s "$MSSDK" | sed -e 's!\\!/!g')
+ if test ! -d "${MSSDK}/bin/win64" ; then
+ AC_MSG_WARN("could not find 64-bit SDK to enable 64bit mode")
+ do64bit="no"
+ fi
+ fi
+
+ if test "$do64bit" = "yes" ; then
+ # All this magic is necessary for the Win64 SDK RC1 - hobbs
+ CC="${MSSDK}/Bin/Win64/cl.exe \
+ -I${MSSDK}/Include/prerelease \
+ -I${MSSDK}/Include/Win64/crt \
+ -I${MSSDK}/Include/Win64/crt/sys \
+ -I${MSSDK}/Include"
+ RC="${MSSDK}/bin/rc.exe"
+ CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
+ CFLAGS_OPTIMIZE="-nologo -O2 -Gs ${runtime}"
+ lflags="-MACHINE:IA64 -LIBPATH:${MSSDK}/Lib/IA64 \
+ -LIBPATH:${MSSDK}/Lib/Prerelease/IA64"
+ STLIB_LD="${MSSDK}/bin/win64/lib.exe -nologo ${lflags}"
+ LINKBIN="${MSSDK}/bin/win64/link.exe ${lflags}"
+ else
+ RC="rc"
+ CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
+ CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
+ STLIB_LD="lib -nologo"
+ LINKBIN="link -link50compat"
+ fi
+
+ SHLIB_LD="${LINKBIN} -dll -nologo -incremental:no"
+ SHLIB_LD_LIBS="user32.lib advapi32.lib"
+ LIBS="user32.lib advapi32.lib"
+ LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib"
+ RC_OUT=-fo
+ RC_TYPE=-r
+ RC_INCLUDE=-i
+ RC_DEFINE=-d
+ RES=res
+ MAKE_LIB="\${STLIB_LD} -out:\[$]@"
+ POST_MAKE_LIB=
+ MAKE_EXE="\${CC} -Fe\[$]@"
+ LIBPREFIX=""
EXTRA_CFLAGS="-YX"
- CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
-# CFLAGS_OPTIMIZE="-nologo -O2 -Gs -GD ${runtime}"
- CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
CFLAGS_WARNING="-W3"
- LDFLAGS_DEBUG="-debug:full -debugtype:cv"
+ LDFLAGS_DEBUG="-debug:full -debugtype:both"
LDFLAGS_OPTIMIZE="-release"
-
+
# Specify the CC output file names based on the target name
CC_OBJNAME="-Fo\[$]@"
CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\""
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
- LDFLAGS_CONSOLE="-link -subsystem:console"
- LDFLAGS_WINDOW="-link -subsystem:windows"
+ LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}"
+ LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}"
fi
- # Define the same variables as used in tclConfig.sh so that macros
- # that depend on these variables work for both Tcl and extensions.
- TCL_LIB_SUFFIX=$LIBSUFFIX
- TCL_VENDOR_PREFIX=$VENDORPREFIX
+ # DL_LIBS is empty, but then we match the Unix version
+ AC_SUBST(DL_LIBS)
+ AC_SUBST(CFLAGS_DEBUG)
+ AC_SUBST(CFLAGS_OPTIMIZE)
+ AC_SUBST(CFLAGS_WARNING)
])
#------------------------------------------------------------------------
#------------------------------------------------------------------------
AC_DEFUN(SC_WITH_TCL, [
- if test -d ../../tcl8.3$1/win; then
- TCL_BIN_DEFAULT=../../tcl8.3$1/win
+ if test -d ../../tcl8.4$1/win; then
+ TCL_BIN_DEFAULT=../../tcl8.4$1/win
else
- TCL_BIN_DEFAULT=../../tcl8.3/win
+ TCL_BIN_DEFAULT=../../tcl8.4/win
fi
- AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.3 binaries from DIR],
+ AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.4 binaries from DIR],
TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist)
AC_SUBST(TCL_BIN_DIR)
])
-#--------------------------------------------------------------------
-# SC_TIME_HANLDER
-#
-# Checks how the system deals with time.h, what time structures
-# are used on the system, and what fields the structures have.
-#
-# Arguments:
+# FIXME : SC_PROG_TCLSH should really look for the installed tclsh and
+# not the build version. If we want to use the build version in the
+# tk script, it is better to hardcode that!
+
+#------------------------------------------------------------------------
+# SC_PROG_TCLSH
+# Locate a tclsh shell in the following directories:
+# ${exec_prefix}/bin
+# ${prefix}/bin
+# ${TCL_BIN_DIR}
+# ${TCL_BIN_DIR}/../bin
+# ${PATH}
+#
+# Arguments
# none
-#
-# Results:
#
-# Defines some of the following vars:
-# USE_DELTA_FOR_TZ
-# HAVE_TM_GMTOFF
-# HAVE_TM_TZADJ
-# HAVE_TIMEZONE_VAR
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(SC_TIME_HANDLER, [
- AC_CHECK_HEADERS(sys/time.h)
- AC_HEADER_TIME
- AC_STRUCT_TIMEZONE
-
- AC_MSG_CHECKING([tm_tzadj in struct tm])
- AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;],
- [AC_DEFINE(HAVE_TM_TZADJ)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
-
- AC_MSG_CHECKING([tm_gmtoff in struct tm])
- AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;],
- [AC_DEFINE(HAVE_TM_GMTOFF)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
-
- #
- # Its important to include time.h in this check, as some systems
- # (like convex) have timezone functions, etc.
- #
- have_timezone=no
- AC_MSG_CHECKING([long timezone variable])
- AC_TRY_COMPILE([#include <time.h>],
- [extern long timezone;
- timezone += 1;
- exit (0);],
- [have_timezone=yes
- AC_DEFINE(HAVE_TIMEZONE_VAR)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
-
- #
- # On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
- #
- if test "$have_timezone" = no; then
- AC_MSG_CHECKING([time_t timezone variable])
- AC_TRY_COMPILE([#include <time.h>],
- [extern time_t timezone;
- timezone += 1;
- exit (0);],
- [AC_DEFINE(HAVE_TIMEZONE_VAR)
- AC_MSG_RESULT(yes)],
- AC_MSG_RESULT(no))
- fi
-
- #
- # On some systems (eg Solaris 2.5.1), timezone is not declared in
- # time.h unless you jump through hoops. Instead of that, we just
- # declare it ourselves when necessary.
- #
- if test "$have_timezone" = yes; then
- AC_MSG_CHECKING(for timezone declaration)
- changequote(<<,>>)
- tzrx='^[ ]*extern.*timezone'
- changequote([,])
- AC_EGREP_HEADER($tzrx, time.h, [
- AC_DEFINE(HAVE_TIMEZONE_DECL)
- AC_MSG_RESULT(found)], AC_MSG_RESULT(missing))
- fi
-
- #
- # AIX does not have a timezone field in struct tm. When the AIX bsd
- # library is used, the timezone global and the gettimeofday methods are
- # to be avoided for timezone deduction instead, we deduce the timezone
- # by comparing the localtime result on a known GMT value.
- #
+# Results
+# Subst's the following values:
+# TCLSH_PROG
+#------------------------------------------------------------------------
- if test "`uname -s`" = "AIX" ; then
- AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes)
- if test $libbsd = yes; then
- AC_DEFINE(USE_DELTA_FOR_TZ)
- fi
+AC_DEFUN(SC_PROG_TCLSH, [
+ AC_MSG_CHECKING([for tclsh])
+
+ AC_CACHE_VAL(ac_cv_path_tclsh, [
+ search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'`
+ for dir in $search_path ; do
+ for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \
+ `ls -r $dir/tclsh* 2> /dev/null` ; do
+ if test x"$ac_cv_path_tclsh" = x ; then
+ if test -f "$j" ; then
+ ac_cv_path_tclsh=$j
+ break
+ fi
+ fi
+ done
+ done
+ ])
+
+ if test -f "$ac_cv_path_tclsh" ; then
+ TCLSH_PROG="$ac_cv_path_tclsh"
+ AC_MSG_RESULT($TCLSH_PROG)
+ elif test -f "$TCL_BIN_DIR/tclConfig.sh" ; then
+ # One-tree build.
+ ac_cv_path_tclsh="$TCL_BIN_DIR/tclsh"
+ TCLSH_PROG="$ac_cv_path_tclsh"
+ AC_MSG_RESULT($TCLSH_PROG)
+ else
+ AC_MSG_ERROR(No tclsh found in PATH: $search_path)
fi
+ AC_SUBST(TCLSH_PROG)
])
-
// RCS: @(#) $Id$
//
-// Version
+// Version Resource Script
//
-#define VS_VERSION_INFO 1
-
-#define RESOURCE_INCLUDED
+#include <winver.h>
#include <tcl.h>
+//
+// build-up the name suffix that defines the type of build this is.
+//
+#ifdef TCL_THREADS
+#define SUFFIX_THREADS "t"
+#else
+#define SUFFIX_THREADS ""
+#endif
+
+#ifdef DEBUG
+#define SUFFIX_DEBUG "d"
+#else
+#define SUFFIX_DEBUG ""
+#endif
+
+#define SUFFIX SUFFIX_THREADS SUFFIX_DEBUG
+
+
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
VS_VERSION_INFO VERSIONINFO
FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
FILEFLAGSMASK 0x3fL
+#ifdef DEBUG
+ FILEFLAGS VS_FF_DEBUG
+#else
FILEFLAGS 0x0L
- FILEOS 0x4 /* VOS__WINDOWS32 */
- FILETYPE 0x2 /* VFT_DLL */
+#endif
+ FILEOS VOS__WINDOWS32
+ FILETYPE VFT_DLL
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
BEGIN
VALUE "FileDescription", "Tcl DLL\0"
- VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0"
- VALUE "CompanyName", "Scriptics Corporation\0"
+ VALUE "OriginalFilename", "tcl" STRINGIFY(JOIN(TCL_MAJOR_VERSION,TCL_MINOR_VERSION)) SUFFIX ".dll\0"
+ VALUE "CompanyName", "ActiveState Corporation\0"
VALUE "FileVersion", TCL_PATCH_LEVEL
- VALUE "LegalCopyright", "Copyright (c) 2000 by Scriptics Corporation\0"
+ VALUE "LegalCopyright", "Copyright \251 2001 by ActiveState Corporation, et al\0"
VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
VALUE "ProductVersion", TCL_PATCH_LEVEL
END
VALUE "Translation", 0x409, 1200
END
END
-
-
-
-
-
-
-
-
-
-
+++ /dev/null
-// RCS: @(#) $Id$
-//
-// Version
-//
-
-#define RESOURCE_INCLUDED
-#include <tcl.h>
-
-VS_VERSION_INFO VERSIONINFO
- FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
- PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
- FILEFLAGSMASK 0x3fL
- FILEFLAGS 0x0L
- FILEOS 0x1L
- FILETYPE 0x2L
- FILESUBTYPE 0x0L
-BEGIN
- BLOCK "StringFileInfo"
- BEGIN
- BLOCK "040904b0"
- BEGIN
- VALUE "FileDescription", "Tcl16 DLL, 16-bit thunking module\0"
- VALUE "OriginalFilename", "tcl16" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0"
- VALUE "CompanyName", "Sun Microsystems, Inc\0"
- VALUE "FileVersion", TCL_PATCH_LEVEL
- VALUE "LegalCopyright", "Copyright \251 1995-1996\0"
- VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
- VALUE "ProductVersion", TCL_PATCH_LEVEL
- END
- END
- BLOCK "VarFileInfo"
- BEGIN
- VALUE "Translation", 0x409, 1200
- END
-END
-
-
#endif /* TCL_TEST */
static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
+static BOOL __stdcall sigHandler (DWORD fdwCtrlType);
+static Tcl_AsyncProc asyncExit;
+
+Tcl_AsyncHandler exitToken;
+DWORD exitErrorCode;
\f
/*
return TCL_ERROR;
}
+ /*
+ * Install a signal handler to the win32 console tclsh is running in.
+ */
+ SetConsoleCtrlHandler(sigHandler, TRUE);
+ exitToken = Tcl_AsyncCreate(asyncExit, NULL);
+
#ifdef TCL_TEST
if (Tcltest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
*argvPtr = argv;
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * asyncExit --
+ *
+ * The AsyncProc for the exitToken.
+ *
+ * Results:
+ * doesn't actually return.
+ *
+ * Side effects:
+ * tclsh cleanly exits.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+asyncExit (ClientData clientData, Tcl_Interp *interp, int code)
+{
+ Tcl_Exit((int)exitErrorCode);
+
+ /* NOTREACHED */
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * sigHandler --
+ *
+ * Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and
+ * other exits. This is needed so tclsh can do it's real clean-up
+ * and not an unclean crash terminate.
+ *
+ * Results:
+ * TRUE.
+ *
+ * Side effects:
+ * Effects the way the app exits from a signal. This is an
+ * operating system supplied thread and unsafe to call ANY
+ * Tcl commands except for Tcl_AsyncMark.
+ *
+ *----------------------------------------------------------------------
+ */
+
+BOOL __stdcall
+sigHandler(DWORD fdwCtrlType)
+{
+ /*
+ * If Tcl is currently executing some bytecode or in the eventloop,
+ * this will cause Tcl to enter asyncExit at the next command
+ * boundry.
+ */
+ exitErrorCode = fdwCtrlType;
+ Tcl_AsyncMark(exitToken);
+
+ /*
+ * This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>
+ * should it be blocked on input and our Tcl_AsyncMark didn't grab
+ * the attention of the interpreter.
+ */
+ CloseHandle(GetStdHandle(STD_INPUT_HANDLE));
+ /* indicate to the OS not to call the default terminator */
+ return TRUE;
+}
#
# RCS: @(#) $Id$
+TCL_DLL_FILE="@TCL_DLL_FILE@"
+
# Tcl's version number.
TCL_VERSION='@TCL_VERSION@'
TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@'
# The name of the Tcl library (may be either a .a file or a shared library):
TCL_LIB_FILE='@TCL_LIB_FILE@'
-# The fullpath of the Tcl library (used for dependency checking)
-TCL_LIB_FULL_PATH='@TCL_LIB_FULL_PATH@'
-
# Flag to indicate whether shared libraries need export files.
TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@
# explanation.
TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@'
-# Suffix to use in the name of a shared library.
-TCL_SHLIB_SUFFIX='@DLLSUFFIX@'
-
-# Suffix to use in the name of an unshared library.
-TCL_LIB_SUFFIX='@LIBSUFFIX@'
+# Suffix to use for the name of a shared library.
+TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@'
# Library file(s) to include in tclsh and other base applications
# in order to provide facilities needed by DLOBJ above.
# installed directory.
TCL_LIB_SPEC='@TCL_LIB_SPEC@'
+# String to pass to the compiler so that an extension can
+# find installed Tcl headers.
+TCL_INCLUDE_SPEC='@TCL_INCLUDE_SPEC@'
+
# Indicates whether a version numbers should be used in -l switches
# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means
# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for
# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@'
-TCL_DLL_FILE="@TCL_DLL_FILE@"
-TCL_STUB_LIB_FILE="@TCL_STUB_LIB_FILE@"
-
-# Vendor prefix to be added to lib names
-TCL_VENDOR_PREFIX=@VENDORPREFIX@
+# Flag, 1: we built Tcl with threads enables, 0 we didn't
+TCL_THREADS=@TCL_THREADS@
+++ /dev/null
-/*
- * tclWin16.c --
- *
- * This file contains code for a 16-bit DLL to handle 32-to-16 bit
- * thunking. This is necessary for the Win32s SynchSpawn() call.
- *
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id$
- */
-
-#define STRICT
-
-#include <windows.h>
-#include <toolhelp.h>
-
-#include <stdio.h>
-#include <string.h>
-
-static int WinSpawn(char *command);
-static int DosSpawn(char *command, char *fromFileName,
- char *toFileName);
-static int WaitForExit(int inst);
-
-/*
- * The following data is used to construct a .pif file that wraps the
- * .bat file that runs the 16-bit application (that Jack built).
- * The .pif file causes the .bat file to run in an iconified window.
- * Otherwise, when we try to exec something, a DOS box pops up,
- * obscuring everything, and then almost immediately flickers out of
- * existence, which is rather disconcerting.
- */
-
-static char pifData[545] = {
-'\000', '\013', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\200', '\000', '\200', '\000', '\103', '\117', '\115', '\115',
-'\101', '\116', '\104', '\056', '\103', '\117', '\115', '\000',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\020', '\000', '\000', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\177', '\001', '\000',
-'\377', '\031', '\120', '\000', '\000', '\007', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\340',
-'\040', '\115', '\111', '\103', '\122', '\117', '\123', '\117',
-'\106', '\124', '\040', '\120', '\111', '\106', '\105', '\130',
-'\000', '\207', '\001', '\000', '\000', '\161', '\001', '\127',
-'\111', '\116', '\104', '\117', '\127', '\123', '\040', '\063',
-'\070', '\066', '\040', '\063', '\056', '\060', '\000', '\005',
-'\002', '\235', '\001', '\150', '\000', '\200', '\002', '\200',
-'\000', '\144', '\000', '\062', '\000', '\000', '\004', '\000',
-'\000', '\000', '\004', '\000', '\000', '\002', '\020', '\002',
-'\000', '\037', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000', '\000', '\000', '\000', '\000', '\057', '\143', '\040',
-'\146', '\157', '\157', '\056', '\142', '\141', '\164', '\000',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
-'\040', '\040', '\040', '\040', '\040', '\127', '\111', '\116',
-'\104', '\117', '\127', '\123', '\040', '\062', '\070', '\066',
-'\040', '\063', '\056', '\060', '\000', '\377', '\377', '\033',
-'\002', '\006', '\000', '\000', '\000', '\000', '\000', '\000',
-'\000'
-};
-
-static HINSTANCE hInstance;
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * LibMain --
- *
- * 16-bit DLL entry point.
- *
- * Results:
- * Returns 1.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int CALLBACK
-LibMain(
- HINSTANCE hinst,
- WORD wDS,
- WORD cbHeap,
- LPSTR unused)
-{
- hInstance = hinst;
- wDS = wDS; /* lint. */
- cbHeap = cbHeap; /* lint. */
- unused = unused; /* lint. */
-
- return TRUE;
-}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * UTProc --
- *
- * Universal Thunk dispatch routine. Executes a 16-bit DOS
- * application or a 16-bit or 32-bit Windows application and
- * waits for it to complete.
- *
- * Results:
- * 1 if the application could be run, 0 or -1 on failure.
- *
- * Side effects:
- * Executes 16-bit code.
- *
- *----------------------------------------------------------------------
- */
-
-int WINAPI
-UTProc(buf, func)
- void *buf;
- DWORD func;
-{
- char **args;
-
- args = (char **) buf;
- if (func == 0) {
- return DosSpawn(args[0], args[1], args[2]);
- } else {
- return WinSpawn(args[0]);
- }
-}
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * WinSpawn --
- *
- * Start a 16-bit or 32-bit Windows application with optional
- * command line arguments and wait for it to finish. Windows
- * applications do not handle input/output redirection.
- *
- * Results:
- * The return value is 1 if the application could be run, 0 otherwise.
- *
- * Side effects:
- * Whatever the application does.
- *
- *-------------------------------------------------------------------------
- */
-
-static int
-WinSpawn(command)
- char *command; /* The command line, consisting of the name
- * of the executable to run followed by any
- * number of arguments to the executable. */
-{
- return WaitForExit(WinExec(command, SW_SHOW));
-}
-\f
-/*
- *---------------------------------------------------------------------------
- *
- * DosSpawn --
- *
- * Start a 16-bit DOS program with optional command line arguments
- * and wait for it to finish. Input and output can be redirected
- * from the specified files, but there is no such thing as stderr
- * under Win32s.
- *
- * This procedure to constructs a temporary .pif file that wraps a
- * temporary .bat file that runs the 16-bit application. The .bat
- * file is necessary to get the redirection symbols '<' and '>' to
- * work, because WinExec() doesn't accept them. The .pif file is
- * necessary to cause the .bat file to run in an iconified window,
- * to avoid having a large DOS box pop up, obscuring everything, and
- * then almost immediately flicker out of existence, which is rather
- * disconcerting.
- *
- * Results:
- * The return value is 1 if the application could be run, 0 otherwise.
- *
- * Side effects:
- * Whatever the application does.
- *
- *---------------------------------------------------------------------------
- */
-
-static int
-DosSpawn(command, fromFileName, toFileName)
- char *command; /* The name of the program, plus any
- * arguments, to be run. */
- char *fromFileName; /* Standard input for the program is to be
- * redirected from this file, or NULL for no
- * standard input. */
- char *toFileName; /* Standard output for the program is to be
- * redirected to this file, or NULL to
- * discard standard output. */
-{
- int result;
- HFILE batFile, pifFile;
- char batFileName[144], pifFileName[144];
-
- GetTempFileName(0, "tcl", 0, batFileName);
- unlink(batFileName);
- strcpy(strrchr(batFileName, '.'), ".bat");
- batFile = _lcreat(batFileName, 0);
-
- GetTempFileName(0, "tcl", 0, pifFileName);
- unlink(pifFileName);
- strcpy(strrchr(pifFileName, '.'), ".pif");
- pifFile = _lcreat(pifFileName, 0);
-
- _lwrite(batFile, command, strlen(command));
- if (fromFileName == NULL) {
- _lwrite(batFile, " < nul", 6);
- } else {
- _lwrite(batFile, " < ", 3);
- _lwrite(batFile, fromFileName, strlen(fromFileName));
- }
- if (toFileName == NULL) {
- _lwrite(batFile, " > nul", 6);
- } else {
- _lwrite(batFile, " > ", 3);
- _lwrite(batFile, toFileName, strlen(toFileName));
- }
- _lwrite(batFile, "\r\n\032", 3);
- _lclose(batFile);
-
- strcpy(pifData + 0x1c8, batFileName);
- _lwrite(pifFile, pifData, sizeof(pifData));
- _lclose(pifFile);
-
- result = WaitForExit(WinExec(pifFileName, SW_MINIMIZE));
-
- unlink(pifFileName);
- unlink(batFileName);
-
- return result;
-}
-\f
-/*
- *-------------------------------------------------------------------------
- *
- * WaitForExit --
- *
- * Wait until the application with the given instance handle has
- * finished. PeekMessage() is used to yield the processor;
- * otherwise, nothing else could execute on the system.
- *
- * Results:
- * The return value is 1 if the process exited successfully,
- * or 0 otherwise.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-static int
-WaitForExit(inst)
- int inst; /* Identifies the instance handle of the
- * process to wait for. */
-{
- TASKENTRY te;
- MSG msg;
- UINT timer;
-
- if (inst < 32) {
- return 0;
- }
-
- te.dwSize = sizeof(te);
- te.hInst = 0;
- TaskFirst(&te);
- do {
- if (te.hInst == (HINSTANCE) inst) {
- break;
- }
- } while (TaskNext(&te) != FALSE);
-
- if (te.hInst != (HINSTANCE) inst) {
- return 0;
- }
-
- timer = SetTimer(NULL, 0, 0, NULL);
- while (1) {
- if (GetMessage(&msg, NULL, 0, 0) != 0) {
- TranslateMessage(&msg);
- DispatchMessage(&msg);
- }
- TaskFirst(&te);
- do {
- if (te.hInst == (HINSTANCE) inst) {
- break;
- }
- } while (TaskNext(&te) != FALSE);
-
- if (te.hInst != (HINSTANCE) inst) {
- KillTimer(NULL, timer);
- return 1;
- }
- }
-}
static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
static int platformId; /* Running under NT, or 95/98? */
+#ifdef HAVE_NO_SEH
+static void *ESP;
+static void *EBP;
+#endif /* HAVE_NO_SEH */
+
/*
* The following function tables are used to dispatch to either the
* wide-character or multi-byte versions of the operating system calls,
WCHAR *, TCHAR **)) SearchPathA,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
+ NULL,
+ NULL,
};
static TclWinProcs unicodeProcs = {
WCHAR *, TCHAR **)) SearchPathW,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
+ NULL,
+ NULL,
};
TclWinProcs *tclWinProcs;
-Tcl_Encoding tclWinTCharEncoding;
+static Tcl_Encoding tclWinTCharEncoding;
/*
* The following declaration is for the VC++ DLL entry point.
BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
LPVOID reserved);
-/* CYGNUS LOCAL */
-#ifdef __CYGWIN__0
-/* CYGWIN requires an impure pointer variable, which must be
- explicitly initialized when the DLL starts up. */
-struct _reent *_impure_ptr;
-extern struct _reent __declspec(dllimport) reent_data;
-#endif
-/* END CYGNUS LOCAL */
#ifdef __WIN32__
#ifndef STATIC_BUILD
DWORD reason; /* Reason this function is being called. */
LPVOID reserved; /* Not used. */
{
- /* CYGNUS LOCAL */
-#ifdef __CYGWIN__0
- /* Cygwin requires the impure data pointer to be initialized
- when the DLL starts up. */
- _impure_ptr = &reent_data;
-#endif
- /* END CYGNUS LOCAL */
-
switch (reason) {
case DLL_PROCESS_ATTACH:
TclWinInit(hInst);
int
TclpCheckStackSpace()
{
+ int retval = 0;
+
/*
* We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
* bytes of stack space left. alloca() is cheap on windows; basically
* exception if the stack pointer is set below the bottom of the stack.
*/
-#ifndef __GNUC__
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "movl %esp, _ESP" "\n\t"
+ "movl %ebp, _EBP");
+
+ __asm__ __volatile__ (
+ "pushl $__except_checkstackspace_handler" "\n\t"
+ "pushl %fs:0" "\n\t"
+ "mov %esp, %fs:0");
+#else
__try {
+#endif /* HAVE_NO_SEH */
alloca(TCL_WIN_STACK_THRESHOLD);
- return 1;
- /* CYGNUS LOCAL */
- } __except (1) {}
+ retval = 1;
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "jmp checkstackspace_pop" "\n"
+ "checkstackspace_reentry:" "\n\t"
+ "movl _ESP, %esp" "\n\t"
+ "movl _EBP, %ebp");
+
+ __asm__ __volatile__ (
+ "checkstackspace_pop:" "\n\t"
+ "mov (%esp), %eax" "\n\t"
+ "mov %eax, %fs:0" "\n\t"
+ "add $8, %esp");
#else
- return alloca(TCL_WIN_STACK_THRESHOLD) != NULL;
-#endif
+ } __except (EXCEPTION_EXECUTE_HANDLER) {}
+#endif /* HAVE_NO_SEH */
- return 0;
+ /*
+ * Avoid using control flow statements in the SEH guarded block!
+ */
+ return retval;
}
-
+#ifdef HAVE_NO_SEH
+static
+__attribute__ ((cdecl))
+EXCEPTION_DISPOSITION
+_except_checkstackspace_handler(
+ struct _EXCEPTION_RECORD *ExceptionRecord,
+ void *EstablisherFrame,
+ struct _CONTEXT *ContextRecord,
+ void *DispatcherContext)
+{
+ __asm__ __volatile__ (
+ "jmp checkstackspace_reentry");
+ return 0; /* Function does not return */
+}
+#endif /* HAVE_NO_SEH */
\f
/*
*----------------------------------------------------------------------
* tclWinProcs structure to dispatch to either the wide-character
* or multi-byte versions of the operating system calls, depending
* on whether Unicode is the system encoding.
+ *
+ * As well as this, we can also try to load in some additional
+ * procs which may/may not be present depending on the current
+ * Windows version (e.g. Win95 will not have the procs below).
*
* Results:
* None.
if (wide) {
tclWinProcs = &unicodeProcs;
tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
+ if (tclWinProcs->getFileAttributesExProc == NULL) {
+ HINSTANCE hInstance = LoadLibraryA("kernel32");
+ if (hInstance != NULL) {
+ tclWinProcs->getFileAttributesExProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
+ LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");
+ tclWinProcs->createHardLinkProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
+ LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
+ "CreateHardLinkW");
+ FreeLibrary(hInstance);
+ }
+ }
} else {
tclWinProcs = &asciiProcs;
tclWinTCharEncoding = NULL;
+ if (tclWinProcs->getFileAttributesExProc == NULL) {
+ HINSTANCE hInstance = LoadLibraryA("kernel32");
+ if (hInstance != NULL) {
+ tclWinProcs->getFileAttributesExProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
+ LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");
+ tclWinProcs->createHardLinkProc =
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
+ LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
+ "CreateHardLinkA");
+ FreeLibrary(hInstance);
+ }
+ }
}
}
\f
return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
(CONST char *) string, len, dsPtr);
}
-
-
-
int flags; /* State flags, see above for a list. */
HANDLE handle; /* Input/output file. */
struct FileInfo *nextPtr; /* Pointer to next registered file. */
+ int dirty; /* Boolean flag. Set if the OS may have data
+ * pending on the channel */
} FileInfo;
typedef struct ThreadSpecificData {
static int FileInputProc _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
static int FileOutputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCode));
+ CONST char *buf, int toWrite, int *errorCode));
static int FileSeekProc _ANSI_ARGS_((ClientData instanceData,
long offset, int mode, int *errorCode));
+static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_WideInt offset, int mode, int *errorCode));
static void FileSetupProc _ANSI_ARGS_((ClientData clientData,
int flags));
static void FileWatchProc _ANSI_ARGS_((ClientData instanceData,
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
- TCL_CHANNEL_VERSION_2, /* v2 channel */
+ TCL_CHANNEL_VERSION_3, /* v3 channel */
FileCloseProc, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
FileBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
+ FileWideSeekProc, /* Wide seek proc. */
};
+#ifdef HAVE_NO_SEH
+static void *ESP;
+static void *EBP;
+#endif /* HAVE_NO_SEH */
+
\f
/*
*----------------------------------------------------------------------
static int
FileSeekProc(instanceData, offset, mode, errorCodePtr)
- ClientData instanceData; /* File state. */
- long offset; /* Offset to seek to. */
- int mode; /* Relative to where
- * should we seek? */
- int *errorCodePtr; /* To store error code. */
+ ClientData instanceData; /* File state. */
+ long offset; /* Offset to seek to. */
+ int mode; /* Relative to where should we seek? */
+ int *errorCodePtr; /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *) instanceData;
DWORD moveMethod;
- DWORD newPos;
+ DWORD newPos, newPosHigh;
+ DWORD oldPos, oldPosHigh;
*errorCodePtr = 0;
if (mode == SEEK_SET) {
moveMethod = FILE_END;
}
- newPos = SetFilePointer(infoPtr->handle, offset, NULL, moveMethod);
- if (newPos == 0xFFFFFFFF) {
- TclWinConvertError(GetLastError());
- *errorCodePtr = errno;
+ /*
+ * Save our current place in case we need to roll-back the seek.
+ */
+ oldPosHigh = (DWORD)0;
+ oldPos = SetFilePointer(infoPtr->handle, (LONG)0, &oldPosHigh,
+ FILE_CURRENT);
+ if (oldPos == INVALID_SET_FILE_POINTER) {
+ int winError = GetLastError();
+ if (winError != NO_ERROR) {
+ TclWinConvertError(winError);
+ *errorCodePtr = errno;
+ return -1;
+ }
+ }
+
+ newPosHigh = (DWORD)(offset < 0 ? -1 : 0);
+ newPos = SetFilePointer(infoPtr->handle, (LONG) offset, &newPosHigh,
+ moveMethod);
+ if (newPos == INVALID_SET_FILE_POINTER) {
+ int winError = GetLastError();
+ if (winError != NO_ERROR) {
+ TclWinConvertError(winError);
+ *errorCodePtr = errno;
+ return -1;
+ }
+ }
+
+ /*
+ * Check for expressability in our return type, and roll-back otherwise.
+ */
+ if (newPosHigh != 0) {
+ *errorCodePtr = EOVERFLOW;
+ SetFilePointer(infoPtr->handle, (LONG)oldPos, &oldPosHigh, FILE_BEGIN);
return -1;
}
- return newPos;
+ return (int) newPos;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileWideSeekProc --
+ *
+ * Seeks on a file-based channel. Returns the new position.
+ *
+ * Results:
+ * -1 if failed, the new position if successful. If failed, it
+ * also sets *errorCodePtr to the error code.
+ *
+ * Side effects:
+ * Moves the location at which the channel will be accessed in
+ * future operations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+FileWideSeekProc(instanceData, offset, mode, errorCodePtr)
+ ClientData instanceData; /* File state. */
+ Tcl_WideInt offset; /* Offset to seek to. */
+ int mode; /* Relative to where should we seek? */
+ int *errorCodePtr; /* To store error code. */
+{
+ FileInfo *infoPtr = (FileInfo *) instanceData;
+ DWORD moveMethod;
+ DWORD newPos, newPosHigh;
+
+ *errorCodePtr = 0;
+ if (mode == SEEK_SET) {
+ moveMethod = FILE_BEGIN;
+ } else if (mode == SEEK_CUR) {
+ moveMethod = FILE_CURRENT;
+ } else {
+ moveMethod = FILE_END;
+ }
+
+ newPosHigh = (DWORD)(offset >> 32);
+ newPos = SetFilePointer(infoPtr->handle, (LONG) offset, &newPosHigh,
+ moveMethod);
+ if (newPos == INVALID_SET_FILE_POINTER) {
+ int winError = GetLastError();
+ if (winError != NO_ERROR) {
+ TclWinConvertError(winError);
+ *errorCodePtr = errno;
+ return -1;
+ }
+ }
+ return ((Tcl_WideInt) newPos) | (((Tcl_WideInt) newPosHigh) << 32);
}
\f
/*
static int
FileOutputProc(instanceData, buf, toWrite, errorCode)
ClientData instanceData; /* File state. */
- char *buf; /* The data buffer. */
+ CONST char *buf; /* The data buffer. */
int toWrite; /* How many bytes to write? */
int *errorCode; /* Where to store error code. */
{
*errorCode = errno;
return -1;
}
- FlushFileBuffers(infoPtr->handle);
+ infoPtr->dirty = 1;
return bytesWritten;
}
\f
*/
Tcl_Channel
-TclpOpenFileChannel(interp, fileName, modeString, permissions)
+TclpOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
- char *fileName; /* Name of file to open. */
- char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
+ Tcl_Obj *pathPtr; /* Name of file to open. */
+ int mode; /* POSIX mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel channel = 0;
- int seekFlag, mode, channelPermissions;
+ int channelPermissions;
DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
- TCHAR *nativeName;
- Tcl_DString ds, buffer;
+ CONST TCHAR *nativeName;
DCB dcb;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL;
TclFile writeFile = NULL;
-#ifdef __CYGWIN__
- char winbuf[MAX_PATH];
-#endif
- mode = TclGetOpenMode(interp, modeString, &seekFlag);
- if (mode == -1) {
- return NULL;
- }
-
- if (Tcl_TranslateFileName(interp, fileName, &ds) == NULL) {
+ nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr);
+ if (nativeName == NULL) {
return NULL;
}
- nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds), &buffer);
-
-#ifdef __CYGWIN__
- /* In the Cygwin world, call conv_to_win32_path in order to use
- the mount table to translate the file name into something
- Windows will understand. */
- cygwin_conv_to_win32_path(nativeName, winbuf);
- Tcl_DStringFree(&buffer);
- Tcl_DStringAppend(&buffer, winbuf, -1);
-#endif
-
+
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
accessMode = GENERIC_READ;
}
TclWinConvertError(err);
if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
+ Tcl_AppendResult(interp, "couldn't open \"",
+ Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
- Tcl_DStringFree(&buffer);
return NULL;
}
switch (type) {
case FILE_TYPE_SERIAL:
+ /*
+ * Reopen channel for OVERLAPPED operation
+ * Normally this shouldn't fail, because the channel exists
+ */
+ handle = TclWinSerialReopen(handle, nativeName, accessMode);
+ if (handle == INVALID_HANDLE_VALUE) {
+ TclWinConvertError(GetLastError());
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp, "couldn't reopen serial \"",
+ Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return NULL;
+ }
channel = TclWinOpenSerialChannel(handle, channelName,
channelPermissions);
break;
*/
channel = NULL;
- Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
- "bad file type", (char *) NULL);
+ Tcl_AppendResult(interp, "couldn't open \"",
+ Tcl_GetString(pathPtr), "\": ",
+ "bad file type", (char *) NULL);
break;
}
- Tcl_DStringFree(&buffer);
- Tcl_DStringFree(&ds);
-
- if (channel != NULL) {
- if (seekFlag) {
- if (Tcl_Seek(channel, 0, SEEK_END) < 0) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp,
- "could not seek to end of file on \"",
- channelName, "\": ", Tcl_PosixError(interp),
- (char *) NULL);
- }
- Tcl_Close(NULL, channel);
- return NULL;
- }
- }
- }
return channel;
}
\f
char channelName[16 + TCL_INTEGER_SPACE];
Tcl_Channel channel = NULL;
HANDLE handle = (HANDLE) rawHandle;
+ HANDLE dupedHandle;
DCB dcb;
- DWORD consoleParams;
- DWORD type;
+ DWORD consoleParams, type;
TclFile readFile = NULL;
TclFile writeFile = NULL;
+ BOOL result;
if (mode == 0) {
return NULL;
}
+ /*
+ * GetFileType() returns FILE_TYPE_UNKNOWN for invalid handles.
+ */
+
type = GetFileType(handle);
/*
case FILE_TYPE_DISK:
case FILE_TYPE_CHAR:
- case FILE_TYPE_UNKNOWN:
channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
break;
+ case FILE_TYPE_UNKNOWN:
default:
/*
- * The handle is of an unknown type, probably /dev/nul equivalent
- * or possibly a closed handle.
+ * The handle is of an unknown type. Test the validity of this OS
+ * handle by duplicating it, then closing the dupe. The Win32 API
+ * doesn't provide an IsValidHandle() function, so we have to emulate
+ * it here. This test will not work on a console handle reliably,
+ * which is why we can't test every handle that comes into this
+ * function in this way.
*/
-
- channel = NULL;
- break;
+ result = DuplicateHandle(GetCurrentProcess(), handle,
+ GetCurrentProcess(), &dupedHandle, 0, FALSE,
+ DUPLICATE_SAME_ACCESS);
+
+ if (result != 0) {
+ /*
+ * Unable to make a duplicate. It's definately invalid at this
+ * point.
+ */
+
+ return NULL;
+ }
+
+ /*
+ * Use structured exception handling (Win32 SEH) to protect the close
+ * of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
+ */
+
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "movl %esp, _ESP" "\n\t"
+ "movl %ebp, _EBP");
+
+ __asm__ __volatile__ (
+ "pushl $__except_makefilechannel_handler" "\n\t"
+ "pushl %fs:0" "\n\t"
+ "mov %esp, %fs:0");
+
+ result = 0;
+#else
+ __try {
+#endif /* HAVE_NO_SEH */
+ CloseHandle(dupedHandle);
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "jmp makefilechannel_pop" "\n"
+ "makefilechannel_reentry:" "\n\t"
+ "movl _ESP, %esp" "\n\t"
+ "movl _EBP, %ebp");
+
+ result = 1; /* True when exception was raised */
+
+ __asm__ __volatile__ (
+ "makefilechannel_pop:" "\n\t"
+ "mov (%esp), %eax" "\n\t"
+ "mov %eax, %fs:0" "\n\t"
+ "add $8, %esp");
+
+ if (result)
+ return NULL;
+#else
+ }
+ __except (EXCEPTION_EXECUTE_HANDLER) {
+ /*
+ * Definately an invalid handle. So, therefore, the original
+ * is invalid also.
+ */
+
+ return NULL;
+ }
+#endif /* HAVE_NO_SEH */
+
+ /* Fall through, the handle is valid. */
+
+ /*
+ * Create the undefined channel, anyways, because we know the handle
+ * is valid to something.
+ */
+
+ channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
}
return channel;
}
+#ifdef HAVE_NO_SEH
+static
+__attribute__ ((cdecl))
+EXCEPTION_DISPOSITION
+_except_makefilechannel_handler(
+ struct _EXCEPTION_RECORD *ExceptionRecord,
+ void *EstablisherFrame,
+ struct _CONTEXT *ContextRecord,
+ void *DispatcherContext)
+{
+ __asm__ __volatile__ (
+ "jmp makefilechannel_reentry");
+ return 0; /* Function does not return */
+}
+#endif
\f
/*
*----------------------------------------------------------------------
char *bufMode;
DWORD handleId; /* Standard handle to retrieve. */
+
switch (type) {
case TCL_STDIN:
handleId = STD_INPUT_HANDLE;
* is not a console mode application, even though this is not a valid
* handle.
*/
-
+
if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) {
- return NULL;
+ return (Tcl_Channel) NULL;
}
-
+
channel = Tcl_MakeFileChannel(handle, mode);
if (channel == NULL) {
- return NULL;
+ return (Tcl_Channel) NULL;
}
/*
infoPtr->watchMask = 0;
infoPtr->flags = appendMode;
infoPtr->handle = handle;
-
+ infoPtr->dirty = 0;
wsprintfA(channelName, "file%lx", (int) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinFlushDirtyChannels --
+ *
+ * Flush all dirty channels to disk, so that requesting the
+ * size of any file returns the correct value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Information is actually written to disk now, rather than
+ * later. Don't call this too often, or there will be a
+ * performance hit (i.e. only call when we need to ask for
+ * the size of a file).
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclWinFlushDirtyChannels ()
+{
+ FileInfo *infoPtr;
+ ThreadSpecificData *tsdPtr;
+
+ tsdPtr = FileInit();
+
+ /*
+ * Flush all channels which are dirty, i.e. may have data pending
+ * in the OS
+ */
+
+ for (infoPtr = tsdPtr->firstFilePtr;
+ infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->dirty) {
+ FlushFileBuffers(infoPtr->handle);
+ infoPtr->dirty = 0;
+ }
+ }
+}
static ThreadSpecificData *ConsoleInit(void);
static int ConsoleInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
-static int ConsoleOutputProc(ClientData instanceData, char *buf,
- int toWrite, int *errorCode);
+static int ConsoleOutputProc(ClientData instanceData,
+ CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI ConsoleReaderThread(LPVOID arg);
static void ConsoleSetupProc(ClientData clientData, int flags);
static void ConsoleWatchProc(ClientData instanceData, int mask);
*/
if (consolePtr->writeThread) {
- WaitForSingleObject(consolePtr->writable, INFINITE);
+ if (consolePtr->toWrite) {
+ /*
+ * We only need to wait if there is something to write.
+ * This may prevent infinite wait on exit. [python bug 216289]
+ */
+ WaitForSingleObject(consolePtr->writable, INFINITE);
+ }
/*
* Forcibly terminate the background thread. We cannot rely on the
*/
if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) {
- memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
+ memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize);
bytesRead = bufSize;
infoPtr->offset += bufSize;
} else {
- memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
+ memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize);
bytesRead = infoPtr->bytesRead - infoPtr->offset;
/*
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
- char *buf, /* The data buffer. */
+ CONST char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc(toWrite);
+ infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
}
- memcpy(infoPtr->writeBuf, buf, toWrite);
+ memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->writable);
SetEvent(infoPtr->startWriter);
mask = 0;
if (infoPtr->watchMask & TCL_WRITABLE) {
if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
- mask = TCL_WRITABLE;
+ mask = TCL_WRITABLE;
}
}
* that are not KEY_EVENTs
*/
if (ReadConsole(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
- &infoPtr->bytesRead, NULL) != FALSE) {
+ (LPDWORD) &infoPtr->bytesRead, NULL) != FALSE) {
/*
* Data was stored in the buffer.
*/
return infoPtr->channel;
}
-
* to us by DdeInitialize. */
static int ddeIsServer = 0;
-#define TCL_DDE_VERSION "1.1"
+#define TCL_DDE_VERSION "1.2"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME "TclEval"
{
HSZ ddeTopic, ddeService;
HCONV ddeConv;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
DDE_EVAL
};
- static char *ddeCommands[] = {"servername", "execute", "poke",
+ static CONST char *ddeCommands[] = {"servername", "execute", "poke",
"request", "services", "eval",
(char *) NULL};
- static char *ddeOptions[] = {"-async", (char *) NULL};
+ static CONST char *ddeOptions[] = {"-async", (char *) NULL};
+ static CONST char *ddeReqOptions[] = {"-binary", (char *) NULL};
int index, argIndex;
- int async = 0;
+ int async = 0, binary = 0;
int result = TCL_OK;
HSZ ddeService = NULL;
HSZ ddeTopic = NULL;
switch (index) {
case DDE_SERVERNAME:
if ((objc != 3) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "servername ?serverName?");
+ Tcl_WrongNumArgs(interp, 1, objv, "servername ?serverName?");
return TCL_ERROR;
}
firstArg = (objc - 1);
firstArg = 2;
break;
case DDE_REQUEST:
- if (objc != 5) {
+ if ((objc < 5) || (objc > 6)) {
Tcl_WrongNumArgs(interp, 1, objv,
- "request serviceName topicName value");
+ "request ?-binary? serviceName topicName value");
return TCL_ERROR;
}
- firstArg = 2;
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0,
+ &argIndex) != TCL_OK) {
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "request ?-binary? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ binary = 0;
+ firstArg = 2;
+ } else {
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "request ?-binary? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ binary = 1;
+ firstArg = 3;
+ }
break;
case DDE_SERVICES:
if (objc != 4) {
result = TCL_ERROR;
break;
}
- hConv = DdeConnect(ddeInstance, ddeService, ddeTopic,
- NULL);
- DdeFreeStringHandle (ddeInstance, ddeService) ;
- DdeFreeStringHandle (ddeInstance, ddeTopic) ;
+ hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv,
- ddeResult);
+ ddeResult);
} else {
ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
return TCL_ERROR;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- DdeFreeStringHandle (ddeInstance, ddeService) ;
- DdeFreeStringHandle (ddeInstance, ddeTopic) ;
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
dataString = DdeAccessData(ddeData, &dataLength);
- returnObjPtr = Tcl_NewStringObj(dataString, -1);
+ if (binary) {
+ returnObjPtr = Tcl_NewByteArrayObj(dataString,
+ dataLength);
+ } else {
+ returnObjPtr = Tcl_NewStringObj(dataString, -1);
+ }
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
Tcl_SetObjResult(interp, returnObjPtr);
dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- DdeFreeStringHandle (ddeInstance,ddeService) ;
- DdeFreeStringHandle (ddeInstance, ddeTopic) ;
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
- ddeItem = DdeCreateStringHandle(ddeInstance, itemString, \
+ ddeItem = DdeCreateStringHandle(ddeInstance, itemString,
CP_WINANSI);
if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(dataString,length+1, \
- hConv, ddeItem,
- CF_TEXT, XTYP_POKE, 5000, NULL);
+ ddeData = DdeClientTransaction(dataString,length+1,
+ hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
convInfo.cb = sizeof(CONVINFO);
hConvList = DdeConnectList(ddeInstance, ddeService,
ddeTopic, 0, NULL);
- DdeFreeStringHandle (ddeInstance,ddeService) ;
- DdeFreeStringHandle (ddeInstance, ddeTopic) ;
+ DdeFreeStringHandle(ddeInstance,ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
hConv = 0;
convListObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_DStringInit(&dString);
length + 1, CP_WINANSI);
Tcl_ListObjAppendElement(interp, elementObjPtr,
Tcl_NewStringObj(name, length));
- Tcl_ListObjAppendElement(interp, convListObjPtr, elementObjPtr);
+ Tcl_ListObjAppendElement(interp, convListObjPtr,
+ elementObjPtr);
}
DdeDisconnectList(hConvList);
Tcl_SetObjResult(interp, convListObjPtr);
* deallocated objects.
*/
- for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr
- = riPtr->nextPtr) {
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
if (stricmp(serviceName, riPtr->name) == 0) {
break;
}
}
-
+
if (riPtr != NULL) {
/*
* This command is to a local interp. No need to go through
Tcl_Preserve((ClientData) sendInterp);
/*
- * Don't exchange objects between interps. The target interp would
- * compile an object, producing a bytecode structure that refers to
- * other objects owned by the target interp. If the target interp
- * is then deleted, the bytecode structure would be referring to
- * deallocated objects.
+ * Don't exchange objects between interps. The target interp
+ * would compile an object, producing a bytecode structure that
+ * refers to other objects owned by the target interp. If the
+ * target interp is then deleted, the bytecode structure would
+ * be referring to deallocated objects.
*/
if (objc == 1) {
- result = Tcl_EvalObjEx(sendInterp, objv[0], TCL_EVAL_GLOBAL);
+ result = Tcl_EvalObjEx(sendInterp, objv[0],
+ TCL_EVAL_GLOBAL);
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
- result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
+ result = Tcl_EvalObjEx(sendInterp, objPtr,
+ TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
}
if (interp != sendInterp) {
if (result == TCL_ERROR) {
/*
- * An error occurred, so transfer error information from the
- * destination interpreter back to our interpreter.
+ * An error occurred, so transfer error information
+ * from the destination interpreter back to our
+ * interpreter.
*/
Tcl_ResetResult(interp);
Tcl_Release((ClientData) sendInterp);
} else {
/*
- * This is a non-local request. Send the script to the server and poll
- * it for a result.
+ * This is a non-local request. Send the script to the server
+ * and poll it for a result.
*/
if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
objPtr = Tcl_ConcatObj(objc, objv);
string = Tcl_GetStringFromObj(objPtr, &length);
- ddeItemData = DdeCreateDataHandle(ddeInstance, string, length+1, 0, 0,
- CF_TEXT, 0);
+ ddeItemData = DdeCreateDataHandle(ddeInstance, string,
+ length+1, 0, 0, CF_TEXT, 0);
if (async) {
- ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
+ ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
+ 0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
- ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
+ ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
+ 0xFFFFFFFF, hConv, 0,
CF_TEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
ddeCookie = DdeCreateStringHandle(ddeInstance,
"$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
- ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
- CF_TEXT, XTYP_REQUEST, 30000, NULL);
+ ddeData = DdeClientTransaction(NULL, 0, hConv,
+ ddeCookie, CF_TEXT, XTYP_REQUEST, 30000, NULL);
}
}
-
-
+
Tcl_DecrRefCount(objPtr);
if (ddeData == 0) {
Tcl_Obj *resultPtr;
/*
- * The return handle has a two or four element list in it. The first
- * element is the return code (TCL_OK, TCL_ERROR, etc.). The
- * second is the result of the script. If the return code is TCL_ERROR,
- * then the third element is the value of the variable "errorCode",
- * and the fourth is the value of the variable "errorInfo".
+ * The return handle has a two or four element list in
+ * it. The first element is the return code (TCL_OK,
+ * TCL_ERROR, etc.). The second is the result of the
+ * script. If the return code is TCL_ERROR, then the third
+ * element is the value of the variable "errorCode", and
+ * the fourth is the value of the variable "errorInfo".
*/
resultPtr = Tcl_NewObj();
DdeGetData(ddeData, string, length, 0);
Tcl_SetObjLength(resultPtr, strlen(string));
- if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
+ if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr)
+ != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
goto error;
}
}
if (result == TCL_ERROR) {
Tcl_ResetResult(interp);
-
- if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr) != TCL_OK) {
+
+ if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr)
+ != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
goto error;
}
Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
Tcl_SetObjErrorCode(interp, objPtr);
}
- if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) {
+ if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr)
+ != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
goto error;
}
EINVAL, /* 124 */
EINVAL, /* 125 */
EINVAL, /* 126 */
- ESRCH, /* ERROR_PROC_NOT_FOUND 127 */
+ EINVAL, /* ERROR_PROC_NOT_FOUND 127 */
ECHILD, /* ERROR_WAIT_NO_CHILDREN 128 */
ECHILD, /* ERROR_CHILD_NOT_COMPLETE 129 */
EBADF, /* ERROR_DIRECT_ACCESS_HANDLE 130 */
- EINVAL, /* 131 */
+ EINVAL, /* ERROR_NEGATIVE_SEEK 131 */
ESPIPE, /* ERROR_SEEK_ON_DEVICE 132 */
EINVAL, /* 133 */
EINVAL, /* 134 */
Tcl_SetErrno(EINVAL);
}
}
-
-
*/
static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj **attributePtrPtr));
static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr));
static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
+ int objIndex, Tcl_Obj *fileName,
Tcl_Obj *attributePtr));
/*
0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
-char *tclpFileAttrStrings[] = {
+CONST char *tclpFileAttrStrings[] = {
"-archive", "-hidden", "-longname", "-readonly",
"-shortname", "-system", (char *) NULL
};
-const TclFileAttrProcs tclpFileAttrProcs[] = {
+CONST TclFileAttrProcs tclpFileAttrProcs[] = {
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileLongName, CannotSetAttribute},
{GetWinFileShortName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes}};
+#ifdef HAVE_NO_SEH
+static void *ESP;
+static void *EBP;
+#endif /* HAVE_NO_SEH */
+
/*
* Prototype for the TraverseWinTree callback function.
*/
-typedef int (TraversalProc)(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
+typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
/*
* Declarations for local procedures defined in this file:
*/
-static void StatError(Tcl_Interp *interp, CONST char *fileName);
+static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName);
static int ConvertFileNameFormat(Tcl_Interp *interp,
- int objIndex, CONST char *fileName, int longShort,
+ int objIndex, Tcl_Obj *fileName, int longShort,
Tcl_Obj **attributePtrPtr);
-static int DoCopyFile(Tcl_DString *srcPtr, Tcl_DString *dstPtr);
-static int DoCreateDirectory(Tcl_DString *pathPtr);
-static int DoDeleteFile(Tcl_DString *pathPtr);
+static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr);
+static int DoCreateDirectory(CONST TCHAR *pathPtr);
+static int DoDeleteFile(CONST TCHAR *pathPtr);
+static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc,
+ int ignoreError, Tcl_DString *errorPtr);
static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
Tcl_DString *errorPtr);
-static int DoRenameFile(const TCHAR *nativeSrc, Tcl_DString *dstPtr);
-static int TraversalCopy(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
+static int DoRenameFile(CONST TCHAR *nativeSrc, CONST TCHAR *dstPtr);
+static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
-static int TraversalDelete(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
+static int TraversalDelete(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
static int TraverseWinTree(TraversalProc *traverseProc,
Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
/*
*---------------------------------------------------------------------------
*
- * TclpRenameFile, DoRenameFile --
+ * TclpObjRenameFile, DoRenameFile --
*
* Changes the name of an existing file or directory, from src to dst.
* If src and dst refer to the same file or directory, does nothing
*---------------------------------------------------------------------------
*/
-int
-TclpRenameFile(
- CONST char *src, /* Pathname of file or dir to be renamed
- * (UTF-8). */
- CONST char *dst) /* New pathname of file or directory
- * (UTF-8). */
+int
+TclpObjRenameFile(srcPathPtr, destPathPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
{
- int result;
- TCHAR *nativeSrc;
- Tcl_DString srcString, dstString;
-
- nativeSrc = Tcl_WinUtfToTChar(src, -1, &srcString);
- Tcl_WinUtfToTChar(dst, -1, &dstString);
-
- result = DoRenameFile(nativeSrc, &dstString);
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
+ return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
- Tcl_DString *dstPtr) /* New pathname for file or directory
+ CONST TCHAR *nativeDst) /* New pathname for file or directory
* (native). */
{
- const TCHAR *nativeDst;
DWORD srcAttr, dstAttr;
+ int retval = -1;
+
+ /*
+ * The MoveFile API acts differently under Win95/98 and NT
+ * WRT NULL and "". Avoid passing these values.
+ */
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
+ if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
+ nativeDst == NULL || nativeDst[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
/*
- * Would throw an exception under NT if one of the arguments is a
- * char block device.
+ * The MoveFile API would throw an exception under NT
+ * if one of the arguments is a char block device.
*/
- /* CYGNUS LOCAL */
-#ifndef __GNUC__
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "movl %esp, _ESP" "\n\t"
+ "movl %ebp, _EBP");
+
+ __asm__ __volatile__ (
+ "pushl $__except_dorenamefile_handler" "\n\t"
+ "pushl %fs:0" "\n\t"
+ "mov %esp, %fs:0");
+#else
__try {
-#endif
+#endif /* HAVE_NO_SEH */
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
- return TCL_OK;
+ retval = TCL_OK;
}
- /* CYGNUS LOCAL */
-#ifndef __GNUC__
- } __except (-1) {}
-#endif
- /* END CYGNUS LOCAL */
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "jmp dorenamefile_pop" "\n"
+ "dorenamefile_reentry:" "\n\t"
+ "movl _ESP, %esp" "\n\t"
+ "movl _EBP, %ebp");
+
+ __asm__ __volatile__ (
+ "dorenamefile_pop:" "\n\t"
+ "mov (%esp), %eax" "\n\t"
+ "mov %eax, %fs:0" "\n\t"
+ "add $8, %esp");
+#else
+ } __except (EXCEPTION_EXECUTE_HANDLER) {}
+#endif /* HAVE_NO_SEH */
+
+ /*
+ * Avoid using control flow statements in the SEH guarded block!
+ */
+ if (retval != -1)
+ return retval;
TclWinConvertError(GetLastError());
* fails, it's because it wasn't empty.
*/
- if (DoRemoveDirectory(dstPtr, 0, NULL) == TCL_OK) {
+ if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
}
return TCL_ERROR;
}
+#ifdef HAVE_NO_SEH
+static
+__attribute__ ((cdecl))
+EXCEPTION_DISPOSITION
+_except_dorenamefile_handler(
+ struct _EXCEPTION_RECORD *ExceptionRecord,
+ void *EstablisherFrame,
+ struct _CONTEXT *ContextRecord,
+ void *DispatcherContext)
+{
+ __asm__ __volatile__ (
+ "jmp dorenamefile_reentry");
+ return 0; /* Function does not return */
+}
+#endif /* HAVE_NO_SEH */
\f
/*
*---------------------------------------------------------------------------
*
- * TclpCopyFile, DoCopyFile --
+ * TclpObjCopyFile, DoCopyFile --
*
* Copy a single file (not a directory). If dst already exists and
* is not a directory, it is removed.
*/
int
-TclpCopyFile(
- CONST char *src, /* Pathname of file to be copied (UTF-8). */
- CONST char *dst) /* Pathname of file to copy to (UTF-8). */
+TclpObjCopyFile(srcPathPtr, destPathPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_WinUtfToTChar(src, -1, &srcString);
- Tcl_WinUtfToTChar(dst, -1, &dstString);
- result = DoCopyFile(&srcString, &dstString);
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
+ return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr),
+ Tcl_FSGetNativePath(destPathPtr));
}
static int
DoCopyFile(
- Tcl_DString *srcPtr, /* Pathname of file to be copied (native). */
- Tcl_DString *dstPtr) /* Pathname of file to copy to (native). */
+ CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
+ CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
- CONST TCHAR *nativeSrc, *nativeDst;
+ int retval = -1;
- nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
+ /*
+ * The CopyFile API acts differently under Win95/98 and NT
+ * WRT NULL and "". Avoid passing these values.
+ */
+ if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
+ nativeDst == NULL || nativeDst[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
+
/*
- * Would throw an exception under NT if one of the arguments is a char
- * block device.
+ * The CopyFile API would throw an exception under NT if one
+ * of the arguments is a char block device.
*/
- /* CYGNUS LOCAL */
-#ifndef __GNUC__
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "movl %esp, _ESP" "\n\t"
+ "movl %ebp, _EBP");
+
+ __asm__ __volatile__ (
+ "pushl $__except_docopyfile_handler" "\n\t"
+ "pushl %fs:0" "\n\t"
+ "mov %esp, %fs:0");
+#else
__try {
+#endif /* HAVE_NO_SEH */
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
-#endif
- /* END CYGNUS LOCAL */
- return TCL_OK;
-#ifndef __GNUC__
+ retval = TCL_OK;
}
- /* CYGNUS LOCAL */
- } __except (-1) {}
-#endif
- /* END CYGNUS LOCAL */
+#ifdef HAVE_NO_SEH
+ __asm__ __volatile__ (
+ "jmp docopyfile_pop" "\n"
+ "docopyfile_reentry:" "\n\t"
+ "movl _ESP, %esp" "\n\t"
+ "movl _EBP, %ebp");
+
+ __asm__ __volatile__ (
+ "docopyfile_pop:" "\n\t"
+ "mov (%esp), %eax" "\n\t"
+ "mov %eax, %fs:0" "\n\t"
+ "add $8, %esp");
+#else
+ } __except (EXCEPTION_EXECUTE_HANDLER) {}
+#endif /* HAVE_NO_SEH */
+
+ /*
+ * Avoid using control flow statements in the SEH guarded block!
+ */
+ if (retval != -1)
+ return retval;
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EBADF) {
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
+ if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
+ /* Source is a symbolic link -- copy it */
+ if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
+ return TCL_OK;
+ }
+ }
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
}
return TCL_ERROR;
}
+#ifdef HAVE_NO_SEH
+static
+__attribute__ ((cdecl))
+EXCEPTION_DISPOSITION
+_except_docopyfile_handler(
+ struct _EXCEPTION_RECORD *ExceptionRecord,
+ void *EstablisherFrame,
+ struct _CONTEXT *ContextRecord,
+ void *DispatcherContext)
+{
+ __asm__ __volatile__ (
+ "jmp docopyfile_reentry");
+ return 0; /* Function does not return */
+}
+#endif /* HAVE_NO_SEH */
\f
/*
*---------------------------------------------------------------------------
*
- * TclpDeleteFile, DoDeleteFile --
+ * TclpObjDeleteFile, DoDeleteFile --
*
* Removes a single file (not a directory).
*
*---------------------------------------------------------------------------
*/
-int
-TclpDeleteFile(
- CONST char *path) /* Pathname of file to be removed (UTF-8). */
+int
+TclpObjDeleteFile(pathPtr)
+ Tcl_Obj *pathPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_WinUtfToTChar(path, -1, &pathString);
- result = DoDeleteFile(&pathString);
- Tcl_DStringFree(&pathString);
- return result;
+ return DoDeleteFile(Tcl_FSGetNativePath(pathPtr));
}
static int
DoDeleteFile(
- Tcl_DString *pathPtr) /* Pathname of file to be removed (native). */
+ CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
- CONST TCHAR *nativePath;
- nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
-
+ /*
+ * The DeleteFile API acts differently under Win95/98 and NT
+ * WRT NULL and "". Avoid passing these values.
+ */
+
+ if (nativePath == NULL || nativePath[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
+
if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
- /*
- * Win32s thinks that "" is the same as "." and then reports EISDIR
- * instead of ENOENT.
- */
-
- if (tclWinProcs->useWide) {
- if (((WCHAR *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- } else {
- if (((char *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- }
if (Tcl_GetErrno() == EACCES) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
- /*
+ if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
+ /* It is a symbolic link -- remove it */
+ if (TclWinSymLinkDelete(nativePath, 0) == 0) {
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * If we fall through here, it is a directory.
+ *
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
- (*tclWinProcs->setFileAttributesProc)(nativePath,
+ int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
attr & ~FILE_ATTRIBUTE_READONLY);
- if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
+ if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath)
+ != FALSE)) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
- (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
+ if (res != 0) {
+ (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
+ }
}
}
} else if (Tcl_GetErrno() == ENOENT) {
/*
*---------------------------------------------------------------------------
*
- * TclpCreateDirectory --
+ * TclpObjCreateDirectory --
*
* Creates the specified directory. All parent directories of the
* specified directory must already exist. The directory is
*---------------------------------------------------------------------------
*/
-int
-TclpCreateDirectory(
- CONST char *path) /* Pathname of directory to create (UTF-8). */
+int
+TclpObjCreateDirectory(pathPtr)
+ Tcl_Obj *pathPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_WinUtfToTChar(path, -1, &pathString);
- result = DoCreateDirectory(&pathString);
- Tcl_DStringFree(&pathString);
- return result;
+ return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
- Tcl_DString *pathPtr) /* Pathname of directory to create (native). */
+ CONST TCHAR *nativePath) /* Pathname of directory to create (native). */
{
DWORD error;
- CONST TCHAR *nativePath;
-
- nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
error = GetLastError();
TclWinConvertError(error);
/*
*---------------------------------------------------------------------------
*
- * TclpCopyDirectory --
+ * TclpObjCopyDirectory --
*
* Recursively copies a directory. The target directory dst must
* not already exist. Note that this function does not merge two
*---------------------------------------------------------------------------
*/
-int
-TclpCopyDirectory(
- CONST char *src, /* Pathname of directory to be copied
- * (UTF-8). */
- CONST char *dst, /* Pathname of target directory (UTF-8). */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+int
+TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
+ Tcl_Obj *srcPathPtr;
+ Tcl_Obj *destPathPtr;
+ Tcl_Obj **errorPtr;
{
- int result;
+ Tcl_DString ds;
Tcl_DString srcString, dstString;
+ int ret;
- Tcl_WinUtfToTChar(src, -1, &srcString);
- Tcl_WinUtfToTChar(dst, -1, &dstString);
+ Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL,srcPathPtr),
+ -1, &srcString);
+ Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL,destPathPtr),
+ -1, &dstString);
- result = TraverseWinTree(TraversalCopy, &srcString, &dstString, errorPtr);
+ ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
- return result;
+
+ if (ret != TCL_OK) {
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_DStringFree(&ds);
+ Tcl_IncrRefCount(*errorPtr);
+ }
+ return ret;
}
\f
/*
*----------------------------------------------------------------------
*
- * TclpRemoveDirectory, DoRemoveDirectory --
+ * TclpObjRemoveDirectory, DoRemoveDirectory --
*
* Removes directory (and its contents, if the recursive flag is set).
*
*----------------------------------------------------------------------
*/
-int
-TclpRemoveDirectory(
- CONST char *path, /* Pathname of directory to be removed
- * (UTF-8). */
- int recursive, /* If non-zero, removes directories that
- * are nonempty. Otherwise, will only remove
- * empty directories. */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
+int
+TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
+ Tcl_Obj *pathPtr;
+ int recursive;
+ Tcl_Obj **errorPtr;
{
- int result;
- Tcl_DString pathString;
-
- Tcl_WinUtfToTChar(path, -1, &pathString);
- result = DoRemoveDirectory(&pathString, recursive, errorPtr);
- Tcl_DStringFree(&pathString);
-
- return result;
+ Tcl_DString ds;
+ int ret;
+ if (recursive) {
+ /*
+ * In the recursive case, the string rep is used to construct a
+ * Tcl_DString which may be used extensively, so we can't
+ * optimize this case easily.
+ */
+ Tcl_DString native;
+ Tcl_WinUtfToTChar(Tcl_FSGetTranslatedStringPath(NULL, pathPtr),
+ -1, &native);
+ ret = DoRemoveDirectory(&native, recursive, &ds);
+ Tcl_DStringFree(&native);
+ } else {
+ ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr),
+ 0, &ds);
+ }
+ if (ret != TCL_OK) {
+ int len = Tcl_DStringLength(&ds);
+ if (len > 0) {
+ *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_IncrRefCount(*errorPtr);
+ }
+ Tcl_DStringFree(&ds);
+ }
+ return ret;
}
static int
-DoRemoveDirectory(
- Tcl_DString *pathPtr, /* Pathname of directory to be removed
+DoRemoveJustDirectory(
+ CONST TCHAR *nativePath, /* Pathname of directory to be removed
* (native). */
- int recursive, /* If non-zero, removes directories that
- * are nonempty. Otherwise, will only remove
- * empty directories. */
+ int ignoreError, /* If non-zero, don't initialize the
+ * errorPtr under some circumstances
+ * on return. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
- CONST TCHAR *nativePath;
- DWORD attr;
+ /*
+ * The RemoveDirectory API acts differently under Win95/98 and NT
+ * WRT NULL and "". Avoid passing these values.
+ */
- nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
+ if (nativePath == NULL || nativePath[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ goto end;
+ }
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
- /*
- * Win32s thinks that "" is the same as "." and then reports EACCES
- * instead of ENOENT.
- */
-
-
- if (tclWinProcs->useWide) {
- if (((WCHAR *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- } else {
- if (((char *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- }
if (Tcl_GetErrno() == EACCES) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
goto end;
}
+ if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
+ /* It is a symbolic link -- remove it */
+ if (TclWinSymLinkDelete(nativePath, 1) != 0) {
+ goto end;
+ }
+ }
+
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
*/
if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
- char *path, *find;
+ CONST char *path, *find;
HANDLE handle;
WIN32_FIND_DATAA data;
Tcl_DString buffer;
int len;
- path = (char *) nativePath;
+ path = (CONST char *) nativePath;
Tcl_DStringInit(&buffer);
len = strlen(path);
Tcl_SetErrno(EEXIST);
}
- if ((recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
- /*
- * The directory is nonempty, but the recursive flag has been
- * specified, so we recursively remove all the files in the directory.
+ if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) {
+ /*
+ * If we're being recursive, this error may actually
+ * be ok, so we don't want to initialise the errorPtr
+ * yet.
*/
-
- return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
+ return TCL_ERROR;
}
-
+
end:
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
}
return TCL_ERROR;
+
+}
+
+static int
+DoRemoveDirectory(
+ Tcl_DString *pathPtr, /* Pathname of directory to be removed
+ * (native). */
+ int recursive, /* If non-zero, removes directories that
+ * are nonempty. Otherwise, will only remove
+ * empty directories. */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
+ * DString filled with UTF-8 name of file
+ * causing error. */
+{
+ int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive,
+ errorPtr);
+
+ if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
+ /*
+ * The directory is nonempty, but the recursive flag has been
+ * specified, so we recursively remove all the files in the directory.
+ */
+ return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
+ } else {
+ return res;
+ }
}
\f
/*
Tcl_DString *sourcePtr, /* Pathname of source directory to be
* traversed (native). */
Tcl_DString *targetPtr, /* Pathname of directory to traverse in
- * parallel with source directory (native). */
+ * parallel with source directory (native),
+ * may be NULL. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
DWORD sourceAttr;
- TCHAR *nativeSource, *nativeErrfile;
+ TCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATAT data;
oldTargetLen = 0; /* lint. */
nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
+ nativeTarget = (TCHAR *) (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
+
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
if (sourceAttr == 0xffffffff) {
* Process the regular file
*/
- return (*traverseProc)(sourcePtr, targetPtr, DOTREE_F, errorPtr);
+ return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
if (tclWinProcs->useWide) {
nativeSource[oldSourceLen + 1] = '\0';
Tcl_DStringSetLength(sourcePtr, oldSourceLen);
- result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_PRED, errorPtr);
+ result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, errorPtr);
if (result != TCL_OK) {
FindClose(handle);
return result;
* files in that directory.
*/
- result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_POSTD,
- errorPtr);
+ result = (*traverseProc)(Tcl_DStringValue(sourcePtr),
+ (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)),
+ DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
static int
TraversalCopy(
- Tcl_DString *srcPtr, /* Source pathname to copy. */
- Tcl_DString *dstPtr, /* Destination pathname of copy. */
+ CONST TCHAR *nativeSrc, /* Source pathname to copy. */
+ CONST TCHAR *nativeDst, /* Destination pathname of copy. */
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
- TCHAR *nativeDst, *nativeSrc;
- DWORD attr;
-
switch (type) {
case DOTREE_F: {
- if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) {
+ if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) {
return TCL_OK;
}
break;
}
case DOTREE_PRED: {
- if (DoCreateDirectory(dstPtr) == TCL_OK) {
- nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
- attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
+ if (DoCreateDirectory(nativeDst) == TCL_OK) {
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
return TCL_OK;
}
*/
if (errorPtr != NULL) {
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
}
return TCL_ERROR;
static int
TraversalDelete(
- Tcl_DString *srcPtr, /* Source pathname to delete. */
- Tcl_DString *dstPtr, /* Not used. */
+ CONST TCHAR *nativeSrc, /* Source pathname to delete. */
+ CONST TCHAR *dstPtr, /* Not used. */
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
- TCHAR *nativeSrc;
-
switch (type) {
case DOTREE_F: {
- if (DoDeleteFile(srcPtr) == TCL_OK) {
+ if (DoDeleteFile(nativeSrc) == TCL_OK) {
return TCL_OK;
}
break;
return TCL_OK;
}
case DOTREE_POSTD: {
- if (DoRemoveDirectory(srcPtr, 0, NULL) == TCL_OK) {
+ if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
return TCL_OK;
}
break;
}
if (errorPtr != NULL) {
- nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
}
return TCL_ERROR;
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
- CONST char *fileName) /* The name of the file which caused the
+ Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName, "\": ", Tcl_PosixError(interp),
- (char *) NULL);
+ "could not read \"", Tcl_GetString(fileName),
+ "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
}
\f
/*
GetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
- Tcl_DString ds;
- TCHAR *nativeName;
-
- nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+ CONST TCHAR *nativeName;
+ int attr;
+
+ nativeName = Tcl_FSGetNativePath(fileName);
result = (*tclWinProcs->getFileAttributesProc)(nativeName);
- Tcl_DStringFree(&ds);
if (result == 0xffffffff) {
StatError(interp, fileName);
return TCL_ERROR;
}
- *attributePtrPtr = Tcl_NewBooleanObj((int) (result & attributeArray[objIndex]));
+ attr = (int)(result & attributeArray[objIndex]);
+ if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
+ /*
+ * It is hidden. However there is a bug on some Windows
+ * OSes in which root volumes (drives) formatted as NTFS
+ * are declared hidden when they are not (and cannot be).
+ *
+ * We test for, and fix that case, here.
+ */
+ int len;
+ char *str = Tcl_GetStringFromObj(fileName,&len);
+ if (len < 4) {
+ if (len == 0) {
+ /*
+ * Not sure if this is possible, but we pass it on
+ * anyway
+ */
+ } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) {
+ /* Path is pointing to the root volume */
+ attr = 0;
+ } else if ((str[1] == ':')
+ && (len == 2 || (str[2] == '/' || str[2] == '\\'))) {
+ /* Path is of the form 'x:' or 'x:/' or 'x:\' */
+ attr = 0;
+ }
+ }
+ }
+ *attributePtrPtr = Tcl_NewBooleanObj(attr);
return TCL_OK;
}
\f
* Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object
* will have ref count 0. If the return value is not TCL_OK,
* attributePtrPtr is not touched.
+ *
+ * Warning: if you pass this function a drive name like 'c:' it
+ * will actually return the current working directory on that
+ * drive. To avoid this, make sure the drive name ends in a
+ * slash, like this 'c:/'.
*
* Side effects:
* A new object is allocated if the file is valid.
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int pathc, i;
- char **pathv, **newv;
- char *resultStr;
- Tcl_DString resultDString;
+ Tcl_Obj *splitPath;
int result = TCL_OK;
- Tcl_SplitPath(fileName, &pathc, &pathv);
- newv = (char **) ckalloc(pathc * sizeof(char *));
+ splitPath = Tcl_FSSplitPath(fileName, &pathc);
- if (pathc == 0) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName,
+ if (splitPath == NULL || pathc == 0) {
+ if (interp != NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "could not read \"", Tcl_GetString(fileName),
"\": no such file or directory",
(char *) NULL);
+ }
result = TCL_ERROR;
goto cleanup;
}
for (i = 0; i < pathc; i++) {
- if ((pathv[i][0] == '/')
- || ((strlen(pathv[i]) == 3) && (pathv[i][1] == ':'))
- || (strcmp(pathv[i], ".") == 0)
- || (strcmp(pathv[i], "..") == 0)) {
+ Tcl_Obj *elt;
+ char *pathv;
+ int pathLen;
+ Tcl_ListObjIndex(NULL, splitPath, i, &elt);
+
+ pathv = Tcl_GetStringFromObj(elt, &pathLen);
+ if ((pathv[0] == '/')
+ || ((pathLen == 3) && (pathv[1] == ':'))
+ || (strcmp(pathv, ".") == 0)
+ || (strcmp(pathv, "..") == 0)) {
/*
* Handle "/", "//machine/export", "c:/", "." or ".." by just
* copying the string literally. Uppercase the drive letter,
*/
simple:
- pathv[i][0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[i][0]));
- newv[i] = (char *) ckalloc(strlen(pathv[i]) + 1);
- lstrcpyA(newv[i], pathv[i]);
+ /* Here we are modifying the string representation in place */
+ /* I believe this is legal, since this won't affect any
+ * file representation this thing may have. */
+ pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
- char *str;
- TCHAR *nativeName;
+ Tcl_Obj *tempPath;
Tcl_DString ds;
+ Tcl_DString dsTemp;
+ TCHAR *nativeName;
+ char *tempString;
+ int tempLen;
WIN32_FIND_DATAT data;
HANDLE handle;
DWORD attr;
- Tcl_DStringInit(&resultDString);
- str = Tcl_JoinPath(i + 1, pathv, &resultDString);
- nativeName = Tcl_WinUtfToTChar(str, -1, &ds);
+ tempPath = Tcl_FSJoinPath(splitPath, i+1);
+ Tcl_IncrRefCount(tempPath);
+ /*
+ * We'd like to call Tcl_FSGetNativePath(tempPath)
+ * but that is likely to lead to infinite loops
+ */
+ Tcl_DStringInit(&ds);
+ tempString = Tcl_GetStringFromObj(tempPath,&tempLen);
+ nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds);
+ Tcl_DecrRefCount(tempPath);
handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_DStringFree(&ds);
- Tcl_DStringFree(&resultDString);
-
goto simple;
}
}
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&resultDString);
if (handle == INVALID_HANDLE_VALUE) {
- pathc = i - 1;
- StatError(interp, fileName);
+ Tcl_DStringFree(&ds);
+ if (interp != NULL) {
+ StatError(interp, fileName);
+ }
result = TCL_ERROR;
goto cleanup;
}
* fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
*/
- Tcl_WinTCharToUtf(nativeName, -1, &ds);
- newv[i] = ckalloc((unsigned int) (Tcl_DStringLength(&ds) + 1));
- lstrcpyA(newv[i], Tcl_DStringValue(&ds));
+ Tcl_DStringInit(&dsTemp);
+ Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
+ /* Deal with issues of tildes being absolute */
+ if (Tcl_DStringValue(&dsTemp)[0] == '~') {
+ tempPath = Tcl_NewStringObj("./",2);
+ Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
+ Tcl_DStringLength(&dsTemp));
+ } else {
+ tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
+ Tcl_DStringLength(&dsTemp));
+ }
+ Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&dsTemp);
FindClose(handle);
}
}
- Tcl_DStringInit(&resultDString);
- resultStr = Tcl_JoinPath(pathc, newv, &resultDString);
- *attributePtrPtr = Tcl_NewStringObj(resultStr,
- Tcl_DStringLength(&resultDString));
- Tcl_DStringFree(&resultDString);
+ *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
cleanup:
- for (i = 0; i < pathc; i++) {
- ckfree(newv[i]);
+ if (splitPath != NULL) {
+ Tcl_DecrRefCount(splitPath);
}
- ckfree((char *) newv);
- ckfree((char *) pathv);
+
return result;
}
\f
*
* GetWinFileLongName --
*
- * Returns a Tcl_Obj containing the short version of the file
+ * Returns a Tcl_Obj containing the long version of the file
* name.
*
* Results:
GetWinFileLongName(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
GetWinFileShortName(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
SetWinFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes;
int yesNo;
int result;
- Tcl_DString ds;
- TCHAR *nativeName;
+ CONST TCHAR *nativeName;
- nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+ nativeName = Tcl_FSGetNativePath(fileName);
fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
if (fileAttributes == 0xffffffff) {
StatError(interp, fileName);
- result = TCL_ERROR;
- goto end;
+ return TCL_ERROR;
}
result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
if (result != TCL_OK) {
- goto end;
+ return result;
}
if (yesNo) {
if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
StatError(interp, fileName);
- result = TCL_ERROR;
- goto end;
+ return TCL_ERROR;
}
- end:
- Tcl_DStringFree(&ds);
-
return result;
}
\f
* TCL_ERROR
*
* Side effects:
- * The object result is set to a pertinant error message.
+ * The object result is set to a pertinent error message.
*
*----------------------------------------------------------------------
*/
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot set attribute \"", tclpFileAttrStrings[objIndex],
- "\" for file \"", fileName, "\": attribute is readonly",
+ "\" for file \"", Tcl_GetString(fileName),
+ "\": attribute is readonly",
(char *) NULL);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
- * TclpListVolumes --
+ * TclpObjListVolumes --
*
* Lists the currently mounted volumes
*
* Results:
- * A standard Tcl result. Will always be TCL_OK, since there is no way
- * that this command can fail. Also, the interpreter's result is set to
- * the list of volumes.
+ * The list of volumes.
*
* Side effects:
* None
*---------------------------------------------------------------------------
*/
-int
-TclpListVolumes(
- Tcl_Interp *interp) /* Interpreter for returning volume list. */
+Tcl_Obj*
+TclpObjListVolumes(void)
{
Tcl_Obj *resultPtr, *elemPtr;
char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
int i;
char *p;
- resultPtr = Tcl_GetObjResult(interp);
+ resultPtr = Tcl_NewObj();
/*
* On Win32s:
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
- return TCL_OK;
+
+ Tcl_IncrRefCount(resultPtr);
+ return resultPtr;
}
-
-
-
* RCS: @(#) $Id$
*/
+//#define _WIN32_WINNT 0x0500
+
#include "tclWinInt.h"
+#include <winioctl.h>
#include <sys/stat.h>
-
#include <shlobj.h>
#include <lmaccess.h> /* For TclpGetUserHome(). */
+/*
+ * Declarations for 'link' related information. This information
+ * should come with VC++ 6.0, but is not in some older SDKs.
+ * In any case it is not well documented.
+ */
+#ifndef IO_REPARSE_TAG_RESERVED_ONE
+# define IO_REPARSE_TAG_RESERVED_ONE 0x000000001
+#endif
+#ifndef IO_REPARSE_TAG_RESERVED_RANGE
+# define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001
+#endif
+#ifndef IO_REPARSE_TAG_VALID_VALUES
+# define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF
+#endif
+#ifndef IO_REPARSE_TAG_HSM
+# define IO_REPARSE_TAG_HSM 0x0C0000004
+#endif
+#ifndef IO_REPARSE_TAG_NSS
+# define IO_REPARSE_TAG_NSS 0x080000005
+#endif
+#ifndef IO_REPARSE_TAG_NSSRECOVER
+# define IO_REPARSE_TAG_NSSRECOVER 0x080000006
+#endif
+#ifndef IO_REPARSE_TAG_SIS
+# define IO_REPARSE_TAG_SIS 0x080000007
+#endif
+#ifndef IO_REPARSE_TAG_DFS
+# define IO_REPARSE_TAG_DFS 0x080000008
+#endif
+
+#ifndef IO_REPARSE_TAG_RESERVED_ZERO
+# define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000
+#endif
+#ifndef FILE_FLAG_OPEN_REPARSE_POINT
+# define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000
+#endif
+#ifndef IO_REPARSE_TAG_MOUNT_POINT
+# define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003
+#endif
+#ifndef IsReparseTagValid
+# define IsReparseTagValid(x) (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
+#endif
+#ifndef IO_REPARSE_TAG_SYMBOLIC_LINK
+# define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO
+#endif
+#ifndef FILE_SPECIAL_ACCESS
+# define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS)
+#endif
+#ifndef FSCTL_SET_REPARSE_POINT
+# define FSCTL_SET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
+# define FSCTL_GET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS)
+# define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS)
+#endif
+
+/*
+ * Maximum reparse buffer info size. The max user defined reparse
+ * data is 16KB, plus there's a header.
+ */
+
+#define MAX_REPARSE_SIZE 17000
+
+/*
+ * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition.
+ * This is found in winnt.h.
+ *
+ * IMPORTANT: caution when using this structure, since the actual
+ * structures used will want to store a full path in the 'PathBuffer'
+ * field, but there isn't room (there's only a single WCHAR!). Therefore
+ * one must artificially create a larger space of memory and then cast it
+ * to this type. We use the 'DUMMY_REPARSE_BUFFER' struct just below to
+ * deal with this problem.
+ */
+
+#define REPARSE_MOUNTPOINT_HEADER_SIZE 8
+#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
+typedef struct _REPARSE_DATA_BUFFER {
+ DWORD ReparseTag;
+ WORD ReparseDataLength;
+ WORD Reserved;
+ union {
+ struct {
+ WORD SubstituteNameOffset;
+ WORD SubstituteNameLength;
+ WORD PrintNameOffset;
+ WORD PrintNameLength;
+ WCHAR PathBuffer[1];
+ } SymbolicLinkReparseBuffer;
+ struct {
+ WORD SubstituteNameOffset;
+ WORD SubstituteNameLength;
+ WORD PrintNameOffset;
+ WORD PrintNameLength;
+ WCHAR PathBuffer[1];
+ } MountPointReparseBuffer;
+ struct {
+ BYTE DataBuffer[1];
+ } GenericReparseBuffer;
+ };
+} REPARSE_DATA_BUFFER;
+#endif
+
+typedef struct {
+ REPARSE_DATA_BUFFER dummy;
+ WCHAR dummyBuf[MAX_PATH*3];
+} DUMMY_REPARSE_BUFFER;
+
+/* Other typedefs required by this code */
+
static time_t ToCTime(FILETIME fileTime);
typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
(LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
+/*
+ * Declarations for local procedures defined in this file:
+ */
+
+static int NativeAccess(CONST TCHAR *path, int mode);
+static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks);
+static int NativeIsExec(CONST TCHAR *path);
+static int NativeReadReparse(CONST TCHAR* LinkDirectory,
+ REPARSE_DATA_BUFFER* buffer);
+static int NativeWriteReparse(CONST TCHAR* LinkDirectory,
+ REPARSE_DATA_BUFFER* buffer);
+static int NativeMatchType(CONST char *name, int nameLen,
+ CONST TCHAR* nativeName, Tcl_GlobTypeData *types);
+static int WinIsDrive(CONST char *name, int nameLen);
+static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource);
+static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory);
+static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget,
+ int linkAction);
+static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory,
+ CONST TCHAR* LinkTarget);
+
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * WinLink
+ *
+ * Make a link from source to target.
+ *--------------------------------------------------------------------
+ */
+static int
+WinLink(LinkSource, LinkTarget, linkAction)
+ CONST TCHAR* LinkSource;
+ CONST TCHAR* LinkTarget;
+ int linkAction;
+{
+ WCHAR tempFileName[MAX_PATH];
+ TCHAR* tempFilePart;
+ int attr;
+
+ /* Get the full path referenced by the target */
+ if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget,
+ MAX_PATH, tempFileName, &tempFilePart)) {
+ /* Invalid file */
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+
+ /* Make sure source file doesn't exist */
+ attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
+ if (attr != 0xffffffff) {
+ Tcl_SetErrno(EEXIST);
+ return -1;
+ }
+
+ /* Get the full path referenced by the directory */
+ if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
+ MAX_PATH, tempFileName, &tempFilePart)) {
+ /* Invalid file */
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ /* Check the target */
+ attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget);
+ if (attr == 0xffffffff) {
+ /* The target doesn't exist */
+ TclWinConvertError(GetLastError());
+ return -1;
+ } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
+ /* It is a file */
+ if (tclWinProcs->createHardLinkProc == NULL) {
+ Tcl_SetErrno(ENOTDIR);
+ return -1;
+ }
+ if (linkAction & TCL_CREATE_HARD_LINK) {
+ if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ return 0;
+ } else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ /* Can't symlink files */
+ Tcl_SetErrno(ENOTDIR);
+ return -1;
+ } else {
+ Tcl_SetErrno(ENODEV);
+ return -1;
+ }
+ } else {
+ if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
+ return WinSymLinkDirectory(LinkSource, LinkTarget);
+ } else if (linkAction & TCL_CREATE_HARD_LINK) {
+ /* Can't hard link directories */
+ Tcl_SetErrno(EISDIR);
+ return -1;
+ } else {
+ Tcl_SetErrno(ENODEV);
+ return -1;
+ }
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * WinReadLink
+ *
+ * What does 'LinkSource' point to? We need the original 'pathPtr'
+ * just so we can construct a path object in the correct filesystem.
+ *--------------------------------------------------------------------
+ */
+static Tcl_Obj*
+WinReadLink(LinkSource)
+ CONST TCHAR* LinkSource;
+{
+ WCHAR tempFileName[MAX_PATH];
+ TCHAR* tempFilePart;
+ int attr;
+
+ /* Get the full path referenced by the target */
+ if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
+ MAX_PATH, tempFileName, &tempFilePart)) {
+ /* Invalid file */
+ TclWinConvertError(GetLastError());
+ return NULL;
+ }
+
+ /* Make sure source file does exist */
+ attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
+ if (attr == 0xffffffff) {
+ /* The source doesn't exist */
+ TclWinConvertError(GetLastError());
+ return NULL;
+ } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
+ /* It is a file - this is not yet supported */
+ Tcl_SetErrno(ENOTDIR);
+ return NULL;
+ } else {
+ return WinReadLinkDirectory(LinkSource);
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * WinSymLinkDirectory
+ *
+ * This routine creates a NTFS junction, using the undocumented
+ * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points
+ * and junctions.
+ *
+ * Assumption that LinkTarget is a valid, existing directory.
+ *
+ * Returns zero on success.
+ *--------------------------------------------------------------------
+ */
+static int
+WinSymLinkDirectory(LinkDirectory, LinkTarget)
+ CONST TCHAR* LinkDirectory;
+ CONST TCHAR* LinkTarget;
+{
+ DUMMY_REPARSE_BUFFER dummy;
+ REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
+ int len;
+ WCHAR nativeTarget[MAX_PATH];
+ WCHAR *loop;
+
+ /* Make the native target name */
+ memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR));
+ memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget,
+ sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget)));
+ len = wcslen(nativeTarget);
+ /*
+ * We must have backslashes only. This is VERY IMPORTANT.
+ * If we have any forward slashes everything appears to work,
+ * but the resulting symlink is useless!
+ */
+ for (loop = nativeTarget; *loop != 0; loop++) {
+ if (*loop == L'/') *loop = L'\\';
+ }
+ if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) {
+ nativeTarget[len-1] = 0;
+ }
+
+ /* Build the reparse info */
+ memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
+ reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
+ reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength =
+ wcslen(nativeTarget) * sizeof(WCHAR);
+ reparseBuffer->Reserved = 0;
+ reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0;
+ reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset =
+ reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength
+ + sizeof(WCHAR);
+ memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget,
+ sizeof(WCHAR)
+ + reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
+ reparseBuffer->ReparseDataLength =
+ reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;
+
+ return NativeWriteReparse(LinkDirectory, reparseBuffer);
+}
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * TclWinSymLinkCopyDirectory
+ *
+ * Copy a Windows NTFS junction. This function assumes that
+ * LinkOriginal exists and is a valid junction point, and that
+ * LinkCopy does not exist.
+ *
+ * Returns zero on success.
+ *--------------------------------------------------------------------
+ */
+int
+TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
+ CONST TCHAR* LinkOriginal; /* Existing junction - reparse point */
+ CONST TCHAR* LinkCopy; /* Will become a duplicate junction */
+{
+ DUMMY_REPARSE_BUFFER dummy;
+ REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
+
+ if (NativeReadReparse(LinkOriginal, reparseBuffer)) {
+ return -1;
+ }
+ return NativeWriteReparse(LinkCopy, reparseBuffer);
+}
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * TclWinSymLinkDelete
+ *
+ * Delete a Windows NTFS junction. Once the junction information
+ * is deleted, the filesystem object becomes an ordinary directory.
+ * Unless 'linkOnly' is given, that directory is also removed.
+ *
+ * Assumption that LinkOriginal is a valid, existing junction.
+ *
+ * Returns zero on success.
+ *--------------------------------------------------------------------
+ */
+int
+TclWinSymLinkDelete(LinkOriginal, linkOnly)
+ CONST TCHAR* LinkOriginal;
+ int linkOnly;
+{
+ /* It is a symbolic link -- remove it */
+ DUMMY_REPARSE_BUFFER dummy;
+ REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
+ HANDLE hFile;
+ int returnedLength;
+ memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
+ reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
+ hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0,
+ NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ if (hFile != INVALID_HANDLE_VALUE) {
+ if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
+ REPARSE_MOUNTPOINT_HEADER_SIZE,
+ NULL, 0, &returnedLength, NULL)) {
+ /* Error setting junction */
+ TclWinConvertError(GetLastError());
+ CloseHandle(hFile);
+ } else {
+ CloseHandle(hFile);
+ if (!linkOnly) {
+ (*tclWinProcs->removeDirectoryProc)(LinkOriginal);
+ }
+ return 0;
+ }
+ }
+ return -1;
+}
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * WinReadLinkDirectory
+ *
+ * This routine reads a NTFS junction, using the undocumented
+ * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points
+ * and junctions.
+ *
+ * Assumption that LinkDirectory is a valid, existing directory.
+ *
+ * Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller).
+ *--------------------------------------------------------------------
+ */
+static Tcl_Obj*
+WinReadLinkDirectory(LinkDirectory)
+ CONST TCHAR* LinkDirectory;
+{
+ int attr;
+ DUMMY_REPARSE_BUFFER dummy;
+ REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
+
+ attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory);
+ if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
+ Tcl_SetErrno(EINVAL);
+ return NULL;
+ }
+ if (NativeReadReparse(LinkDirectory, reparseBuffer)) {
+ return NULL;
+ }
+
+ switch (reparseBuffer->ReparseTag) {
+ case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
+ case IO_REPARSE_TAG_SYMBOLIC_LINK:
+ case IO_REPARSE_TAG_MOUNT_POINT: {
+ Tcl_Obj *retVal;
+ Tcl_DString ds;
+ CONST char *copy;
+ int len;
+
+ Tcl_WinTCharToUtf(
+ (CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
+ (int)reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength,
+ &ds);
+
+ copy = Tcl_DStringValue(&ds);
+ len = Tcl_DStringLength(&ds);
+ /*
+ * Certain native path representations on Windows have this special
+ * prefix to indicate that they are to be treated specially. For
+ * example extremely long paths, or symlinks
+ */
+ if (*copy == '\\') {
+ if (0 == strncmp(copy,"\\??\\",4)) {
+ copy += 4;
+ len -= 4;
+ } else if (0 == strncmp(copy,"\\\\?\\",4)) {
+ copy += 4;
+ len -= 4;
+ }
+ }
+ retVal = Tcl_NewStringObj(copy,len);
+ Tcl_IncrRefCount(retVal);
+ Tcl_DStringFree(&ds);
+ return retVal;
+ }
+ }
+ Tcl_SetErrno(EINVAL);
+ return NULL;
+}
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * NativeReadReparse
+ *
+ * Read the junction/reparse information from a given NTFS directory.
+ *
+ * Assumption that LinkDirectory is a valid, existing directory.
+ *
+ * Returns zero on success.
+ *--------------------------------------------------------------------
+ */
+static int
+NativeReadReparse(LinkDirectory, buffer)
+ CONST TCHAR* LinkDirectory; /* The junction to read */
+ REPARSE_DATA_BUFFER* buffer; /* Pointer to buffer. Cannot be NULL */
+{
+ HANDLE hFile;
+ int returnedLength;
+
+ hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0,
+ NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ if (hFile == INVALID_HANDLE_VALUE) {
+ /* Error creating directory */
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ /* Get the link */
+ if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL,
+ 0, buffer, sizeof(DUMMY_REPARSE_BUFFER),
+ &returnedLength, NULL)) {
+ /* Error setting junction */
+ TclWinConvertError(GetLastError());
+ CloseHandle(hFile);
+ return -1;
+ }
+ CloseHandle(hFile);
+
+ if (!IsReparseTagValid(buffer->ReparseTag)) {
+ Tcl_SetErrno(EINVAL);
+ return -1;
+ }
+ return 0;
+}
+\f
+/*
+ *--------------------------------------------------------------------
+ *
+ * NativeWriteReparse
+ *
+ * Write the reparse information for a given directory.
+ *
+ * Assumption that LinkDirectory does not exist.
+ *--------------------------------------------------------------------
+ */
+static int
+NativeWriteReparse(LinkDirectory, buffer)
+ CONST TCHAR* LinkDirectory;
+ REPARSE_DATA_BUFFER* buffer;
+{
+ HANDLE hFile;
+ int returnedLength;
+
+ /* Create the directory - it must not already exist */
+ if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) {
+ /* Error creating directory */
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0,
+ NULL, OPEN_EXISTING,
+ FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
+ if (hFile == INVALID_HANDLE_VALUE) {
+ /* Error creating directory */
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ /* Set the link */
+ if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer,
+ buffer->ReparseDataLength
+ + REPARSE_MOUNTPOINT_HEADER_SIZE,
+ NULL, 0, &returnedLength, NULL)) {
+ /* Error setting junction */
+ TclWinConvertError(GetLastError());
+ CloseHandle(hFile);
+ (*tclWinProcs->removeDirectoryProc)(LinkDirectory);
+ return -1;
+ }
+ CloseHandle(hFile);
+ /* We succeeded */
+ return 0;
+}
\f
/*
*---------------------------------------------------------------------------
*/
(*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
- Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds);
+ Tcl_WinTCharToUtf((CONST TCHAR *) wName, -1, &ds);
tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
/*
*----------------------------------------------------------------------
*
- * TclpMatchFilesTypes --
+ * TclpMatchInDirectory --
*
* This routine is used by the globbing code to search a
* directory for all files which match a given pattern.
*
* Results:
- * If the tail argument is NULL, then the matching files are
- * added to the the interp's result. Otherwise, TclDoGlob is called
- * recursively for each matching subdirectory. The return value
- * is a standard Tcl result indicating whether an error occurred
- * in globbing.
+ *
+ * The return value is a standard Tcl result indicating whether an
+ * error occurred in globbing. Errors are left in interp, good
+ * results are lappended to resultPtr (which must be a valid object)
*
* Side effects:
* None.
*---------------------------------------------------------------------- */
int
-TclpMatchFilesTypes(
- Tcl_Interp *interp, /* Interpreter to receive results. */
- char *separators, /* Directory separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr, /* Contains path to directory to search. */
- char *pattern, /* Pattern to match against. */
- char *tail, /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static.*/
- GlobTypeData *types) /* Object containing list of acceptable types.
- * May be NULL. */
+TclpMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
+ Tcl_Interp *interp; /* Interpreter to receive errors. */
+ Tcl_Obj *resultPtr; /* List object to lappend results. */
+ Tcl_Obj *pathPtr; /* Contains path to directory to search. */
+ CONST char *pattern; /* Pattern to match against. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. In particular the directory
+ * flag is very important. */
{
- char drivePat[] = "?:\\";
- const char *message;
- char *dir, *newPattern, *root;
- int matchDotFiles;
- int dirLength, result = TCL_OK;
- Tcl_DString dirString, patternString;
- DWORD attr, volFlags;
- HANDLE handle;
- WIN32_FIND_DATAT data;
- BOOL found;
- Tcl_DString ds;
- TCHAR *nativeName;
- Tcl_Obj *resultPtr;
+ CONST TCHAR *nativeName;
+
+ if (pattern == NULL || (*pattern == '\0')) {
+ Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ if (norm != NULL) {
+ int len;
+ char *str = Tcl_GetStringFromObj(norm,&len);
+ /* Match a file directly */
+ nativeName = (CONST TCHAR*) Tcl_FSGetNativePath(pathPtr);
+ if (NativeMatchType(str, len, nativeName, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
+ }
+ }
+ return TCL_OK;
+ } else {
+ char drivePat[] = "?:\\";
+ const char *message;
+ CONST char *dir;
+ char *root;
+ int dirLength;
+ Tcl_DString dirString;
+ DWORD attr, volFlags;
+ HANDLE handle;
+ WIN32_FIND_DATAT data;
+ BOOL found;
+ Tcl_DString ds;
+ Tcl_DString dsOrig;
+ Tcl_Obj *fileNamePtr;
+ int matchSpecialDots;
+
+ /*
+ * Convert the path to normalized form since some interfaces only
+ * accept backslashes. Also, ensure that the directory ends with a
+ * separator character.
+ */
- /*
- * Convert the path to normalized form since some interfaces only
- * accept backslashes. Also, ensure that the directory ends with a
- * separator character.
- */
+ fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
+ if (fileNamePtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_DStringInit(&dsOrig);
+ Tcl_DStringAppend(&dsOrig, Tcl_GetString(fileNamePtr), -1);
- dirLength = Tcl_DStringLength(dirPtr);
- Tcl_DStringInit(&dirString);
- if (dirLength == 0) {
- Tcl_DStringAppend(&dirString, ".\\", 2);
- } else {
- char *p;
+ dirLength = Tcl_DStringLength(&dsOrig);
+ Tcl_DStringInit(&dirString);
+ if (dirLength == 0) {
+ Tcl_DStringAppend(&dirString, ".\\", 2);
+ } else {
+ char *p;
- Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr),
- Tcl_DStringLength(dirPtr));
- for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
- if (*p == '/') {
- *p = '\\';
+ Tcl_DStringAppend(&dirString, Tcl_DStringValue(&dsOrig),
+ Tcl_DStringLength(&dsOrig));
+ for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
+ if (*p == '/') {
+ *p = '\\';
+ }
+ }
+ p--;
+ /* Make sure we have a trailing directory delimiter */
+ if ((*p != '\\') && (*p != ':')) {
+ Tcl_DStringAppend(&dirString, "\\", 1);
+ Tcl_DStringAppend(&dsOrig, "/", 1);
+ dirLength++;
}
}
- p--;
- if ((*p != '\\') && (*p != ':')) {
- Tcl_DStringAppend(&dirString, "\\", 1);
- }
- }
- dir = Tcl_DStringValue(&dirString);
+ dir = Tcl_DStringValue(&dirString);
- /*
- * First verify that the specified path is actually a directory.
- */
+ /*
+ * First verify that the specified path is actually a directory.
+ */
- nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
- Tcl_DStringFree(&ds);
+ nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ Tcl_DStringFree(&ds);
- if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
- Tcl_DStringFree(&dirString);
- return TCL_OK;
- }
+ if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
+ Tcl_DStringFree(&dirString);
+ return TCL_OK;
+ }
- /*
- * Next check the volume information for the directory to see whether
- * comparisons should be case sensitive or not. If the root is null, then
- * we use the root of the current directory. If the root is just a drive
- * specifier, we use the root directory of the given drive.
- */
+ /*
+ * Next check the volume information for the directory to see
+ * whether comparisons should be case sensitive or not. If the
+ * root is null, then we use the root of the current directory.
+ * If the root is just a drive specifier, we use the root
+ * directory of the given drive.
+ */
- switch (Tcl_GetPathType(dir)) {
- case TCL_PATH_RELATIVE:
- found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
- &volFlags, NULL, 0);
- break;
- case TCL_PATH_VOLUME_RELATIVE:
- if (dir[0] == '\\') {
- root = NULL;
- } else {
- root = drivePat;
- *root = dir[0];
- }
- found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
- &volFlags, NULL, 0);
- break;
- case TCL_PATH_ABSOLUTE:
- if (dir[1] == ':') {
- root = drivePat;
- *root = dir[0];
+ switch (Tcl_GetPathType(dir)) {
+ case TCL_PATH_RELATIVE:
+ found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
+ &volFlags, NULL, 0);
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ if (dir[0] == '\\') {
+ root = NULL;
+ } else {
+ root = drivePat;
+ *root = dir[0];
+ }
found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
&volFlags, NULL, 0);
- } else if (dir[1] == '\\') {
- char *p;
-
- p = strchr(dir + 2, '\\');
- p = strchr(p + 1, '\\');
- p++;
- nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
- found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
- NULL, 0, NULL, NULL, &volFlags, NULL, 0);
- Tcl_DStringFree(&ds);
- }
- break;
- }
-
- if (found == 0) {
- message = "couldn't read volume information for \"";
- goto error;
- }
-
- /*
- * In Windows, although some volumes may support case sensitivity, Windows
- * doesn't honor case. So in globbing we need to ignore the case
- * of file names.
- */
+ break;
+ case TCL_PATH_ABSOLUTE:
+ if (dir[1] == ':') {
+ root = drivePat;
+ *root = dir[0];
+ found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
+ &volFlags, NULL, 0);
+ } else if (dir[1] == '\\') {
+ char *p;
+
+ p = strchr(dir + 2, '\\');
+ p = strchr(p + 1, '\\');
+ p++;
+ nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
+ found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
+ NULL, 0, NULL, NULL, &volFlags, NULL, 0);
+ Tcl_DStringFree(&ds);
+ }
+ break;
+ }
- Tcl_DStringInit(&patternString);
- newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern);
- Tcl_UtfToLower(newPattern);
+ if (found == 0) {
+ message = "couldn't read volume information for \"";
+ goto error;
+ }
- /*
- * We need to check all files in the directory, so append a *.*
- * to the path.
- */
+ /*
+ * Check to see if the pattern should match the special
+ * . and .. names, referring to the current directory,
+ * or the directory above. We need a special check for
+ * this because paths beginning with a dot are not considered
+ * hidden on Windows, and so otherwise a relative glob like
+ * 'glob -join * *' will actually return './. ../..' etc.
+ */
- dir = Tcl_DStringAppend(&dirString, "*.*", 3);
- nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
- handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
- Tcl_DStringFree(&ds);
+ if ((pattern[0] == '.')
+ || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
+ matchSpecialDots = 1;
+ } else {
+ matchSpecialDots = 0;
+ }
- if (handle == INVALID_HANDLE_VALUE) {
- message = "couldn't read directory \"";
- goto error;
- }
+ /*
+ * We need to check all files in the directory, so append a *.*
+ * to the path.
+ */
- /*
- * Clean up the tail pointer. Leave the tail pointing to the
- * first character after the path separator or NULL.
- */
+ dir = Tcl_DStringAppend(&dirString, "*.*", 3);
+ nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
+ handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
+ Tcl_DStringFree(&ds);
- if (*tail == '\\') {
- tail++;
- }
- if (*tail == '\0') {
- tail = NULL;
- } else {
- tail++;
- }
+ if (handle == INVALID_HANDLE_VALUE) {
+ message = "couldn't read directory \"";
+ goto error;
+ }
- /*
- * Check to see if the pattern needs to compare with dot files.
- */
+ /*
+ * Now iterate over all of the files in the directory.
+ */
- if ((newPattern[0] == '.')
- || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
- matchDotFiles = 1;
- } else {
- matchDotFiles = 0;
- }
+ for (found = 1; found != 0;
+ found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
+ CONST TCHAR *nativeMatchResult;
+ CONST char *name, *fname;
+
+ if (tclWinProcs->useWide) {
+ nativeName = (CONST TCHAR *) data.w.cFileName;
+ } else {
+ nativeName = (CONST TCHAR *) data.a.cFileName;
+ }
+ name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
+
+ if (!matchSpecialDots) {
+ /* If it is exactly '.' or '..' then we ignore it */
+ if (name[0] == '.') {
+ if (name[1] == '\0'
+ || (name[1] == '.' && name[2] == '\0')) {
+ continue;
+ }
+ }
+ }
+
+ /*
+ * Check to see if the file matches the pattern. Note that
+ * we are ignoring the case sensitivity flag because Windows
+ * doesn't honor case even if the volume is case sensitive.
+ * If the volume also doesn't preserve case, then we
+ * previously returned the lower case form of the name. This
+ * didn't seem quite right since there are
+ * non-case-preserving volumes that actually return mixed
+ * case. So now we are returning exactly what we get from
+ * the system.
+ */
- /*
- * Now iterate over all of the files in the directory.
- */
+ nativeMatchResult = NULL;
- resultPtr = Tcl_GetObjResult(interp);
- for (found = 1; found != 0;
- found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
- TCHAR *nativeMatchResult;
- char *name, *fname;
+ if (Tcl_StringCaseMatch(name, pattern, 1) != 0) {
+ nativeMatchResult = nativeName;
+ }
+ Tcl_DStringFree(&ds);
- if (tclWinProcs->useWide) {
- nativeName = (TCHAR *) data.w.cFileName;
- } else {
- nativeName = (TCHAR *) data.a.cFileName;
- }
- name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
+ if (nativeMatchResult == NULL) {
+ continue;
+ }
- /*
- * Check to see if the file matches the pattern. We need to convert
- * the file name to lower case for comparison purposes. Note that we
- * are ignoring the case sensitivity flag because Windows doesn't honor
- * case even if the volume is case sensitive. If the volume also
- * doesn't preserve case, then we previously returned the lower case
- * form of the name. This didn't seem quite right since there are
- * non-case-preserving volumes that actually return mixed case. So now
- * we are returning exactly what we get from the system.
- */
+ /*
+ * If the file matches, then we need to process the remainder
+ * of the path.
+ */
- Tcl_UtfToLower(name);
- nativeMatchResult = NULL;
+ name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
+ Tcl_DStringAppend(&dsOrig, name, -1);
+ Tcl_DStringFree(&ds);
- if ((matchDotFiles == 0) && (name[0] == '.')) {
+ fname = Tcl_DStringValue(&dsOrig);
+ nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(&dsOrig),
+ &ds);
+
+ if (NativeMatchType(fname, Tcl_DStringLength(&dsOrig),
+ nativeName, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(fname, Tcl_DStringLength(&dsOrig)));
+ }
/*
- * Ignore hidden files.
+ * Free ds here to ensure that nativeName is valid above.
*/
- } else if (Tcl_StringMatch(name, newPattern) != 0) {
- nativeMatchResult = nativeName;
- }
- Tcl_DStringFree(&ds);
- if (nativeMatchResult == NULL) {
- continue;
- }
+ Tcl_DStringFree(&ds);
- /*
- * If the file matches, then we need to process the remainder of the
- * path. If there are more characters to process, then ensure matching
- * files are directories and call TclDoGlob. Otherwise, just add the
- * file to the result.
- */
+ Tcl_DStringSetLength(&dsOrig, dirLength);
+ }
- name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
- Tcl_DStringAppend(dirPtr, name, -1);
- Tcl_DStringFree(&ds);
+ FindClose(handle);
+ Tcl_DStringFree(&dirString);
+ Tcl_DStringFree(&dsOrig);
- fname = Tcl_DStringValue(dirPtr);
- nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds);
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
- Tcl_DStringFree(&ds);
+ return TCL_OK;
+
+ error:
+ Tcl_DStringFree(&dirString);
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, message, Tcl_DStringValue(&dsOrig), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DStringFree(&dsOrig);
+ return TCL_ERROR;
+ }
- if (tail == NULL) {
- int typeOk = 1;
- if (types != NULL) {
- if (types->perm != 0) {
- if (
- ((types->perm & TCL_GLOB_PERM_RONLY) &&
- !(attr & FILE_ATTRIBUTE_READONLY)) ||
- ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
- !(attr & FILE_ATTRIBUTE_HIDDEN)) ||
- ((types->perm & TCL_GLOB_PERM_R) &&
- (TclpAccess(fname, R_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_W) &&
- (TclpAccess(fname, W_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_X) &&
- (TclpAccess(fname, X_OK) != 0))
- ) {
- typeOk = 0;
- }
+}
+\f
+/*
+ * Does the given path represent a root volume? We need this special
+ * case because for NTFS root volumes, the getFileAttributesProc returns
+ * a 'hidden' attribute when it should not.
+ */
+static int
+WinIsDrive(
+ CONST char *name, /* Name (UTF-8) */
+ int len) /* Length of name */
+{
+ int remove = 0;
+ while (len > 4) {
+ if ((name[len-1] != '.' || name[len-2] != '.')
+ || (name[len-3] != '/' && name[len-3] != '\\')) {
+ /* We don't have '/..' at the end */
+ if (remove == 0) {
+ break;
+ }
+ remove--;
+ while (len > 0) {
+ len--;
+ if (name[len] == '/' || name[len] == '\\') {
+ break;
}
- if (typeOk && types->type != 0) {
- struct stat buf;
- /*
- * We must match at least one flag to be listed
- */
- typeOk = 0;
- if (TclpLstat(fname, &buf) >= 0) {
- /*
- * In order bcdpfls as in 'find -t'
- */
- if (
- ((types->type & TCL_GLOB_TYPE_BLOCK) &&
- S_ISBLK(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_CHAR) &&
- S_ISCHR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_DIR) &&
- S_ISDIR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_PIPE) &&
- S_ISFIFO(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_FILE) &&
- S_ISREG(buf.st_mode))
-#ifdef S_ISLNK
- || ((types->type & TCL_GLOB_TYPE_LINK) &&
- S_ISLNK(buf.st_mode))
-#endif
+ }
+ if (len < 4) {
+ len++;
+ break;
+ }
+ } else {
+ /* We do have '/..' */
+ len -= 3;
+ remove++;
+ }
+ }
+ if (len < 4) {
+ if (len == 0) {
+ /*
+ * Not sure if this is possible, but we pass it on
+ * anyway
+ */
+ } else if (len == 1 && (name[0] == '/' || name[0] == '\\')) {
+ /* Path is pointing to the root volume */
+ return 1;
+ } else if ((name[1] == ':')
+ && (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
+ /* Path is of the form 'x:' or 'x:/' or 'x:\' */
+ return 1;
+ }
+ }
+ return 0;
+}
+
+\f
+/*
+ * This function needs a special case for a path which is a root
+ * volume, because for NTFS root volumes, the getFileAttributesProc
+ * returns a 'hidden' attribute when it should not.
+ */
+static int
+NativeMatchType(
+ CONST char *name, /* Name */
+ int nameLen, /* Length of name */
+ CONST TCHAR* nativeName, /* Native path to check */
+ Tcl_GlobTypeData *types) /* Type description to match against */
+{
+ /*
+ * 'attr' represents the attributes of the file, but we only
+ * want to retrieve this info if it is absolutely necessary
+ * because it is an expensive call. Unfortunately, to deal
+ * with hidden files properly, we must always retrieve it.
+ * There are more modern Win32 APIs available which we should
+ * look into.
+ */
+
+ DWORD attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ if (attr == 0xffffffff) {
+ /* File doesn't exist */
+ return 0;
+ }
+
+ if (types == NULL) {
+ /* If invisible, don't return the file */
+ if (attr & FILE_ATTRIBUTE_HIDDEN && !WinIsDrive(name, nameLen)) {
+ return 0;
+ }
+ } else {
+ if (attr & FILE_ATTRIBUTE_HIDDEN && !WinIsDrive(name, nameLen)) {
+ /* If invisible */
+ if ((types->perm == 0) ||
+ !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
+ return 0;
+ }
+ } else {
+ /* Visible */
+ if (types->perm & TCL_GLOB_PERM_HIDDEN) {
+ return 0;
+ }
+ }
+
+ if (types->perm != 0) {
+ if (
+ ((types->perm & TCL_GLOB_PERM_RONLY) &&
+ !(attr & FILE_ATTRIBUTE_READONLY)) ||
+ ((types->perm & TCL_GLOB_PERM_R) &&
+ (NativeAccess(nativeName, R_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_W) &&
+ (NativeAccess(nativeName, W_OK) != 0)) ||
+ ((types->perm & TCL_GLOB_PERM_X) &&
+ (NativeAccess(nativeName, X_OK) != 0))
+ ) {
+ return 0;
+ }
+ }
+ if (types->type != 0) {
+ Tcl_StatBuf buf;
+
+ if (NativeStat(nativeName, &buf, 0) != 0) {
+ /*
+ * Posix error occurred, either the file
+ * has disappeared, or there is some other
+ * strange error. In any case we don't
+ * return this file.
+ */
+ return 0;
+ }
+ /*
+ * In order bcdpfls as in 'find -t'
+ */
+ if (
+ ((types->type & TCL_GLOB_TYPE_BLOCK) &&
+ S_ISBLK(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_CHAR) &&
+ S_ISCHR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_DIR) &&
+ S_ISDIR(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_PIPE) &&
+ S_ISFIFO(buf.st_mode)) ||
+ ((types->type & TCL_GLOB_TYPE_FILE) &&
+ S_ISREG(buf.st_mode))
#ifdef S_ISSOCK
- || ((types->type & TCL_GLOB_TYPE_SOCK) &&
- S_ISSOCK(buf.st_mode))
+ || ((types->type & TCL_GLOB_TYPE_SOCK) &&
+ S_ISSOCK(buf.st_mode))
#endif
- ) {
- typeOk = 1;
+ ) {
+ /* Do nothing -- this file is ok */
+ } else {
+#ifdef S_ISLNK
+ if (types->type & TCL_GLOB_TYPE_LINK) {
+ if (NativeStat(nativeName, &buf, 1) == 0) {
+ if (S_ISLNK(buf.st_mode)) {
+ return 1;
}
- } else {
- /* Posix error occurred */
}
- }
- }
- if (typeOk) {
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr)));
- }
- } else if (attr & FILE_ATTRIBUTE_DIRECTORY) {
- Tcl_DStringAppend(dirPtr, "/", 1);
- result = TclDoGlob(interp, separators, dirPtr, tail, types);
- if (result != TCL_OK) {
- break;
+ }
+#endif
+ return 0;
}
- }
- Tcl_DStringSetLength(dirPtr, dirLength);
- }
-
- FindClose(handle);
- Tcl_DStringFree(&dirString);
- Tcl_DStringFree(&patternString);
-
- return result;
-
- error:
- Tcl_DStringFree(&dirString);
- TclWinConvertError(GetLastError());
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
-}
-\f
-/*
- * TclpMatchFiles --
- *
- * This function is now obsolete. Call the above function
- * 'TclpMatchFilesTypes' instead.
- */
-int
-TclpMatchFiles(
- Tcl_Interp *interp, /* Interpreter to receive results. */
- char *separators, /* Directory separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr, /* Contains path to directory to search. */
- char *pattern, /* Pattern to match against. */
- char *tail) /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static.*/
-{
- return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
+ }
+ }
+ return 1;
}
\f
/*
if (badDomain == 0) {
Tcl_DStringInit(&ds);
wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
- if ((*netUserGetInfoProc)(wDomain, wName, 1,
+ if ((*netUserGetInfoProc)(wDomain, wName, 1,
(LPBYTE *) &uiPtr) == 0) {
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
return result;
}
+
\f
/*
*---------------------------------------------------------------------------
*
- * TclpAccess --
+ * NativeAccess --
*
* This function replaces the library version of access(), fixing the
* following bugs:
*---------------------------------------------------------------------------
*/
-int
-TclpAccess(
- CONST char *path, /* Path of file to access (UTF-8). */
+static int
+NativeAccess(
+ CONST TCHAR *nativePath, /* Path of file to access (UTF-8). */
int mode) /* Permission setting. */
{
- Tcl_DString ds;
- TCHAR *nativePath;
DWORD attr;
- nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
- Tcl_DStringFree(&ds);
if (attr == 0xffffffff) {
/*
}
if (mode & X_OK) {
- CONST char *p;
-
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Directories are always executable.
return 0;
}
- p = strrchr(path, '.');
- if (p != NULL) {
- p++;
- if ((stricmp(p, "exe") == 0)
- || (stricmp(p, "com") == 0)
- || (stricmp(p, "bat") == 0)) {
- /*
- * File that ends with .exe, .com, or .bat is executable.
- */
-
- return 0;
- }
+ if (NativeIsExec(nativePath)) {
+ return 0;
}
Tcl_SetErrno(EACCES);
return -1;
return 0;
}
\f
+static int
+NativeIsExec(nativePath)
+ CONST TCHAR *nativePath;
+{
+ CONST char *p, *path;
+ Tcl_DString ds;
+
+ /*
+ * This is really not efficient. We should be able to examine
+ * the native path directly without converting to UTF.
+ */
+ Tcl_DStringInit(&ds);
+ path = Tcl_WinTCharToUtf(nativePath, -1, &ds);
+
+ p = strrchr(path, '.');
+ if (p != NULL) {
+ p++;
+ /*
+ * Note: in the old code, stat considered '.pif' files as
+ * executable, whereas access did not.
+ */
+ if ((stricmp(p, "exe") == 0)
+ || (stricmp(p, "com") == 0)
+ || (stricmp(p, "bat") == 0)) {
+ /*
+ * File that ends with .exe, .com, or .bat is executable.
+ */
+
+ Tcl_DStringFree(&ds);
+ return 1;
+ }
+ }
+ Tcl_DStringFree(&ds);
+ return 0;
+}
+\f
/*
*----------------------------------------------------------------------
*
- * TclpChdir --
+ * TclpObjChdir --
*
* This function replaces the library version of chdir().
*
*----------------------------------------------------------------------
*/
-int
-TclpChdir(path)
- CONST char *path; /* Path to new working directory (UTF-8). */
+int
+TclpObjChdir(pathPtr)
+ Tcl_Obj *pathPtr; /* Path to new working directory. */
{
int result;
- Tcl_DString ds;
- TCHAR *nativePath;
+ CONST TCHAR *nativePath;
- nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
+ nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);
result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
- Tcl_DStringFree(&ds);
if (result == 0) {
TclWinConvertError(GetLastError());
Tcl_DStringFree(&ds);
if (length < 0) {
- return NULL;
+ return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
*----------------------------------------------------------------------
*/
-char *
+CONST char *
TclpGetCwd(interp, bufferPtr)
Tcl_Interp *interp; /* If non-NULL, used for error reporting. */
Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
}
/*
- * Watch for the wierd Windows c:\\UNC syntax.
+ * Watch for the weird Windows c:\\UNC syntax.
*/
if (tclWinProcs->useWide) {
return Tcl_DStringValue(bufferPtr);
}
\f
+int
+TclpObjStat(pathPtr, statPtr)
+ Tcl_Obj *pathPtr; /* Path of file to stat */
+ Tcl_StatBuf *statPtr; /* Filled with results of stat call. */
+{
+#ifdef OLD_API
+ Tcl_Obj *transPtr;
+ /*
+ * Eliminate file names containing wildcard characters, or subsequent
+ * call to FindFirstFile() will expand them, matching some other file.
+ */
+
+ transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
+ if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) {
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
+#endif
+
+ /*
+ * Ensure correct file sizes by forcing the OS to write any
+ * pending data to disk. This is done only for channels which are
+ * dirty, i.e. have been written to since the last flush here.
+ */
+
+ TclWinFlushDirtyChannels ();
+
+ return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0);
+}
+\f
/*
*----------------------------------------------------------------------
*
- * TclpStat --
+ * NativeStat --
*
* This function replaces the library version of stat(), fixing
* the following bugs:
*----------------------------------------------------------------------
*/
-int
-TclpStat(path, statPtr)
- CONST char *path; /* Path of file to stat (UTF-8). */
- struct stat *statPtr; /* Filled with results of stat call. */
+static int
+NativeStat(nativePath, statPtr, checkLinks)
+ CONST TCHAR *nativePath; /* Path of file to stat */
+ Tcl_StatBuf *statPtr; /* Filled with results of stat call. */
+ int checkLinks; /* If non-zero, behave like 'lstat' */
{
Tcl_DString ds;
- TCHAR *nativePath;
- WIN32_FIND_DATAT data;
- HANDLE handle;
DWORD attr;
WCHAR nativeFullPath[MAX_PATH];
TCHAR *nativePart;
- char *p, *fullPath;
+ CONST char *fullPath;
int dev, mode;
+
+ if (tclWinProcs->getFileAttributesExProc == NULL) {
+ /*
+ * We don't have the faster attributes proc, so we're
+ * probably running on Win95
+ */
+ WIN32_FIND_DATAT data;
+ HANDLE handle;
+
+ handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
+ if (handle == INVALID_HANDLE_VALUE) {
+ /*
+ * FindFirstFile() doesn't work on root directories, so call
+ * GetFileAttributes() to see if the specified file exists.
+ */
- /*
- * Eliminate file names containing wildcard characters, or subsequent
- * call to FindFirstFile() will expand them, matching some other file.
- */
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ if (attr == 0xffffffff) {
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
- if (strpbrk(path, "?*") != NULL) {
- Tcl_SetErrno(ENOENT);
- return -1;
- }
+ /*
+ * Make up some fake information for this file. It has the
+ * correct file attributes and a time of 0.
+ */
- nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
- handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
- if (handle == INVALID_HANDLE_VALUE) {
- /*
- * FindFirstFile() doesn't work on root directories, so call
- * GetFileAttributes() to see if the specified file exists.
- */
+ memset(&data, 0, sizeof(data));
+ data.a.dwFileAttributes = attr;
+ } else {
+ FindClose(handle);
+ }
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
- if (attr == 0xffffffff) {
- Tcl_DStringFree(&ds);
+
+ (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
+ &nativePart);
+
+ fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
+
+ dev = -1;
+ if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
+ CONST char *p;
+ DWORD dw;
+ CONST TCHAR *nativeVol;
+ Tcl_DString volString;
+
+ p = strchr(fullPath + 2, '\\');
+ p = strchr(p + 1, '\\');
+ if (p == NULL) {
+ /*
+ * Add terminating backslash to fullpath or
+ * GetVolumeInformation() won't work.
+ */
+
+ fullPath = Tcl_DStringAppend(&ds, "\\", 1);
+ p = fullPath + Tcl_DStringLength(&ds);
+ } else {
+ p++;
+ }
+ nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
+ dw = (DWORD) -1;
+ (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
+ NULL, NULL, NULL, 0);
+ /*
+ * GetFullPathName() turns special devices like "NUL" into
+ * "\\.\NUL", but GetVolumeInformation() returns failure for
+ * "\\.\NUL". This will cause "NUL" to get a drive number of
+ * -1, which makes about as much sense as anything since the
+ * special devices don't live on any drive.
+ */
+
+ dev = dw;
+ Tcl_DStringFree(&volString);
+ } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
+ dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
+ }
+ Tcl_DStringFree(&ds);
+
+ attr = data.a.dwFileAttributes;
+
+ statPtr->st_size = ((Tcl_WideInt)data.a.nFileSizeLow) |
+ (((Tcl_WideInt)data.a.nFileSizeHigh) << 32);
+ statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
+ statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
+ statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
+ } else {
+ WIN32_FILE_ATTRIBUTE_DATA data;
+ if((*tclWinProcs->getFileAttributesExProc)(nativePath,
+ GetFileExInfoStandard,
+ &data) != TRUE) {
Tcl_SetErrno(ENOENT);
return -1;
}
- /*
- * Make up some fake information for this file. It has the
- * correct file attributes and a time of 0.
- */
+
+ (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH,
+ nativeFullPath, &nativePart);
- memset(&data, 0, sizeof(data));
- data.a.dwFileAttributes = attr;
- } else {
- FindClose(handle);
- }
+ fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
- (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
- &nativePart);
+ dev = -1;
+ if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
+ CONST char *p;
+ DWORD dw;
+ CONST TCHAR *nativeVol;
+ Tcl_DString volString;
- Tcl_DStringFree(&ds);
- fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
-
- dev = -1;
- if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
- char *p;
- DWORD dw;
- TCHAR *nativeVol;
- Tcl_DString volString;
-
- p = strchr(fullPath + 2, '\\');
- p = strchr(p + 1, '\\');
- if (p == NULL) {
+ p = strchr(fullPath + 2, '\\');
+ p = strchr(p + 1, '\\');
+ if (p == NULL) {
+ /*
+ * Add terminating backslash to fullpath or
+ * GetVolumeInformation() won't work.
+ */
+
+ fullPath = Tcl_DStringAppend(&ds, "\\", 1);
+ p = fullPath + Tcl_DStringLength(&ds);
+ } else {
+ p++;
+ }
+ nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
+ dw = (DWORD) -1;
+ (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
+ NULL, NULL, NULL, 0);
/*
- * Add terminating backslash to fullpath or
- * GetVolumeInformation() won't work.
+ * GetFullPathName() turns special devices like "NUL" into
+ * "\\.\NUL", but GetVolumeInformation() returns failure for
+ * "\\.\NUL". This will cause "NUL" to get a drive number of
+ * -1, which makes about as much sense as anything since the
+ * special devices don't live on any drive.
*/
- fullPath = Tcl_DStringAppend(&ds, "\\", 1);
- p = fullPath + Tcl_DStringLength(&ds);
- } else {
- p++;
+ dev = dw;
+ Tcl_DStringFree(&volString);
+ } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
+ dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
}
- nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
- dw = (DWORD) -1;
- (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
- NULL, NULL, NULL, 0);
- /*
- * GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
- * but GetVolumeInformation() returns failure for "\\.\NUL". This
- * will cause "NUL" to get a drive number of -1, which makes about
- * as much sense as anything since the special devices don't live on
- * any drive.
- */
-
- dev = dw;
- Tcl_DStringFree(&volString);
- } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
- dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
+ Tcl_DStringFree(&ds);
+
+ attr = data.dwFileAttributes;
+
+ statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) |
+ (((Tcl_WideInt)data.nFileSizeHigh) << 32);
+ statPtr->st_atime = ToCTime(data.ftLastAccessTime);
+ statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
+ statPtr->st_ctime = ToCTime(data.ftCreationTime);
}
- Tcl_DStringFree(&ds);
- attr = data.a.dwFileAttributes;
- mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
+ if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
+ /* It is a link */
+ mode = S_IFLNK;
+ } else {
+ mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
+ }
mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
- p = strrchr(path, '.');
- if (p != NULL) {
- if ((lstrcmpiA(p, ".exe") == 0)
- || (lstrcmpiA(p, ".com") == 0)
- || (lstrcmpiA(p, ".bat") == 0)
- || (lstrcmpiA(p, ".pif") == 0)) {
- mode |= S_IEXEC;
- }
+ if (NativeIsExec(nativePath)) {
+ mode |= S_IEXEC;
}
-
+
/*
* Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
* other positions.
statPtr->st_uid = 0;
statPtr->st_gid = 0;
statPtr->st_rdev = (dev_t) dev;
- statPtr->st_size = data.a.nFileSizeLow;
- statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
- statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
- statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
return 0;
}
return 0;
}
#endif
+\f
+Tcl_Obj*
+TclpObjGetCwd(interp)
+ Tcl_Interp *interp;
+{
+ Tcl_DString ds;
+ if (TclpGetCwd(interp, &ds) != NULL) {
+ Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+ Tcl_IncrRefCount(cwdPtr);
+ Tcl_DStringFree(&ds);
+ return cwdPtr;
+ } else {
+ return NULL;
+ }
+}
+
+int
+TclpObjAccess(pathPtr, mode)
+ Tcl_Obj *pathPtr;
+ int mode;
+{
+ return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
+}
+
+int
+TclpObjLstat(pathPtr, statPtr)
+ Tcl_Obj *pathPtr;
+ Tcl_StatBuf *statPtr;
+{
+ /*
+ * Ensure correct file sizes by forcing the OS to write any
+ * pending data to disk. This is done only for channels which are
+ * dirty, i.e. have been written to since the last flush here.
+ */
+
+ TclWinFlushDirtyChannels ();
+
+ return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1);
+}
+
+#ifdef S_IFLNK
+
+Tcl_Obj*
+TclpObjLink(pathPtr, toPtr, linkAction)
+ Tcl_Obj *pathPtr;
+ Tcl_Obj *toPtr;
+ int linkAction;
+{
+ if (toPtr != NULL) {
+ int res;
+ TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr);
+ TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
+ if (LinkSource == NULL || LinkTarget == NULL) {
+ return NULL;
+ }
+ res = WinLink(LinkSource, LinkTarget, linkAction);
+ if (res == 0) {
+ return toPtr;
+ } else {
+ return NULL;
+ }
+ } else {
+ TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
+ if (LinkSource == NULL) {
+ return NULL;
+ }
+ return WinReadLink(LinkSource);
+ }
+}
+
+#endif
+
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpFilesystemPathType --
+ *
+ * This function is part of the native filesystem support, and
+ * returns the path type of the given path. Returns NTFS or FAT
+ * or whatever is returned by the 'volume information' proc.
+ *
+ * Results:
+ * NULL at present.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Obj*
+TclpFilesystemPathType(pathObjPtr)
+ Tcl_Obj* pathObjPtr;
+{
+#define VOL_BUF_SIZE 32
+ int found;
+ char volType[VOL_BUF_SIZE];
+ char* firstSeparator;
+ CONST char *path;
+
+ Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
+ if (normPath == NULL) return NULL;
+ path = Tcl_GetString(normPath);
+ if (path == NULL) return NULL;
+
+ firstSeparator = strchr(path, '/');
+ if (firstSeparator == NULL) {
+ found = tclWinProcs->getVolumeInformationProc(
+ Tcl_FSGetNativePath(pathObjPtr), NULL, 0, NULL, NULL,
+ NULL, (WCHAR *)volType, VOL_BUF_SIZE);
+ } else {
+ Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
+ Tcl_IncrRefCount(driveName);
+ found = tclWinProcs->getVolumeInformationProc(
+ Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL,
+ NULL, (WCHAR *)volType, VOL_BUF_SIZE);
+ Tcl_DecrRefCount(driveName);
+ }
+
+ if (found == 0) {
+ return NULL;
+ } else {
+ Tcl_DString ds;
+ Tcl_Obj *objPtr;
+
+ Tcl_WinTCharToUtf(volType, -1, &ds);
+ objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ return objPtr;
+ }
+#undef VOL_BUF_SIZE
+}
+
+\f
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpObjNormalizePath --
+ *
+ * This function scans through a path specification and replaces it,
+ * in place, with a normalized version. This means using the
+ * 'longname', and expanding any symbolic links contained within the
+ * path.
+ *
+ * Results:
+ * The new 'nextCheckpoint' value, giving as far as we could
+ * understand in the path.
+ *
+ * Side effects:
+ * The pathPtr string, which must contain a valid path, is
+ * possibly modified in place.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
+ Tcl_Interp *interp;
+ Tcl_Obj *pathPtr;
+ int nextCheckpoint;
+{
+ char *lastValidPathEnd = NULL;
+ /* This will hold the normalized string */
+ Tcl_DString dsNorm;
+ char *path;
+ char *currentPathEndPosition;
+
+ Tcl_DStringInit(&dsNorm);
+ path = Tcl_GetString(pathPtr);
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
+ /*
+ * We're on Win95, 98 or ME. There are two assumptions
+ * in this block of code. First that the native (NULL)
+ * encoding is basically ascii, and second that symbolic
+ * links are not possible. Both of these assumptions
+ * appear to be true of these operating systems.
+ */
+ Tcl_Obj *temp = NULL;
+ int isDrive = 1;
+ Tcl_DString ds;
+
+ currentPathEndPosition = path + nextCheckpoint;
+ while (1) {
+ char cur = *currentPathEndPosition;
+ if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
+ /* Reached directory separator, or end of string */
+ CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path,
+ currentPathEndPosition - path, &ds);
+
+ /*
+ * Now we convert the tail of the current path to its
+ * 'long form', and append it to 'dsNorm' which holds
+ * the current normalized path, if the file exists.
+ */
+ if (isDrive) {
+ if (GetFileAttributesA(nativePath)
+ == 0xffffffff) {
+ /* File doesn't exist */
+ Tcl_DStringFree(&ds);
+ break;
+ }
+ if (nativePath[0] >= 'a') {
+ ((char*)nativePath)[0] -= ('a' - 'A');
+ }
+ Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
+ } else {
+ WIN32_FIND_DATA fData;
+ HANDLE handle;
+
+ handle = FindFirstFileA(nativePath, &fData);
+ if (handle == INVALID_HANDLE_VALUE) {
+ if (GetFileAttributesA(nativePath)
+ == 0xffffffff) {
+ /* File doesn't exist */
+ Tcl_DStringFree(&ds);
+ break;
+ }
+ /* This is usually the '/' in 'c:/' at end of string */
+ Tcl_DStringAppend(&dsNorm,"/", 1);
+ } else {
+ char *nativeName;
+ if (fData.cFileName[0] != '\0') {
+ nativeName = fData.cFileName;
+ } else {
+ nativeName = fData.cAlternateFileName;
+ }
+ FindClose(handle);
+ Tcl_DStringAppend(&dsNorm,"/", 1);
+ Tcl_DStringAppend(&dsNorm,nativeName,-1);
+ }
+ }
+ Tcl_DStringFree(&ds);
+ lastValidPathEnd = currentPathEndPosition;
+ if (cur == 0) {
+ break;
+ }
+ /*
+ * If we get here, we've got past one directory
+ * delimiter, so we know it is no longer a drive
+ */
+ isDrive = 0;
+ }
+ currentPathEndPosition++;
+ }
+ } else {
+ /* We're on WinNT or 2000 or XP */
+ Tcl_Obj *temp = NULL;
+ int isDrive = 1;
+ Tcl_DString ds;
+
+ currentPathEndPosition = path + nextCheckpoint;
+ while (1) {
+ char cur = *currentPathEndPosition;
+ if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
+ /* Reached directory separator, or end of string */
+ WIN32_FILE_ATTRIBUTE_DATA data;
+ CONST char *nativePath = Tcl_WinUtfToTChar(path,
+ currentPathEndPosition - path, &ds);
+ if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
+ GetFileExInfoStandard, &data) != TRUE) {
+ /* File doesn't exist */
+ Tcl_DStringFree(&ds);
+ break;
+ }
+ /*
+ * File 'nativePath' does exist if we get here. We
+ * now want to check if it is a symlink and otherwise
+ * continue with the rest of the path.
+ */
+
+ /*
+ * Check for symlinks, except at last component
+ * of path (we don't follow final symlinks). Also
+ * a drive (C:/) for example, may sometimes have
+ * the reparse flag set for some reason I don't
+ * understand. We therefore don't perform this
+ * check for drives.
+ */
+ if (cur != 0 && !isDrive && (data.dwFileAttributes
+ & FILE_ATTRIBUTE_REPARSE_POINT)) {
+ Tcl_Obj *to = WinReadLinkDirectory(nativePath);
+ if (to != NULL) {
+ /* Read the reparse point ok */
+ /* Tcl_GetStringFromObj(to, &pathLen); */
+ nextCheckpoint = 0; /* pathLen */
+ Tcl_AppendToObj(to, currentPathEndPosition, -1);
+ /* Convert link to forward slashes */
+ for (path = Tcl_GetString(to); *path != 0; path++) {
+ if (*path == '\\') *path = '/';
+ }
+ path = Tcl_GetString(to);
+ currentPathEndPosition = path + nextCheckpoint;
+ if (temp != NULL) {
+ Tcl_DecrRefCount(temp);
+ }
+ temp = to;
+ /* Reset variables so we can restart normalization */
+ isDrive = 1;
+ Tcl_DStringFree(&dsNorm);
+ Tcl_DStringInit(&dsNorm);
+ Tcl_DStringFree(&ds);
+ continue;
+ }
+ }
+ /*
+ * Now we convert the tail of the current path to its
+ * 'long form', and append it to 'dsNorm' which holds
+ * the current normalized path
+ */
+ if (isDrive) {
+ WCHAR drive = ((WCHAR*)nativePath)[0];
+ if (drive >= L'a') {
+ drive -= (L'a' - L'A');
+ ((WCHAR*)nativePath)[0] = drive;
+ }
+ Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
+ } else {
+ WIN32_FIND_DATAW fData;
+ HANDLE handle;
+
+ handle = FindFirstFileW((WCHAR*)nativePath, &fData);
+ if (handle == INVALID_HANDLE_VALUE) {
+ /* This is usually the '/' in 'c:/' at end of string */
+ Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
+ sizeof(WCHAR));
+ } else {
+ WCHAR *nativeName;
+ if (fData.cFileName[0] != '\0') {
+ nativeName = fData.cFileName;
+ } else {
+ nativeName = fData.cAlternateFileName;
+ }
+ FindClose(handle);
+ Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
+ sizeof(WCHAR));
+ Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName,
+ wcslen(nativeName)*sizeof(WCHAR));
+ }
+ }
+ Tcl_DStringFree(&ds);
+ lastValidPathEnd = currentPathEndPosition;
+ if (cur == 0) {
+ break;
+ }
+ /*
+ * If we get here, we've got past one directory
+ * delimiter, so we know it is no longer a drive
+ */
+ isDrive = 0;
+ }
+ currentPathEndPosition++;
+ }
+ }
+ /* Common code path for all Windows platforms */
+ nextCheckpoint = currentPathEndPosition - path;
+ if (lastValidPathEnd != NULL) {
+ /*
+ * Concatenate the normalized string in dsNorm with the
+ * tail of the path which we didn't recognise. The
+ * string in dsNorm is in the native encoding, so we
+ * have to convert it to Utf.
+ */
+ Tcl_DString dsTemp;
+ Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
+ Tcl_DStringLength(&dsNorm), &dsTemp);
+ nextCheckpoint = Tcl_DStringLength(&dsTemp);
+ if (*lastValidPathEnd != 0) {
+ /* Not the end of the string */
+ int len;
+ char *path;
+ Tcl_Obj *tmpPathPtr;
+ tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
+ nextCheckpoint);
+ Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
+ path = Tcl_GetStringFromObj(tmpPathPtr, &len);
+ Tcl_SetStringObj(pathPtr, path, len);
+ Tcl_DecrRefCount(tmpPathPtr);
+ } else {
+ /* End of string was reached above */
+ Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
+ nextCheckpoint);
+ }
+ Tcl_DStringFree(&dsTemp);
+ }
+ Tcl_DStringFree(&dsNorm);
+ return nextCheckpoint;
+}
*/
#include "tclWinInt.h"
-#include <winreg.h>
#include <winnt.h>
#include <winbase.h>
/*
- * The following macro can be defined at compile time to specify
- * the root of the Tcl registry keys.
- */
-
-#ifndef TCL_REGISTRY_KEY
-#define TCL_REGISTRY_KEY "Software\\Scriptics\\Tcl\\" TCL_VERSION
-#endif
-
-/*
* The following declaration is a workaround for some Microsoft brain damage.
* The SYSTEM_INFO structure is different in various releases, even though the
* layout is the same. So we overlay our own structure on top of it so we
#ifndef PROCESSOR_ARCHITECTURE_PPC
#define PROCESSOR_ARCHITECTURE_PPC 3
#endif
+#ifndef PROCESSOR_ARCHITECTURE_SHX
+#define PROCESSOR_ARCHITECTURE_SHX 4
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_ARM
+#define PROCESSOR_ARCHITECTURE_ARM 5
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_IA64
+#define PROCESSOR_ARCHITECTURE_IA64 6
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_ALPHA64
+#define PROCESSOR_ARCHITECTURE_ALPHA64 7
+#endif
+#ifndef PROCESSOR_ARCHITECTURE_MSIL
+#define PROCESSOR_ARCHITECTURE_MSIL 8
+#endif
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
#endif
"Win32s", "Windows 95", "Windows NT"
};
-#define NUMPROCESSORS 4
+#define NUMPROCESSORS 9
static char* processors[NUMPROCESSORS] = {
- "intel", "mips", "alpha", "ppc"
+ "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil"
};
-/*
- * Thread id used for asynchronous notification from signal handlers.
- */
-
-static DWORD mainThreadId;
+/* Used to store the encoding used for binary files */
+static Tcl_Encoding binaryEncoding = NULL;
+/* Has the basic library path encoding issue been fixed */
+static int libraryPathEncodingFixed = 0;
/*
* The Init script (common to Windows and Unix platforms) is
static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule,
CONST char *lib);
-static void AppendRegistry(Tcl_Obj *listPtr, CONST char *lib);
static int ToUtf(CONST WCHAR *wSrc, char *dst);
\f
/*
SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
- /*
- * Save the id of the first thread to intialize the Tcl library. This
- * thread will be used to handle notifications from async event
- * procedures. This is not strictly correct. A better solution involves
- * using a designated "main" notifier that is kept up to date as threads
- * come and go.
- */
-
- mainThreadId = GetCurrentThreadId();
-
#ifdef STATIC_BUILD
/*
* If we are in a statically linked executable, then we need to
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
- char *str;
+ CONST char *str;
Tcl_DString ds;
int pathc;
- char **pathv;
+ CONST char **pathv;
char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];
-
+#ifdef __CYGWIN__
+ char installLib2[LIBRARY_SIZE];
+#endif
Tcl_DStringInit(&ds);
pathPtr = Tcl_NewObj();
* executable is run from a develpment directory.
*/
- /* CYGNUS LOCAL */
+ /* REDHAT LOCAL */
/* Due to cygwin standard practice, the tcl binary will be
installed in /bin rather than /usr/bin. This means that, without
this change, tcl will search in x:\share rather than x:\usr\share. */
-#ifdef __CYGWIN__
- sprintf(installLib, "usr/share/tcl%s", TCL_VERSION);
-#else
+
+ /* sprintf(installLib, "lib/tcl%s", TCL_VERSION); */
sprintf(installLib, "share/tcl%s", TCL_VERSION);
+#ifdef __CYGWIN__
+ sprintf(installLib2, "usr/share/tcl%s", TCL_VERSION);
#endif
- /* END CYGNUS LOCAL */
- sprintf(developLib, "../tcl%s/library",
- ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION));
+ /* END REDHAT LOCAL */
+
+ sprintf(developLib, "../tcl%s/library", TCL_PATCH_LEVEL);
/*
* Look for the library relative to default encoding dir.
* This code looks in the following directories:
*
* <bindir>/../<installLib>
- * (e.g. /usr/local/bin/../lib/tcl8.2)
+ * (e.g. /usr/local/bin/../lib/tcl8.4)
* <bindir>/../../<installLib>
- * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.2)
+ * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.4)
* <bindir>/../library
- * (e.g. /usr/src/tcl8.2/unix/../library)
+ * (e.g. /usr/src/tcl8.4.0/unix/../library)
* <bindir>/../../library
- * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../library)
+ * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../library)
* <bindir>/../../<developLib>
- * (e.g. /usr/src/tcl8.2/unix/../../tcl8.2/library)
- * <bindir>/../../../<devlopLib>
- * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../../tcl8.2/library)
+ * (e.g. /usr/src/tcl8.4.0/unix/../../tcl8.4.0/library)
+ * <bindir>/../../../<developLib>
+ * (e.g. /usr/src/tcl8.4.0/unix/solaris-sparc/../../../tcl8.4.0/library)
*/
+ /*
+ * The variable path holds an absolute path. Take care not to
+ * overwrite pathv[0] since that might produce a relative path.
+ */
+
if (path != NULL) {
Tcl_SplitPath(path, &pathc, &pathv);
- if (pathc > 1) {
+
+
+ if (pathc > 2) {
+ str = pathv[pathc - 2];
pathv[pathc - 2] = installLib;
path = Tcl_JoinPath(pathc - 1, pathv, &ds);
+ pathv[pathc - 2] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
+ /* REDHAT LOCAL */
+#ifdef __CYGWIN__
+ pathv[pathc - 2] = installLib2;
+ path = Tcl_JoinPath(pathc - 1, pathv, &ds);
+ pathv[pathc - 2] = str;
+ objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+ Tcl_DStringFree(&ds);
+#endif
+ /* END REDHAT LOCAL */
+
}
- if (pathc > 2) {
+ if (pathc > 3) {
+ str = pathv[pathc - 3];
pathv[pathc - 3] = installLib;
path = Tcl_JoinPath(pathc - 2, pathv, &ds);
+ pathv[pathc - 3] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 1) {
+ if (pathc > 2) {
+ str = pathv[pathc - 2];
pathv[pathc - 2] = "library";
path = Tcl_JoinPath(pathc - 1, pathv, &ds);
+ pathv[pathc - 2] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 2) {
+ if (pathc > 3) {
+ str = pathv[pathc - 3];
pathv[pathc - 3] = "library";
path = Tcl_JoinPath(pathc - 2, pathv, &ds);
+ pathv[pathc - 3] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 1) {
+ if (pathc > 3) {
+ str = pathv[pathc - 3];
pathv[pathc - 3] = developLib;
path = Tcl_JoinPath(pathc - 2, pathv, &ds);
+ pathv[pathc - 3] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
- if (pathc > 3) {
+ if (pathc > 4) {
+ str = pathv[pathc - 4];
pathv[pathc - 4] = developLib;
path = Tcl_JoinPath(pathc - 3, pathv, &ds);
+ pathv[pathc - 4] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * TCL_UTF_MAX];
Tcl_Obj *objPtr;
- char *str;
Tcl_DString ds;
- char **pathv;
+ CONST char **pathv;
/*
* The "L" preceeding the TCL_LIBRARY string is used to tell VC++
*/
if ((pathc > 0) && (lstrcmpiA(lib + 4, pathv[pathc - 1]) != 0)) {
+ CONST char *str;
/*
* TCL_LIBRARY is set but refers to a different tcl
* installation than the current version. Try fiddling with the
* version string.
*/
- pathv[pathc - 1] = (char *) (lib + 4);
+ pathv[pathc - 1] = (lib + 4);
Tcl_DStringInit(&ds);
str = Tcl_JoinPath(pathc, pathv, &ds);
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
wSrc++;
}
*dst = '\0';
- return dst - start;
+ return (int) (dst - start);
}
\f
* Based on the locale, determine the encoding of the operating
* system and the default encoding for newly opened files.
*
- * Called at process initialization time.
+ * Called at process initialization time, and part way through
+ * startup, we verify that the initial encodings were correctly
+ * setup. Depending on Tcl's environment, there may not have been
+ * enough information first time through (above).
*
* Results:
* None.
*
* Side effects:
- * The Tcl library path is converted from native encoding to UTF-8.
+ * The Tcl library path is converted from native encoding to UTF-8,
+ * on the first call, and the encodings may be changed on first or
+ * second call.
*
*---------------------------------------------------------------------------
*/
{
CONST char *encoding;
char buf[4 + TCL_INTEGER_SPACE];
- int platformId;
- Tcl_Obj *pathPtr;
-
- platformId = TclWinGetPlatformId();
- TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT);
-
- wsprintfA(buf, "cp%d", GetACP());
- Tcl_SetSystemEncoding(NULL, buf);
-
- if (platformId != VER_PLATFORM_WIN32_NT) {
- pathPtr = TclGetLibraryPath();
- if (pathPtr != NULL) {
- int i, objc;
- Tcl_Obj **objv;
-
- objc = 0;
- Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
- for (i = 0; i < objc; i++) {
- int length;
- char *string;
- Tcl_DString ds;
-
- string = Tcl_GetStringFromObj(objv[i], &length);
- Tcl_ExternalToUtfDString(NULL, string, length, &ds);
- Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
+ if (libraryPathEncodingFixed == 0) {
+ int platformId;
+ platformId = TclWinGetPlatformId();
+ TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT);
+
+ wsprintfA(buf, "cp%d", GetACP());
+ Tcl_SetSystemEncoding(NULL, buf);
+
+ if (platformId != VER_PLATFORM_WIN32_NT) {
+ Tcl_Obj *pathPtr = TclGetLibraryPath();
+ if (pathPtr != NULL) {
+ int i, objc;
+ Tcl_Obj **objv;
+
+ objc = 0;
+ Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+ for (i = 0; i < objc; i++) {
+ int length;
+ char *string;
+ Tcl_DString ds;
+
+ string = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+ Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
}
}
+
+ libraryPathEncodingFixed = 1;
+ } else {
+ wsprintfA(buf, "cp%d", GetACP());
+ Tcl_SetSystemEncoding(NULL, buf);
}
- /*
- * Keep this encoding preloaded. The IO package uses it for gets on a
- * binary channel.
- */
-
- encoding = "iso8859-1";
- Tcl_GetEncoding(NULL, encoding);
+ /* This is only ever called from the startup thread */
+ if (binaryEncoding == NULL) {
+ /*
+ * Keep this encoding preloaded. The IO package uses it for
+ * gets on a binary channel.
+ */
+ encoding = "iso8859-1";
+ binaryEncoding = Tcl_GetEncoding(NULL, encoding);
+ }
}
\f
/*
* None.
*
* Side effects:
- * Sets "tclDefaultLibrary", "tcl_platform", and "env(HOME)" Tcl
- * variables.
+ * Sets "tcl_platform", and "env(HOME)" Tcl variables.
*
*----------------------------------------------------------------------
*/
TclpSetVariables(interp)
Tcl_Interp *interp; /* Interp to initialize. */
{
- char *ptr;
+ CONST char *ptr;
char buffer[TCL_INTEGER_SPACE * 2];
SYSTEM_INFO sysInfo;
OemId *oemId;
GetSystemInfo(&sysInfo);
/*
- * Initialize the tclDefaultLibrary variable from the registry.
- */
-
- Tcl_SetVar(interp, "tclDefaultLibrary", "", TCL_GLOBAL_ONLY);
-
- /*
* Define the tcl_platform array.
*/
Tcl_DStringSetLength(&ds, 100);
if (TclGetEnv("USERNAME", &ds) == NULL) {
- if (GetUserName(Tcl_DStringValue(&ds), &Tcl_DStringLength(&ds)) == 0) {
+ if (GetUserName(Tcl_DStringValue(&ds), (LPDWORD) &Tcl_DStringLength(&ds)) == 0) {
Tcl_DStringSetLength(&ds, 0);
}
}
if (p1 == NULL) {
continue;
}
- length = p1 - envUpper;
+ length = (int) (p1 - envUpper);
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
Tcl_Interp *interp; /* Interpreter to source rc file into. */
{
Tcl_DString temp;
- char *fileName;
+ CONST char *fileName;
Tcl_Channel errChannel;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
- char *fullName;
+ CONST char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
Tcl_DStringFree(&temp);
}
}
-\f
-/*
- *----------------------------------------------------------------------
- *
- * TclpAsyncMark --
- *
- * Wake up the main thread from a signal handler.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sends a message to the main thread.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpAsyncMark(async)
- Tcl_AsyncHandler async; /* Token for handler. */
-{
- /*
- * Need a way to kick the Windows event loop and tell it to go look at
- * asynchronous events.
- */
-
- PostThreadMessage(mainThreadId, WM_USER, 0, 0);
-}
-
-
-
CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
+ BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *,
+ GET_FILEEX_INFO_LEVELS, LPVOID);
+ BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*,
+ LPSECURITY_ATTRIBUTES);
} TclWinProcs;
EXTERN TclWinProcs *tclWinProcs;
-EXTERN Tcl_Encoding tclWinTCharEncoding;
/*
* Declarations of functions that are not accessible by way of the
*/
EXTERN void TclWinInit(HINSTANCE hInst);
+EXTERN int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal,
+ CONST TCHAR* LinkCopy);
+EXTERN int TclWinSymLinkDelete(CONST TCHAR* LinkOriginal,
+ int linkOnly);
+#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+EXTERN void TclWinFreeAllocCache(void);
+EXTERN void TclFreeAllocCache(void *);
+EXTERN Tcl_Mutex *TclpNewAllocMutex(void);
+EXTERN void *TclpGetAllocCache(void);
+EXTERN void TclpSetAllocCache(void *);
+#endif /* TCL_THREADS */
+
+/* Needed by tclWinFile.c and tclWinFCmd.c */
+#ifndef FILE_ATTRIBUTE_REPARSE_POINT
+#define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400
+#endif
+
+#include "tclIntPlatDecls.h"
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT
-#include "tclIntPlatDecls.h"
-
#endif /* _TCLWININT */
-
-
/*
*----------------------------------------------------------------------
*
- * TclpLoadFile --
+ * TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
+ * a handle to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
*/
int
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
+TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ Tcl_Obj *pathPtr; /* Name of the file containing the desired
+ * code (UTF-8). */
+ Tcl_LoadHandle *loadHandle; /* Filled with token for dynamically loaded
* file which will be passed back to
- * TclpUnloadFile() to unload the file. */
+ * (*unloadProcPtr)() to unload the file. */
+ Tcl_FSUnloadFileProc **unloadProcPtr;
+ /* Filled with address of Tcl_FSUnloadFileProc
+ * function which should be used for
+ * this file. */
{
HINSTANCE handle;
- TCHAR *nativeName;
- Tcl_DString ds;
+ CONST TCHAR *nativeName;
- nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+ /*
+ * First try the full path the user gave us. This is particularly
+ * important if the cwd is inside a vfs, and we are trying to load
+ * using a relative path.
+ */
+ nativeName = Tcl_FSGetNativePath(pathPtr);
handle = (*tclWinProcs->loadLibraryProc)(nativeName);
- Tcl_DStringFree(&ds);
+ if (handle == NULL) {
+ /*
+ * Let the OS loader examine the binary search path for
+ * whatever string the user gave us which hopefully refers
+ * to a file on the binary path
+ */
+ Tcl_DString ds;
+ char *fileName = Tcl_GetString(pathPtr);
+ nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+ handle = (*tclWinProcs->loadLibraryProc)(nativeName);
+ Tcl_DStringFree(&ds);
+ }
- *clientDataPtr = (ClientData) handle;
+ *loadHandle = (Tcl_LoadHandle) handle;
if (handle == NULL) {
DWORD lastError = GetLastError();
sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
#endif
Tcl_AppendResult(interp, "couldn't load library \"",
- fileName, "\": ", (char *) NULL);
+ Tcl_GetString(pathPtr), "\": ", (char *) NULL);
/*
* Check for possible DLL errors. This doesn't work quite right,
* because Windows seems to only return ERROR_MOD_NOT_FOUND for
case ERROR_MOD_NOT_FOUND:
case ERROR_DLL_NOT_FOUND:
Tcl_AppendResult(interp, "this library or a dependent library",
- " could not be found in library path", (char *)
- NULL);
+ " could not be found in library path",
+ (char *) NULL);
+ break;
+ case ERROR_PROC_NOT_FOUND:
+ Tcl_AppendResult(interp, "could not find specified procedure",
+ (char *) NULL);
break;
case ERROR_INVALID_DLL:
Tcl_AppendResult(interp, "this library or a dependent library",
(char *) NULL);
}
return TCL_ERROR;
+ } else {
+ *unloadProcPtr = &TclpUnloadFile;
}
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindSymbol --
+ *
+ * Looks up a symbol, by name, through a handle associated with
+ * a previously loaded piece of code (shared library).
+ *
+ * Results:
+ * Returns a pointer to the function associated with 'symbol' if
+ * it is found. Otherwise returns NULL and may leave an error
+ * message in the interp's result.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_PackageInitProc*
+TclpFindSymbol(interp, loadHandle, symbol)
+ Tcl_Interp *interp;
+ Tcl_LoadHandle loadHandle;
+ CONST char *symbol;
+{
+ Tcl_PackageInitProc *proc = NULL;
+ HINSTANCE handle = (HINSTANCE)loadHandle;
/*
* For each symbol, check for both Symbol and _Symbol, since Borland
* generates C symbols with a leading '_' by default.
*/
- *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
- if (*proc1Ptr == NULL) {
+ proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
+ if (proc == NULL) {
+ Tcl_DString ds;
+ Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "_", 1);
- sym1 = Tcl_DStringAppend(&ds, sym1, -1);
- *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
+ symbol = Tcl_DStringAppend(&ds, symbol, -1);
+ proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
Tcl_DStringFree(&ds);
}
-
- *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
- if (*proc2Ptr == NULL) {
- Tcl_DStringAppend(&ds, "_", 1);
- sym2 = Tcl_DStringAppend(&ds, sym2, -1);
- *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
- Tcl_DStringFree(&ds);
- }
- return TCL_OK;
+ return proc;
}
\f
/*
*/
void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
+TclpUnloadFile(loadHandle)
+ Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
+ * to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
HINSTANCE handle;
- handle = (HINSTANCE) clientData;
+ handle = (HINSTANCE) loadHandle;
FreeLibrary(handle);
}
\f
int
TclGuessPackageName(fileName, bufPtr)
- char *fileName; /* Name of file containing package (already
+ CONST char *fileName; /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr; /* Initialized empty dstring. Append
* package name to this if possible. */
{
return 0;
}
-
-
_matherr(xPtr)
struct exception *xPtr; /* Describes error that occurred. */
{
- if (!TclMathInProgress()) {
- return 0;
- }
- if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) {
+ if ((xPtr->type == DOMAIN)
+#ifdef __BORLANDC__
+ || (xPtr->type == TLOSS)
+#endif
+ || (xPtr->type == SING)) {
errno = EDOM;
} else {
errno = ERANGE;
}
return 1;
}
-
-
*/
#include "tclWinInt.h"
-#include <winsock.h>
/*
* The follwing static indicates whether this module has been initialized.
*/
-static int initialized = 0;
-
#define INTERVAL_TIMER 1 /* Handle of interval timer. */
#define WM_WAKEUP WM_USER /* Message that is send by
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+ /*
+ * Only finalize the notifier if a notifier was installed in the
+ * current thread; there is a route in which this is not
+ * guaranteed to be true (when tclWin32Dll.c:DllMain() is called
+ * with the flag DLL_PROCESS_DETACH by the OS, which could be
+ * doing so from a thread that's never previously been involved
+ * with Tcl, e.g. the task manager) so this check is important.
+ *
+ * Fixes Bug #217982 reported by Hugh Vu and Gene Leache.
+ */
+ if (tsdPtr == NULL) {
+ return;
+ }
+
DeleteCriticalSection(&tsdPtr->crit);
CloseHandle(tsdPtr->event);
* propagate the quit message and start unwinding.
*/
- PostQuitMessage(msg.wParam);
+ PostQuitMessage((int) msg.wParam);
status = -1;
} else if (result == -1) {
/*
Tcl_Sleep(ms)
int ms; /* Number of milliseconds to sleep. */
{
- Sleep(ms);
-}
+ /*
+ * Simply calling 'Sleep' for the requisite number of milliseconds
+ * can make the process appear to wake up early because it isn't
+ * synchronized with the CPU performance counter that is used in
+ * tclWinTime.c. This behavior is probably benign, but messes
+ * up some of the corner cases in the test suite. We get around
+ * this problem by repeating the 'Sleep' call as many times
+ * as necessary to make the clock advance by the requisite amount.
+ */
+ Tcl_Time now; /* Current wall clock time */
+ Tcl_Time desired; /* Desired wakeup time */
+ int sleepTime = ms; /* Time to sleep */
+ Tcl_GetTime( &now );
+ desired.sec = now.sec + ( ms / 1000 );
+ desired.usec = now.usec + 1000 * ( ms % 1000 );
+ if ( desired.usec > 1000000 ) {
+ ++desired.sec;
+ desired.usec -= 1000000;
+ }
+
+ for ( ; ; ) {
+ Sleep( sleepTime );
+ Tcl_GetTime( &now );
+ if ( now.sec > desired.sec ) {
+ break;
+ } else if ( ( now.sec == desired.sec )
+ && ( now.usec >= desired.usec ) ) {
+ break;
+ }
+ sleepTime = ( ( 1000 * ( desired.sec - now.sec ) )
+ + ( ( desired.usec - now.usec ) / 1000 ) );
+ }
+
+}
#include "tclWinInt.h"
-/* CYGNUS LOCAL */
-#ifndef __CYGWIN__
-#include <dos.h>
-#endif
-/* END CYGNUS LOCAL */
-
#include <fcntl.h>
#include <io.h>
#include <sys/stat.h>
HANDLE startReader; /* Auto-reset event used by the main thread to
* signal when the reader thread should attempt
* to read from the pipe. */
+ HANDLE stopReader; /* Manual-reset event used to alert the reader
+ * thread to fall-out and exit */
DWORD writeError; /* An error caused by the last background
* write. Set to 0 if no error has been
* detected. This word is shared with the
static int ApplicationType(Tcl_Interp *interp,
const char *fileName, char *fullName);
static void BuildCommandLine(const char *executable, int argc,
- char **argv, Tcl_DString *linePtr);
+ CONST char **argv, Tcl_DString *linePtr);
static BOOL HasConsole(void);
static int PipeBlockModeProc(ClientData instanceData, int mode);
static void PipeCheckProc(ClientData clientData, int flags);
static void PipeInit(void);
static int PipeInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
-static int PipeOutputProc(ClientData instanceData, char *buf,
- int toWrite, int *errorCode);
+static int PipeOutputProc(ClientData instanceData,
+ CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI PipeReaderThread(LPVOID arg);
static void PipeSetupProc(ClientData clientData, int flags);
static void PipeWatchProc(ClientData instanceData, int mask);
HANDLE handle;
DWORD accessMode, createMode, shareMode, flags;
Tcl_DString ds;
- TCHAR *nativePath;
+ CONST TCHAR *nativePath;
/*
* Map the access bits to the NT access mode.
/*
*----------------------------------------------------------------------
*
+ * TclpTempFileName --
+ *
+ * This function returns a unique filename.
+ *
+ * Results:
+ * Returns a valid Tcl_Obj* with refCount 0, or NULL on failure.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclpTempFileName()
+{
+ WCHAR fileName[MAX_PATH];
+
+ if (TempFileName(fileName) == 0) {
+ return NULL;
+ }
+
+ return TclpNativeToNormalized((ClientData) fileName);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclpCreatePipe --
*
* Creates an anonymous pipe.
|| ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
- if (CloseHandle(filePtr->handle) == FALSE) {
+ if (filePtr->handle != NULL &&
+ CloseHandle(filePtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
ckfree((char *) filePtr);
return -1;
* Error messages from the child process
* itself are sent to errorFile. */
int argc, /* Number of arguments in following array. */
- char **argv, /* Array of argument strings. argv[0]
+ CONST char **argv, /* Array of argument strings. argv[0]
* contains the name of the executable
* converted to native format (using the
* Tcl_TranslateFileName call). Additional
if ((*tclWinProcs->createProcessProc)(NULL,
(TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
- createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
+ (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
TclWinConvertError(GetLastError());
Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
"\": ", Tcl_PosixError(interp), (char *) NULL);
DWORD attr, read;
IMAGE_DOS_HEADER header;
Tcl_DString nameBuf, ds;
- TCHAR *nativeName;
+ CONST TCHAR *nativeName;
WCHAR nativeFullPath[MAX_PATH];
static char extensions[][5] = {"", ".com", ".exe", ".bat"};
*/
CloseHandle(hFile);
- if ((ext != NULL) && (strcmp(ext, ".com") == 0)) {
+ if ((ext != NULL) && (stricmp(ext, ".com") == 0)) {
applType = APPL_DOS;
break;
}
CONST char *executable, /* Full path of executable (including
* extension). Replacement for argv[0]. */
int argc, /* Number of arguments. */
- char **argv, /* Argument strings in UTF. */
+ CONST char **argv, /* Argument strings in UTF. */
Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
* command line (TCHAR). */
{
}
quote = 0;
- if (argv[i][0] == '\0') {
+ if (arg[0] == '\0') {
quote = 1;
} else {
- for (start = argv[i]; *start != '\0'; start++) {
+ for (start = arg; *start != '\0'; start++) {
if (isspace(*start)) { /* INTL: ISO space. */
quote = 1;
break;
Tcl_DStringAppend(&ds, "\\\"", 2);
start = special + 1;
}
+ if (*special == '{') {
+ Tcl_DStringAppend(&ds, start, special - start);
+ Tcl_DStringAppend(&ds, "\\{", 2);
+ start = special + 1;
+ }
if (*special == '\0') {
break;
}
Tcl_DStringAppend(&ds, "\"", 1);
}
}
+ Tcl_DStringFree(linePtr);
Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
}
infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->readThread = CreateThread(NULL, 8000, PipeReaderThread,
+ infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL);
+ infoPtr->readThread = CreateThread(NULL, 512, PipeReaderThread,
infoPtr, 0, &id);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_READABLE;
}
if (writeFile != NULL) {
/*
- * Start the background writeer thwrite.
+ * Start the background writer thread.
*/
infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->writeThread = CreateThread(NULL, 8000, PipeWriterThread,
+ infoPtr->writeThread = CreateThread(NULL, 512, PipeWriterThread,
infoPtr, 0, &id);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_WRITABLE;
int errorCode, result;
PipeInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ DWORD exitCode;
errorCode = 0;
if ((!flags || (flags == TCL_CLOSE_READ))
if (pipePtr->readThread) {
/*
- * Forcibly terminate the background thread. We cannot rely on the
- * thread to cleanly terminate itself because we have no way of
- * closing the pipe handle without blocking in the case where the
- * thread is in the middle of an I/O operation. Note that we need
- * to guard against terminating the thread while it is in the
- * middle of Tcl_ThreadAlert because it won't be able to release
- * the notifier lock.
+ * The thread may already have closed on it's own. Check it's
+ * exit code.
*/
- Tcl_MutexLock(&pipeMutex);
- TerminateThread(pipePtr->readThread, 0);
+ GetExitCodeThread(pipePtr->readThread, &exitCode);
- /*
- * Wait for the thread to terminate. This ensures that we are
- * completely cleaned up before we leave this function.
- */
+ if (exitCode == STILL_ACTIVE) {
+ /*
+ * Set the stop event so that if the reader thread is blocked
+ * in PipeReaderThread on WaitForMultipleEvents, it will exit
+ * cleanly.
+ */
- WaitForSingleObject(pipePtr->readThread, INFINITE);
- Tcl_MutexUnlock(&pipeMutex);
+ SetEvent(pipePtr->stopReader);
+
+ /*
+ * Wait at most 10 milliseconds for the reader thread to close.
+ */
+
+ WaitForSingleObject(pipePtr->readThread, 10);
+ GetExitCodeThread(pipePtr->readThread, &exitCode);
+
+ if (exitCode == STILL_ACTIVE) {
+ /*
+ * The thread must be blocked waiting for the pipe to
+ * become readable in ReadFile(). There isn't a clean way
+ * to exit the thread from this condition. We should
+ * terminate the child process instead to get the reader
+ * thread to fall out of ReadFile with a FALSE. (below) is
+ * not the correct way to do this, but will stay here until
+ * a better solution is found.
+ *
+ * Note that we need to guard against terminating the
+ * thread while it is in the middle of Tcl_ThreadAlert
+ * because it won't be able to release the notifier lock.
+ */
+
+ Tcl_MutexLock(&pipeMutex);
+
+ /* BUG: this leaks memory */
+ TerminateThread(pipePtr->readThread, 0);
+
+ /* Wait for the thread to terminate. */
+ WaitForSingleObject(pipePtr->readThread, INFINITE);
+
+ Tcl_MutexUnlock(&pipeMutex);
+ }
+ }
CloseHandle(pipePtr->readThread);
CloseHandle(pipePtr->readable);
CloseHandle(pipePtr->startReader);
+ CloseHandle(pipePtr->stopReader);
pipePtr->readThread = NULL;
}
if (TclpCloseFile(pipePtr->readFile) != 0) {
static int
PipeOutputProc(
ClientData instanceData, /* Pipe state. */
- char *buf, /* The data buffer. */
+ CONST char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
- infoPtr->writeBuf = ckalloc(toWrite);
+ infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
}
- memcpy(infoPtr->writeBuf, buf, toWrite);
+ memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->writable);
SetEvent(infoPtr->startWriter);
int options)
{
ProcInfo *infoPtr, **prevPtrPtr;
- int flags;
+ DWORD flags;
Tcl_Pid result;
DWORD ret;
}
} else if (ret != WAIT_FAILED) {
GetExitCodeProcess(infoPtr->hProcess, (DWORD*)statPtr);
-#ifdef __OLD_CYGWIN__
- /* A cygwin program that exits because of a signal will set
- the exit status to 0x10000 | (sig << 8). Fix that back
- into a standard Unix wait status. */
- if ((*statPtr & 0x10000) != 0
- && (*statPtr & 0xff00) != 0
- && (*statPtr & ~ 0x1ff00) == 0) {
- *statPtr = (*statPtr >> 8) & 0xff;
- } else
-#endif
*statPtr = ((*statPtr << 8) & 0xff00);
result = pid;
} else {
* Side effects:
* Signals the main thread when input become available. May
* cause the main thread to wake up by posting a message. May
- * consume one byte from the pipe for each wait operation.
+ * consume one byte from the pipe for each wait operation. Will
+ * cause a memory leak of ~4k, if forcefully terminated with
+ * TerminateThread().
*
*----------------------------------------------------------------------
*/
HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
DWORD count, err;
int done = 0;
+ HANDLE wEvents[2];
+ DWORD dwWait;
+
+ wEvents[0] = infoPtr->stopReader;
+ wEvents[1] = infoPtr->startReader;
while (!done) {
/*
- * Wait for the main thread to signal before attempting to wait.
+ * Wait for the main thread to signal before attempting to wait
+ * on the pipe becoming readable.
*/
- WaitForSingleObject(infoPtr->startReader, INFINITE);
+ dwWait = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
+
+ if (dwWait != (WAIT_OBJECT_0 + 1)) {
+ /*
+ * The start event was not signaled. It might be the stop event
+ * or an error, so exit.
+ */
+
+ return 0;
+ }
/*
* Try waiting for 0 bytes. This will block until some data is
return 0;
}
-
-
-
#endif
#ifdef CHECK_UNICODE_CALLS
-
-#define _UNICODE
-#define UNICODE
-
-#define __TCHAR_DEFINED
-typedef float *_TCHAR;
-
-#define _TCHAR_DEFINED
-typedef float *TCHAR;
-
-#endif
+# define _UNICODE
+# define UNICODE
+# define __TCHAR_DEFINED
+ typedef float *_TCHAR;
+# define _TCHAR_DEFINED
+ typedef float *TCHAR;
+#endif /* CHECK_UNICODE_CALLS */
/*
*---------------------------------------------------------------------------
#ifndef __MWERKS__
#include <sys/stat.h>
#include <sys/timeb.h>
-#include <sys/utime.h>
-#endif
+# ifdef __BORLANDC__
+# include <utime.h>
+# else
+# include <sys/utime.h>
+# endif /* __BORLANDC__ */
+#endif /* __MWERKS__ */
#include <time.h>
-#include <winsock2.h>
-
-
#define WIN32_LEAN_AND_MEAN
-#define __USE_W32_SOCKETS
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
+#include <winsock2.h>
+
#ifdef BUILD_tcl
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLEXPORT
-#endif
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif /* BUILD_tcl */
/*
* Define EINPROGRESS in terms of WSAEINPROGRESS.
*/
#ifndef EINPROGRESS
-#define EINPROGRESS WSAEINPROGRESS
+# define EINPROGRESS WSAEINPROGRESS
#endif
/*
*/
#ifndef ENOTSUP
-#define ENOTSUP -1030507
+# define ENOTSUP -1030507
#endif
/*
*/
#ifndef EWOULDBLOCK
-#define EWOULDBLOCK EAGAIN
+# define EWOULDBLOCK EAGAIN
#endif
#ifndef EALREADY
-#define EALREADY 149 /* operation already in progress */
+# define EALREADY 149 /* operation already in progress */
#endif
#ifndef ENOTSOCK
-#define ENOTSOCK 95 /* Socket operation on non-socket */
+# define ENOTSOCK 95 /* Socket operation on non-socket */
#endif
#ifndef EDESTADDRREQ
-#define EDESTADDRREQ 96 /* Destination address required */
+# define EDESTADDRREQ 96 /* Destination address required */
#endif
#ifndef EMSGSIZE
-#define EMSGSIZE 97 /* Message too long */
+# define EMSGSIZE 97 /* Message too long */
#endif
#ifndef EPROTOTYPE
-#define EPROTOTYPE 98 /* Protocol wrong type for socket */
+# define EPROTOTYPE 98 /* Protocol wrong type for socket */
#endif
#ifndef ENOPROTOOPT
-#define ENOPROTOOPT 99 /* Protocol not available */
+# define ENOPROTOOPT 99 /* Protocol not available */
#endif
#ifndef EPROTONOSUPPORT
-#define EPROTONOSUPPORT 120 /* Protocol not supported */
+# define EPROTONOSUPPORT 120 /* Protocol not supported */
#endif
#ifndef ESOCKTNOSUPPORT
-#define ESOCKTNOSUPPORT 121 /* Socket type not supported */
+# define ESOCKTNOSUPPORT 121 /* Socket type not supported */
#endif
#ifndef EOPNOTSUPP
-#define EOPNOTSUPP 122 /* Operation not supported on socket */
+# define EOPNOTSUPP 122 /* Operation not supported on socket */
#endif
#ifndef EPFNOSUPPORT
-#define EPFNOSUPPORT 123 /* Protocol family not supported */
+# define EPFNOSUPPORT 123 /* Protocol family not supported */
#endif
#ifndef EAFNOSUPPORT
-#define EAFNOSUPPORT 124 /* Address family not supported */
+# define EAFNOSUPPORT 124 /* Address family not supported */
#endif
#ifndef EADDRINUSE
-#define EADDRINUSE 125 /* Address already in use */
+# define EADDRINUSE 125 /* Address already in use */
#endif
#ifndef EADDRNOTAVAIL
-#define EADDRNOTAVAIL 126 /* Can't assign requested address */
+# define EADDRNOTAVAIL 126 /* Can't assign requested address */
#endif
#ifndef ENETDOWN
-#define ENETDOWN 127 /* Network is down */
+# define ENETDOWN 127 /* Network is down */
#endif
#ifndef ENETUNREACH
-#define ENETUNREACH 128 /* Network is unreachable */
+# define ENETUNREACH 128 /* Network is unreachable */
#endif
#ifndef ENETRESET
-#define ENETRESET 129 /* Network dropped connection on reset */
+# define ENETRESET 129 /* Network dropped connection on reset */
#endif
#ifndef ECONNABORTED
-#define ECONNABORTED 130 /* Software caused connection abort */
+# define ECONNABORTED 130 /* Software caused connection abort */
#endif
#ifndef ECONNRESET
-#define ECONNRESET 131 /* Connection reset by peer */
+# define ECONNRESET 131 /* Connection reset by peer */
#endif
#ifndef ENOBUFS
-#define ENOBUFS 132 /* No buffer space available */
+# define ENOBUFS 132 /* No buffer space available */
#endif
#ifndef EISCONN
-#define EISCONN 133 /* Socket is already connected */
+# define EISCONN 133 /* Socket is already connected */
#endif
#ifndef ENOTCONN
-#define ENOTCONN 134 /* Socket is not connected */
+# define ENOTCONN 134 /* Socket is not connected */
#endif
#ifndef ESHUTDOWN
-#define ESHUTDOWN 143 /* Can't send after socket shutdown */
+# define ESHUTDOWN 143 /* Can't send after socket shutdown */
#endif
#ifndef ETOOMANYREFS
-#define ETOOMANYREFS 144 /* Too many references: can't splice */
+# define ETOOMANYREFS 144 /* Too many references: can't splice */
#endif
#ifndef ETIMEDOUT
-#define ETIMEDOUT 145 /* Connection timed out */
+# define ETIMEDOUT 145 /* Connection timed out */
#endif
#ifndef ECONNREFUSED
-#define ECONNREFUSED 146 /* Connection refused */
+# define ECONNREFUSED 146 /* Connection refused */
#endif
#ifndef ELOOP
-#define ELOOP 90 /* Symbolic link loop */
+# define ELOOP 90 /* Symbolic link loop */
#endif
#ifndef EHOSTDOWN
-#define EHOSTDOWN 147 /* Host is down */
+# define EHOSTDOWN 147 /* Host is down */
#endif
#ifndef EHOSTUNREACH
-#define EHOSTUNREACH 148 /* No route to host */
+# define EHOSTUNREACH 148 /* No route to host */
#endif
#ifndef ENOTEMPTY
-#define ENOTEMPTY 93 /* directory not empty */
+# define ENOTEMPTY 93 /* directory not empty */
#endif
#ifndef EUSERS
-#define EUSERS 94 /* Too many users (for UFS) */
+# define EUSERS 94 /* Too many users (for UFS) */
#endif
#ifndef EDQUOT
-#define EDQUOT 49 /* Disc quota exceeded */
+# define EDQUOT 69 /* Disc quota exceeded */
#endif
#ifndef ESTALE
-#define ESTALE 151 /* Stale NFS file handle */
+# define ESTALE 151 /* Stale NFS file handle */
#endif
#ifndef EREMOTE
-#define EREMOTE 66 /* The object is remote */
+# define EREMOTE 66 /* The object is remote */
#endif
-/* On cygwin, we just use the supplied malloc and free, rather than
- using tclAlloc.c. The cygwin32 malloc is derived from the same
- sources as tclAlloc.c, anyhow. */
-#if defined(__CYGWIN__) && !defined(__WIN32__)
-#define TclpAlloc(size) malloc(size)
-#define TclpFree(ptr) free(ptr)
-#define TclpRealloc(ptr, size) realloc(ptr, size)
-#else
-#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \
- (DWORD)0, (DWORD)size))
-#define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \
- (DWORD)0, (HGLOBAL)ptr))
-#define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \
- (DWORD)0, (LPVOID)ptr, (DWORD)size))
-#endif
+/*
+ * It is very hard to determine how Windows reacts to attempting to
+ * set a file pointer outside the input datatype's representable
+ * region. So we fake the error code ourselves.
+ */
+
+#ifndef EOVERFLOW
+# ifdef EFBIG
+# define EOVERFLOW EFBIG /* The object couldn't fit in the datatype */
+# else /* !EFBIG */
+# define EOVERFLOW EINVAL /* Better than nothing! */
+# endif /* EFBIG */
+#endif /* !EOVERFLOW */
/*
* Supply definitions for macros to query wait status, if not already
# define WAIT_STATUS_TYPE union wait
#else
# define WAIT_STATUS_TYPE int
-#endif
+#endif /* TCL_UNION_WAIT */
#ifndef WIFEXITED
# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0)
* defined.
*/
+#ifndef S_IFLNK
+#define S_IFLNK 0120000 /* Symbolic Link */
+#endif
+
#ifndef S_ISREG
# ifdef S_IFREG
# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
# else
# define S_ISREG(m) 0
# endif
-# endif
+#endif /* !S_ISREG */
#ifndef S_ISDIR
# ifdef S_IFDIR
# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
# else
# define S_ISDIR(m) 0
# endif
-# endif
+#endif /* !S_ISDIR */
#ifndef S_ISCHR
# ifdef S_IFCHR
# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
# else
# define S_ISCHR(m) 0
# endif
-# endif
+#endif /* !S_ISCHR */
#ifndef S_ISBLK
# ifdef S_IFBLK
# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
# else
# define S_ISBLK(m) 0
# endif
-# endif
+#endif /* !S_ISBLK */
#ifndef S_ISFIFO
# ifdef S_IFIFO
# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
# else
# define S_ISFIFO(m) 0
# endif
-# endif
+#endif /* !S_ISFIFO */
+#ifndef S_ISLNK
+# ifdef S_IFLNK
+# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
+# else
+# define S_ISLNK(m) 0
+# endif
+#endif /* !S_ISLNK */
+
/*
* Define MAXPATHLEN in terms of MAXPATH if available
#if ! TCL_PID_T
# define pid_t int
-#endif
+#endif /* !TCL_PID_T */
#if ! TCL_UID_T
# define uid_t int
-#endif
+#endif /* !TCL_UID_T */
/*
* Visual C++ has some odd names for common functions, so we need to
# endif
#endif /* _MSC_VER || __MINGW32__ */
+/*
+ * Borland's timezone and environ functions.
+ */
+
+#ifdef __BORLANDC__
+# define timezone _timezone
+# define environ _environ
+#endif /* __BORLANDC__ */
+
#ifdef __CYGWIN__
-/* On cygwin32, the environment is imported from the cygwin32 DLL. */
-__declspec(dllimport) extern char **__cygwin_environ;
+/* On Cygwin, the environment is imported from the Cygwin DLL. */
+ DLLIMPORT extern char **__cygwin_environ;
# define environ __cygwin_environ
# define putenv TclCygwinPutenv
# define timezone _timezone
-extern int chdir (const char*);
#endif /* __CYGWIN__ */
/*
+ * There is no platform-specific panic routine for Windows in the Tcl internals.
+ */
+
+#define TclpPanic ((Tcl_PanicProc *) NULL)
+
+/*
*---------------------------------------------------------------------------
* The following macros and declarations represent the interface between
* generic and windows-specific parts of Tcl. Some of the macros may
#define USE_PUTENV 1
/*
+ * Msvcrt's putenv() copies the string rather than takes ownership of it.
+ */
+
+#if defined(_MSC_VER) || defined(__MINGW32__)
+# define HAVE_PUTENV_THAT_COPIES 1
+#endif
+
+/*
* The following defines wrap the system memory allocation routines for
* use by tclAlloc.c.
*/
-#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \
+#ifdef __CYGWIN__
+# define TclpSysAlloc(size, isBin) malloc((size))
+# define TclpSysFree(ptr) free((ptr))
+# define TclpSysRealloc(ptr, size) realloc((ptr), (size))
+#else
+# define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \
(DWORD)0, (DWORD)size))
-#define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \
+# define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \
(DWORD)0, (HGLOBAL)ptr))
-#define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \
+# define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \
(DWORD)0, (LPVOID)ptr, (DWORD)size))
+#endif
/*
* The following defines map from standard socket names to our internal
#define getsockopt TclWinGetSockOpt
#define ntohs TclWinNToHS
#define setsockopt TclWinSetSockOpt
+/* This type is not defined in the Windows headers */
+#define socklen_t int
+
/*
* The following macros have trivial definitions, allowing generic code to
*/
#define TclpExit exit
-#define TclpLstat TclpStat
/*
* Declarations for Windows-only functions.
*/
+EXTERN HANDLE TclWinSerialReopen _ANSI_ARGS_(( HANDLE handle,
+ CONST TCHAR *name, DWORD access));
+
EXTERN Tcl_Channel TclWinOpenSerialChannel _ANSI_ARGS_((HANDLE handle,
char *channelName, int permissions));
EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr));
EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr));
-#else
+#else /* !TCL_THREADS */
typedef int TclpMutex;
#define TclpMutexInit(a)
#define TclpMutexLock(a)
#define TclpMutexUnlock(a)
#endif /* TCL_THREADS */
+#ifdef TCL_WIDE_INT_TYPE
+EXTERN Tcl_WideInt strtoll _ANSI_ARGS_((CONST char *string,
+ char **endPtr, int base));
+EXTERN Tcl_WideUInt strtoull _ANSI_ARGS_((CONST char *string,
+ char **endPtr, int base));
+#endif /* TCL_WIDE_INT_TYPE */
+
+#ifndef INVALID_SET_FILE_POINTER
+#define INVALID_SET_FILE_POINTER 0xFFFFFFFF
+#endif /* INVALID_SET_FILE_POINTER */
+
#include "tclPlatDecls.h"
#include "tclIntPlatDecls.h"
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLIMPORT
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLWINPORT */
-
#include <tclPort.h>
#include <stdlib.h>
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
/*
* TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
* Registry_Init declaration is in the source file itself, which is only
* to the system predefined keys.
*/
-static char *rootKeyNames[] = {
+static CONST char *rootKeyNames[] = {
"HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
"HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
"HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
* mapping.
*/
-static char *typeNames[] = {
+static CONST char *typeNames[] = {
"none", "sz", "expand_sz", "binary", "dword",
"dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
typedef struct RegWinProcs {
int useWide;
- LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY);
+ LONG (WINAPI *regConnectRegistryProc)(CONST TCHAR *, HKEY, PHKEY);
LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
static RegWinProcs asciiProcs = {
0,
- (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
+ (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
DWORD *)) RegCreateKeyExA,
static RegWinProcs unicodeProcs = {
1,
- (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
+ (LONG (WINAPI *)(CONST TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
(LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
DWORD *)) RegCreateKeyExW,
*/
static void AppendSystemError(Tcl_Interp *interp, DWORD error);
+static int BroadcastValue(Tcl_Interp *interp, int objc,
+ Tcl_Obj * CONST objv[]);
static DWORD ConvertDWORD(DWORD type, DWORD value);
static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
static int ParseKeyName(Tcl_Interp *interp, char *name,
char **hostNamePtr, HKEY *rootKeyPtr,
char **keyNamePtr);
-static DWORD RecursiveDeleteKey(HKEY hStartKey, TCHAR * pKeyName);
+static DWORD RecursiveDeleteKey(HKEY hStartKey,
+ CONST TCHAR * pKeyName);
static int RegistryObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj * CONST objv[]);
int index;
char *errString;
- static char *subcommands[] = { "delete", "get", "keys", "set", "type",
- "values", (char *) NULL };
- enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };
+ static CONST char *subcommands[] = {
+ "broadcast", "delete", "get", "keys", "set", "type", "values",
+ (char *) NULL
+ };
+ enum SubCmdIdx {
+ BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
+ };
if (objc < 2) {
Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
}
switch (index) {
+ case BroadcastIdx: /* broadcast */
+ return BroadcastValue(interp, objc, objv);
+ break;
case DeleteIdx: /* delete */
if (objc == 3) {
return DeleteKey(interp, objv[2]);
Tcl_Obj *keyNameObj) /* Name of key to delete. */
{
char *tail, *buffer, *hostName, *keyName;
+ CONST char *nativeTail;
HKEY rootKey, subkey;
DWORD result;
int length;
*/
keyName = Tcl_GetStringFromObj(keyNameObj, &length);
- buffer = ckalloc(length + 1);
+ buffer = ckalloc((unsigned int) length + 1);
strcpy(buffer, keyName);
if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
* Now we recursively delete the key and everything below it.
*/
- tail = Tcl_WinUtfToTChar(tail, -1, &buf);
- result = RecursiveDeleteKey(subkey, tail);
+ nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf);
+ result = RecursiveDeleteKey(subkey, nativeTail);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
DWORD type;
Tcl_DString ds;
char *valueName;
+ CONST char *nativeValue;
int length;
/*
resultPtr = Tcl_GetObjResult(interp);
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
- valueName = Tcl_WinUtfToTChar(valueName, length, &ds);
- result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
+ nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds);
+ result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
*/
if (type > lastType || type < 0) {
- Tcl_SetIntObj(resultPtr, type);
+ Tcl_SetIntObj(resultPtr, (int) type);
} else {
Tcl_SetStringObj(resultPtr, typeNames[type], -1);
}
{
HKEY key;
char *valueName;
+ CONST char *nativeValue;
DWORD result, length, type;
Tcl_Obj *resultPtr;
Tcl_DString data, buf;
Tcl_DStringInit(&data);
length = TCL_DSTRING_STATIC_SIZE - 1;
- Tcl_DStringSetLength(&data, length);
+ Tcl_DStringSetLength(&data, (int) length);
resultPtr = Tcl_GetObjResult(interp);
valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
- valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
+ nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
- result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
+ result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
* Required for HKEY_PERFORMANCE_DATA
*/
length *= 2;
- Tcl_DStringSetLength(&data, length);
- result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL,
- &type, (BYTE *) Tcl_DStringValue(&data), &length);
+ Tcl_DStringSetLength(&data, (int) length);
+ result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue,
+ NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
Tcl_DStringFree(&buf);
RegCloseKey(key);
*/
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
- Tcl_SetIntObj(resultPtr, ConvertDWORD(type,
+ Tcl_SetIntObj(resultPtr, (int) ConvertDWORD(type,
*((DWORD*) Tcl_DStringValue(&data))));
} else if (type == REG_MULTI_SZ) {
char *p = Tcl_DStringValue(&data);
* Save binary data as a byte array.
*/
- Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), length);
+ Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), (int) length);
}
Tcl_DStringFree(&data);
return result;
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer,
- (regWinProcs->useWide) ? maxSize*2 : maxSize);
+ (int) ((regWinProcs->useWide) ? maxSize*2 : maxSize));
index = 0;
result = TCL_OK;
size *= 2;
}
- Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), size, &ds);
+ Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
DWORD result;
keyName = Tcl_GetStringFromObj(keyNameObj, &length);
- buffer = ckalloc(length + 1);
+ buffer = ckalloc((unsigned int) length + 1);
strcpy(buffer, keyName);
result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
*/
if (hostName) {
- hostName = Tcl_WinUtfToTChar(hostName, -1, &buf);
+ hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf);
result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey,
&rootKey);
Tcl_DStringFree(&buf);
* that this key must be closed by the caller.
*/
- keyName = Tcl_WinUtfToTChar(keyName, -1, &buf);
+ keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
if (flags & REG_CREATE) {
DWORD create;
result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "",
static DWORD
RecursiveDeleteKey(
HKEY startKey, /* Parent of key to be deleted. */
- char *keyName) /* Name of key to be deleted in external
+ CONST char *keyName) /* Name of key to be deleted in external
* encoding, not UTF. */
{
DWORD result, size, maxSize;
Tcl_DStringInit(&subkey);
Tcl_DStringSetLength(&subkey,
- (regWinProcs->useWide) ? maxSize * 2 : maxSize);
+ (int) ((regWinProcs->useWide) ? maxSize * 2 : maxSize));
while (result == ERROR_SUCCESS) {
/*
}
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
- valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf);
+ valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf);
resultPtr = Tcl_GetObjResult(interp);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
Tcl_DString buf;
char *data = Tcl_GetStringFromObj(dataObj, &length);
- data = Tcl_WinUtfToTChar(data, length, &buf);
+ data = (char *) Tcl_WinUtfToTChar(data, length, &buf);
/*
* Include the null in the length, padding if needed for Unicode.
length = Tcl_DStringLength(&buf) + 1;
result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- (BYTE*)data, length);
+ (BYTE*)data, (DWORD) length);
Tcl_DStringFree(&buf);
} else {
char *data;
data = Tcl_GetByteArrayFromObj(dataObj, &length);
result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- (BYTE *)data, length);
+ (BYTE *)data, (DWORD) length);
}
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
/*
*----------------------------------------------------------------------
*
+ * BroadcastValue --
+ *
+ * This function broadcasts a WM_SETTINGCHANGE message to indicate
+ * to other programs that we have changed the contents of a registry
+ * value.
+ *
+ * Results:
+ * Returns a normal Tcl result.
+ *
+ * Side effects:
+ * Will cause other programs to reload their system settings.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BroadcastValue(
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj * CONST objv[]) /* Argument values. */
+{
+ DWORD result, sendResult;
+ UINT timeout = 3000;
+ int len;
+ char *str;
+ Tcl_Obj *objPtr;
+
+ if ((objc != 3) && (objc != 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
+ return TCL_ERROR;
+ }
+
+ if (objc > 3) {
+ str = Tcl_GetStringFromObj(objv[3], &len);
+ if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ str = Tcl_GetStringFromObj(objv[2], &len);
+ if (len = 0) {
+ str = NULL;
+ }
+
+ /*
+ * Use the ignore the result.
+ */
+ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
+ (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);
+
+ objPtr = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(result));
+ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(sendResult));
+ Tcl_SetObjResult(interp, objPtr);
+
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* AppendSystemError --
*
* This routine formats a Windows system error message and places
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
msg = "function not supported under Win32s";
} else {
- sprintf(msgBuf, "unknown error: %d", error);
+ sprintf(msgBuf, "unknown error: %ld", error);
msg = msgBuf;
}
} else {
}
}
- sprintf(id, "%d", error);
+ sprintf(id, "%ld", error);
Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
Tcl_AppendToObj(resultPtr, msg, length);
localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
return (type != localType) ? SWAPLONG(value) : value;
}
-
-
-
/*
- * Tclwinserial.c --
+ * tclWinSerial.c --
*
* This file implements the Windows-specific serial port functions,
* and the "serial" channel driver.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- * Changes by Rolf.Schroedter@dlr.de June 25-27, 1999
+ *
+ * Serial functionality implemented by Rolf.Schroedter@dlr.de
*
* RCS: @(#) $Id$
*/
static int initialized = 0;
/*
+ * The serialMutex locks around access to the initialized variable, and it is
+ * used to protect background threads from being terminated while they are
+ * using APIs that hold locks.
+ */
+
+TCL_DECLARE_MUTEX(serialMutex)
+
+/*
* Bit masks used in the flags field of the SerialInfo structure below.
*/
#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */
#define SERIAL_ERROR (1<<4)
-#define SERIAL_WRITE (1<<5) /* enables fileevent writable
- * one time after write operation */
/*
* Default time to block between checking status on the serial port.
/*
* Define Win32 read/write error masks returned by ClearCommError()
*/
-#define SERIAL_READ_ERRORS ( CE_RXOVER | CE_OVERRUN | CE_RXPARITY \
- | CE_FRAME | CE_BREAK )
-#define SERIAL_WRITE_ERRORS ( CE_TXFULL )
+#define SERIAL_READ_ERRORS ( CE_RXOVER | CE_OVERRUN | CE_RXPARITY \
+ | CE_FRAME | CE_BREAK )
+#define SERIAL_WRITE_ERRORS ( CE_TXFULL | CE_PTO )
/*
* This structure describes per-instance data for a serial based channel.
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
* which events should be reported. */
int flags; /* State flags, see above for a list. */
- int writable; /* flag that the channel is readable */
int readable; /* flag that the channel is readable */
+ int writable; /* flag that the channel is writable */
int blockTime; /* max. blocktime in msec */
- DWORD error; /* pending error code returned by
- * ClearCommError() */
- DWORD lastError; /* last error code, can be fetched with
- * fconfigure chan -lasterror */
+ unsigned int lastEventTime; /* Time in milliseconds since last readable event */
+ /* Next readable event only after blockTime */
+ DWORD error; /* pending error code returned by
+ * ClearCommError() */
+ DWORD lastError; /* last error code, can be fetched with
+ * fconfigure chan -lasterror */
+ DWORD sysBufRead; /* Win32 system buffer size for read ops,
+ * default=4096 */
+ DWORD sysBufWrite; /* Win32 system buffer size for write ops,
+ * default=4096 */
+
+ Tcl_ThreadId threadId; /* Thread to which events should be reported.
+ * This value is used by the reader/writer
+ * threads. */
+ OVERLAPPED osRead; /* OVERLAPPED structure for read operations */
+ OVERLAPPED osWrite; /* OVERLAPPED structure for write operations */
+ HANDLE writeThread; /* Handle to writer thread. */
+ CRITICAL_SECTION csWrite; /* Writer thread synchronisation */
+ HANDLE evWritable; /* Manual-reset event to signal when the
+ * writer thread has finished waiting for
+ * the current buffer to be written. */
+ HANDLE evStartWriter; /* Auto-reset event used by the main thread to
+ * signal when the writer thread should attempt
+ * to write to the serial. */
+ DWORD writeError; /* An error caused by the last background
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
+ * writer thread so access must be
+ * synchronized with the evWritable object.
+ */
+ char *writeBuf; /* Current background output buffer.
+ * Access is synchronized with the evWritable
+ * object. */
+ int writeBufLen; /* Size of write buffer. Access is
+ * synchronized with the evWritable
+ * object. */
+ int toWrite; /* Current amount to be written. Access is
+ * synchronized with the evWritable object. */
+ int writeQueue; /* Number of bytes pending in output queue.
+ * Offset to DCB.cbInQue.
+ * Used to query [fconfigure -queue] */
} SerialInfo;
typedef struct ThreadSpecificData {
* pointer. */
} SerialEvent;
-COMMTIMEOUTS timeout_sync = { /* Timouts for blocking mode */
- MAXDWORD, /* ReadIntervalTimeout */
- MAXDWORD, /* ReadTotalTimeoutMultiplier */
- MAXDWORD-1, /* ReadTotalTimeoutConstant,
- MAXDWORD-1 works for both Win95/NT */
- 0, /* WriteTotalTimeoutMultiplier */
- 0, /* WriteTotalTimeoutConstant */
-};
+/*
+ * We don't use timeouts.
+ */
-COMMTIMEOUTS timeout_async = { /* Timouts for non-blocking mode */
+static COMMTIMEOUTS no_timeout = {
0, /* ReadIntervalTimeout */
0, /* ReadTotalTimeoutMultiplier */
- 1, /* ReadTotalTimeoutConstant */
+ 0, /* ReadTotalTimeoutConstant */
0, /* WriteTotalTimeoutMultiplier */
0, /* WriteTotalTimeoutConstant */
};
static ThreadSpecificData *SerialInit(void);
static int SerialInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
-static int SerialOutputProc(ClientData instanceData, char *buf,
+static int SerialOutputProc(ClientData instanceData, CONST char *buf,
int toWrite, int *errorCode);
static void SerialSetupProc(ClientData clientData, int flags);
static void SerialWatchProc(ClientData instanceData, int mask);
static void ProcExitHandler(ClientData clientData);
static int SerialGetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
+ Tcl_Interp *interp, CONST char *optionName,
Tcl_DString *dsPtr));
static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
- char *value));
+ Tcl_Interp *interp, CONST char *optionName,
+ CONST char *value));
+static DWORD WINAPI SerialWriterThread(LPVOID arg);
/*
* This structure describes the channel type structure for command serial
*/
static Tcl_ChannelType serialChannelType = {
- "serial", /* Type name. */
- TCL_CHANNEL_VERSION_2, /* v2 channel */
- SerialCloseProc, /* Close proc. */
- SerialInputProc, /* Input proc. */
- SerialOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- SerialSetOptionProc, /* Set option proc. */
- SerialGetOptionProc, /* Get option proc. */
- SerialWatchProc, /* Set up notifier to watch the channel. */
- SerialGetHandleProc, /* Get an OS handle from channel. */
- NULL, /* close2proc. */
- SerialBlockProc, /* Set blocking or non-blocking mode.*/
- NULL, /* flush proc. */
- NULL, /* handler proc. */
+ "serial", /* Type name. */
+ TCL_CHANNEL_VERSION_2, /* v2 channel */
+ SerialCloseProc, /* Close proc. */
+ SerialInputProc, /* Input proc. */
+ SerialOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ SerialSetOptionProc, /* Set option proc. */
+ SerialGetOptionProc, /* Get option proc. */
+ SerialWatchProc, /* Set up notifier to watch the channel. */
+ SerialGetHandleProc, /* Get an OS handle from channel. */
+ NULL, /* close2proc. */
+ SerialBlockProc, /* Set blocking or non-blocking mode.*/
+ NULL, /* flush proc. */
+ NULL, /* handler proc. */
};
-\f
+
/*
*----------------------------------------------------------------------
*
*/
if (!initialized) {
+ Tcl_MutexLock(&serialMutex);
if (!initialized) {
initialized = 1;
Tcl_CreateExitHandler(ProcExitHandler, NULL);
}
+ Tcl_MutexUnlock(&serialMutex);
}
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
}
return tsdPtr;
}
-\f
+
/*
*----------------------------------------------------------------------
*
SerialExitHandler(
ClientData clientData) /* Old window proc */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ SerialInfo *infoPtr;
+
+ /*
+ * Clear all eventually pending output.
+ * Otherwise Tcl's exit could totally block,
+ * because it performs a blocking flush on all open channels.
+ * Note that serial write operations may be blocked due to handshake.
+ */
+ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ PurgeComm(infoPtr->handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
+ | PURGE_RXCLEAR);
+
+ }
Tcl_DeleteEventSource(SerialSetupProc, SerialCheckProc, NULL);
}
-\f
+
/*
*----------------------------------------------------------------------
*
ProcExitHandler(
ClientData clientData) /* Old window proc */
{
+ Tcl_MutexLock(&serialMutex);
initialized = 0;
+ Tcl_MutexUnlock(&serialMutex);
}
-\f
+
/*
*----------------------------------------------------------------------
*
*----------------------------------------------------------------------
*/
-void
+static void
SerialBlockTime(
int msec) /* milli-seconds */
{
/*
*----------------------------------------------------------------------
*
+ * SerialGetMilliseconds --
+ *
+ * Get current time in milliseconds,
+ * Don't care about integer overruns
+ *
+ * Results:
+ * None.
+ *----------------------------------------------------------------------
+ */
+
+static unsigned int
+SerialGetMilliseconds(
+ void)
+{
+ Tcl_Time time;
+
+ TclpGetTime(&time);
+
+ return (time.sec * 1000 + time.usec / 1000);
+}
+/*
+ *----------------------------------------------------------------------
+ *
* SerialSetupProc --
*
* This procedure is invoked before Tcl_DoOneEvent blocks waiting
for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
- if( infoPtr->watchMask & (TCL_WRITABLE | TCL_READABLE) ) {
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
+ block = 0;
+ msec = min( msec, infoPtr->blockTime );
+ }
+ }
+ if( infoPtr->watchMask & TCL_READABLE ) {
block = 0;
msec = min( msec, infoPtr->blockTime );
}
SerialBlockTime(msec);
}
}
-\f
+
/*
*----------------------------------------------------------------------
*
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
COMSTAT cStat;
+ unsigned int time;
if (!(flags & TCL_FILE_EVENTS)) {
return;
needEvent = 0;
/*
- * If any READABLE or WRITABLE watch mask is set
- * call ClearCommError to poll cbInQue,cbOutQue
+ * If WRITABLE watch mask is set
+ * look for infoPtr->evWritable object
+ */
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) {
+ infoPtr->writable = 1;
+ needEvent = 1;
+ }
+ }
+
+ /*
+ * If READABLE watch mask is set
+ * call ClearCommError to poll cbInQue
* Window errors are ignored here
*/
- if( infoPtr->watchMask & (TCL_WRITABLE | TCL_READABLE) ) {
+ if( infoPtr->watchMask & TCL_READABLE ) {
if( ClearCommError( infoPtr->handle, &infoPtr->error, &cStat ) ) {
- /*
- * Look for empty output buffer. If empty, poll.
- */
-
- if( infoPtr->watchMask & TCL_WRITABLE ) {
- /*
- * force fileevent after serial write error
- */
- if (((infoPtr->flags & SERIAL_WRITE) != 0) &&
- ((cStat.cbOutQue == 0) ||
- (infoPtr->error & SERIAL_WRITE_ERRORS))) {
- /*
- * allow only one fileevent after each callback
- */
-
- infoPtr->flags &= ~SERIAL_WRITE;
- infoPtr->writable = 1;
- needEvent = 1;
- }
- }
-
/*
* Look for characters already pending in windows queue.
- * If they are, poll.
+ * If they are, poll.
*/
if( infoPtr->watchMask & TCL_READABLE ) {
- /*
- * force fileevent after serial read error
- */
- if( (cStat.cbInQue > 0) ||
- (infoPtr->error & SERIAL_READ_ERRORS) ) {
+ /*
+ * force fileevent after serial read error
+ */
+ if( (cStat.cbInQue > 0) ||
+ (infoPtr->error & SERIAL_READ_ERRORS) ) {
infoPtr->readable = 1;
- needEvent = 1;
+ time = SerialGetMilliseconds();
+ if ((unsigned int) (time - infoPtr->lastEventTime)
+ >= (unsigned int) infoPtr->blockTime) {
+ needEvent = 1;
+ infoPtr->lastEventTime = time;
+ }
}
}
}
/*
* Queue an event if the serial is signaled for reading or writing.
*/
-
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent));
}
}
}
-\f
+
/*
*----------------------------------------------------------------------
*
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
- COMMTIMEOUTS *timeout;
int errorCode = 0;
SerialInfo *infoPtr = (SerialInfo *) instanceData;
/*
- * Serial IO on Windows can not be switched between blocking & nonblocking,
- * hence we have to emulate the behavior. This is done in the input
- * function by checking against a bit in the state. We set or unset the
- * bit here to cause the input function to emulate the correct behavior.
+ * Only serial READ can be switched between blocking & nonblocking
+ * using COMMTIMEOUTS.
+ * Serial write emulates blocking & nonblocking by the SerialWriterThread.
*/
if (mode == TCL_MODE_NONBLOCKING) {
infoPtr->flags |= SERIAL_ASYNC;
- timeout = &timeout_async;
} else {
infoPtr->flags &= ~(SERIAL_ASYNC);
- timeout = &timeout_sync;
- }
- if (SetCommTimeouts(infoPtr->handle, timeout) == FALSE) {
- TclWinConvertError(GetLastError());
- errorCode = errno;
}
return errorCode;
}
-\f
+
/*
*----------------------------------------------------------------------
*
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
errorCode = 0;
+
+ if (serialPtr->validMask & TCL_READABLE) {
+ PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
+ CloseHandle(serialPtr->osRead.hEvent);
+ }
serialPtr->validMask &= ~TCL_READABLE;
+
+ if (serialPtr->validMask & TCL_WRITABLE) {
+
+ /*
+ * Generally we cannot wait for a pending write operation
+ * because it may hang due to handshake
+ * WaitForSingleObject(serialPtr->evWritable, INFINITE);
+ */
+ /*
+ * Forcibly terminate the background thread. We cannot rely on the
+ * thread to cleanly terminate itself because we have no way of
+ * closing the handle without blocking in the case where the
+ * thread is in the middle of an I/O operation. Note that we need
+ * to guard against terminating the thread while it is in the
+ * middle of Tcl_ThreadAlert because it won't be able to release
+ * the notifier lock.
+ */
+
+ Tcl_MutexLock(&serialMutex);
+ TerminateThread(serialPtr->writeThread, 0);
+ Tcl_MutexUnlock(&serialMutex);
+
+ /*
+ * Wait for the thread to terminate. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(serialPtr->writeThread, INFINITE);
+ CloseHandle(serialPtr->writeThread);
+ CloseHandle(serialPtr->evWritable);
+ CloseHandle(serialPtr->evStartWriter);
+ serialPtr->writeThread = NULL;
+
+ PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
+ }
serialPtr->validMask &= ~TCL_WRITABLE;
/*
|| ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) {
- if (CloseHandle(serialPtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
- errorCode = errno;
- }
+ if (CloseHandle(serialPtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ errorCode = errno;
+ }
}
serialPtr->watchMask &= serialPtr->validMask;
* Wrap the error file into a channel and give it to the cleanup
* routine.
*/
-
+ if (serialPtr->writeBuf != NULL) {
+ ckfree(serialPtr->writeBuf);
+ serialPtr->writeBuf = NULL;
+ }
ckfree((char*) serialPtr);
if (errorCode == 0) {
}
return errorCode;
}
-\f
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * blockingRead --
+ *
+ * Perform a blocking read into the buffer given. Returns
+ * count of how many bytes were actually read, and an error indication.
+ *
+ * Results:
+ * A count of how many bytes were read is returned and an error
+ * indication is returned.
+ *
+ * Side effects:
+ * Reads input from the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+blockingRead(
+ SerialInfo *infoPtr, /* Serial info structure */
+ LPVOID buf, /* The input buffer pointer */
+ DWORD bufSize, /* The number of bytes to read */
+ LPDWORD lpRead, /* Returns number of bytes read */
+ LPOVERLAPPED osPtr ) /* OVERLAPPED structure */
+{
+ /*
+ * Perform overlapped blocking read.
+ * 1. Reset the overlapped event
+ * 2. Start overlapped read operation
+ * 3. Wait for completion
+ */
+
+ /*
+ * Set Offset to ZERO, otherwise NT4.0 may report an error
+ */
+ osPtr->Offset = osPtr->OffsetHigh = 0;
+ ResetEvent(osPtr->hEvent);
+ if (! ReadFile(infoPtr->handle, buf, bufSize, lpRead, osPtr) ) {
+ if (GetLastError() != ERROR_IO_PENDING) {
+ /* ReadFile failed, but it isn't delayed. Report error */
+ return FALSE;
+ } else {
+ /* Read is pending, wait for completion, timeout ? */
+ if (! GetOverlappedResult(infoPtr->handle, osPtr, lpRead, TRUE) ) {
+ return FALSE;
+ }
+ }
+ } else {
+ /* ReadFile completed immediately. */
+ }
+ return TRUE;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * blockingWrite --
+ *
+ * Perform a blocking write from the buffer given. Returns
+ * count of how many bytes were actually written, and an error indication.
+ *
+ * Results:
+ * A count of how many bytes were written is returned and an error
+ * indication is returned.
+ *
+ * Side effects:
+ * Writes output to the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+blockingWrite(
+ SerialInfo *infoPtr, /* Serial info structure */
+ LPVOID buf, /* The output buffer pointer */
+ DWORD bufSize, /* The number of bytes to write */
+ LPDWORD lpWritten, /* Returns number of bytes written */
+ LPOVERLAPPED osPtr ) /* OVERLAPPED structure */
+{
+ int result;
+ /*
+ * Perform overlapped blocking write.
+ * 1. Reset the overlapped event
+ * 2. Remove these bytes from the output queue counter
+ * 3. Start overlapped write operation
+ * 3. Remove these bytes from the output queue counter
+ * 4. Wait for completion
+ * 5. Adjust the output queue counter
+ */
+ ResetEvent(osPtr->hEvent);
+
+ EnterCriticalSection(&infoPtr->csWrite);
+ infoPtr->writeQueue -= bufSize;
+ /*
+ * Set Offset to ZERO, otherwise NT4.0 may report an error
+ */
+ osPtr->Offset = osPtr->OffsetHigh = 0;
+ result = WriteFile(infoPtr->handle, buf, bufSize, lpWritten, osPtr);
+ LeaveCriticalSection(&infoPtr->csWrite);
+
+ if (result == FALSE ) {
+ int err = GetLastError();
+ switch (err) {
+ case ERROR_IO_PENDING:
+ /* Write is pending, wait for completion */
+ if (! GetOverlappedResult(infoPtr->handle, osPtr, lpWritten, TRUE) ) {
+ return FALSE;
+ }
+ break;
+ case ERROR_COUNTER_TIMEOUT:
+ /* Write timeout handled in SerialOutputProc */
+ break;
+ default:
+ /* WriteFile failed, but it isn't delayed. Report error */
+ return FALSE;
+ }
+ } else {
+ /* WriteFile completed immediately. */
+ }
+
+ EnterCriticalSection(&infoPtr->csWrite);
+ infoPtr->writeQueue += (*lpWritten - bufSize);
+ LeaveCriticalSection(&infoPtr->csWrite);
+
+ return TRUE;
+}
+
/*
*----------------------------------------------------------------------
*
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
DWORD bytesRead = 0;
- DWORD err;
COMSTAT cStat;
*errorCode = 0;
- /*
+ /*
* Check if there is a CommError pending from SerialCheckProc
*/
if( infoPtr->error & SERIAL_READ_ERRORS ){
- goto commError;
+ goto commError;
}
/*
if( ClearCommError( infoPtr->handle, &infoPtr->error, &cStat ) ) {
/*
- * Check for errors here, but not in the evSetup/Check procedures
- */
+ * Check for errors here, but not in the evSetup/Check procedures
+ */
if( infoPtr->error & SERIAL_READ_ERRORS ) {
- goto commError;
+ goto commError;
}
if( infoPtr->flags & SERIAL_ASYNC ) {
- /*
- * NON_BLOCKING mode:
- * Avoid blocking by reading more bytes than available
- * in input buffer
- */
+ /*
+ * NON_BLOCKING mode:
+ * Avoid blocking by reading more bytes than available
+ * in input buffer
+ */
if( cStat.cbInQue > 0 ) {
if( (DWORD) bufSize > cStat.cbInQue ) {
return -1;
}
} else {
- /*
- * BLOCKING mode:
- * Tcl trys to read a full buffer of 4 kBytes here
- */
+ /*
+ * BLOCKING mode:
+ * Tcl trys to read a full buffer of 4 kBytes here
+ */
if( cStat.cbInQue > 0 ) {
if( (DWORD) bufSize > cStat.cbInQue ) {
return bytesRead = 0;
}
- if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
- NULL) == FALSE) {
- err = GetLastError();
- if (err != ERROR_IO_PENDING) {
- goto error;
- }
+ /*
+ * Perform blocking read. Doesn't block in non-blocking mode,
+ * because we checked the number of available bytes.
+ */
+ if (blockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
+ &infoPtr->osRead) == FALSE) {
+ goto error;
}
return bytesRead;
- error:
+error:
TclWinConvertError(GetLastError());
*errorCode = errno;
return -1;
- commError:
+commError:
infoPtr->lastError = infoPtr->error; /* save last error code */
- infoPtr->error = 0; /* reset error code */
- *errorCode = EIO; /* to return read-error only once */
+ infoPtr->error = 0; /* reset error code */
+ *errorCode = EIO; /* to return read-error only once */
return -1;
}
-\f
+
/*
*----------------------------------------------------------------------
*
static int
SerialOutputProc(
ClientData instanceData, /* Serial state. */
- char *buf, /* The data buffer. */
+ CONST char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
- DWORD bytesWritten, err;
+ int bytesWritten, timeout;
*errorCode = 0;
/*
+ * At EXIT Tcl trys to flush all open channels in blocking mode.
+ * We avoid blocking output after ExitProc or CloseHandler(chan)
+ * has been called by checking the corrresponding variables.
+ */
+ if( ! initialized || TclInExit() ) {
+ return toWrite;
+ }
+
+ /*
* Check if there is a CommError pending from SerialCheckProc
*/
if( infoPtr->error & SERIAL_WRITE_ERRORS ){
- infoPtr->lastError = infoPtr->error; /* save last error code */
- infoPtr->error = 0; /* reset error code */
- *errorCode = EIO; /* to return read-error only once */
- return -1;
+ infoPtr->lastError = infoPtr->error; /* save last error code */
+ infoPtr->error = 0; /* reset error code */
+ errno = EIO;
+ goto error;
}
+ timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE;
+ if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) {
+ /*
+ * The writer thread is blocked waiting for a write to complete
+ * and the channel is in non-blocking mode.
+ */
+
+ errno = EWOULDBLOCK;
+ goto error1;
+ }
/*
* Check for a background error on the last write.
- * Allow one write-fileevent after each callback
*/
- if( toWrite ) {
- infoPtr->flags |= SERIAL_WRITE;
+ if (infoPtr->writeError) {
+ TclWinConvertError(infoPtr->writeError);
+ infoPtr->writeError = 0;
+ goto error1;
}
- if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
- &bytesWritten, NULL) == FALSE) {
- err = GetLastError();
- if (err != ERROR_IO_PENDING) {
- TclWinConvertError(GetLastError());
+ /*
+ * Remember the number of bytes in output queue
+ */
+ EnterCriticalSection(&infoPtr->csWrite);
+ infoPtr->writeQueue += toWrite;
+ LeaveCriticalSection(&infoPtr->csWrite);
+
+ if (infoPtr->flags & SERIAL_ASYNC) {
+ /*
+ * The serial is non-blocking, so copy the data into the output
+ * buffer and restart the writer thread.
+ */
+
+ if (toWrite > infoPtr->writeBufLen) {
+ /*
+ * Reallocate the buffer to be large enough to hold the data.
+ */
+
+ if (infoPtr->writeBuf) {
+ ckfree(infoPtr->writeBuf);
+ }
+ infoPtr->writeBufLen = toWrite;
+ infoPtr->writeBuf = ckalloc(toWrite);
+ }
+ memcpy(infoPtr->writeBuf, buf, toWrite);
+ infoPtr->toWrite = toWrite;
+ ResetEvent(infoPtr->evWritable);
+ SetEvent(infoPtr->evStartWriter);
+ bytesWritten = toWrite;
+
+ } else {
+ /*
+ * In the blocking case, just try to write the buffer directly.
+ * This avoids an unnecessary copy.
+ */
+ if (! blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
+ &bytesWritten, &infoPtr->osWrite) ) {
+ goto writeError;
+ }
+ if (bytesWritten != toWrite) {
+ /* Write timeout */
+ infoPtr->lastError |= CE_PTO;
+ errno = EIO;
goto error;
}
}
return bytesWritten;
+writeError:
+ TclWinConvertError(GetLastError());
+
error:
+ /*
+ * Reset the output queue counter on error during blocking output
+ */
+/*
+ EnterCriticalSection(&infoPtr->csWrite);
+ infoPtr->writeQueue = 0;
+ LeaveCriticalSection(&infoPtr->csWrite);
+*/
+ error1:
*errorCode = errno;
return -1;
-
}
-\f
+
/*
*----------------------------------------------------------------------
*
Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
return 1;
}
-\f
+
/*
*----------------------------------------------------------------------
*
SerialBlockTime(infoPtr->blockTime);
} else {
if (oldMask) {
- /*
- * Remove the serial port from the list of watched serial ports.
- */
+ /*
+ * Remove the serial port from the list of watched serial ports.
+ */
for (nextPtrPtr = &(tsdPtr->firstSerialPtr), ptr = *nextPtrPtr;
ptr != NULL;
}
}
}
-\f
+
/*
*----------------------------------------------------------------------
*
*handlePtr = (ClientData) infoPtr->handle;
return TCL_OK;
}
-\f
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialWriterThread --
+ *
+ * This function runs in a separate thread and writes data
+ * onto a serial.
+ *
+ * Results:
+ * Always returns 0.
+ *
+ * Side effects:
+ * Signals the main thread when an output operation is completed.
+ * May cause the main thread to wake up by posting a message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+SerialWriterThread(LPVOID arg)
+{
+
+ SerialInfo *infoPtr = (SerialInfo *)arg;
+ HANDLE *handle = infoPtr->handle;
+ DWORD bytesWritten, toWrite;
+ char *buf;
+ OVERLAPPED myWrite; /* have an own OVERLAPPED in this thread */
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to write.
+ */
+
+ WaitForSingleObject(infoPtr->evStartWriter, INFINITE);
+
+ buf = infoPtr->writeBuf;
+ toWrite = infoPtr->toWrite;
+
+ myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
+
+ /*
+ * Loop until all of the bytes are written or an error occurs.
+ */
+
+ while (toWrite > 0) {
+ /*
+ * Check for pending writeError
+ * Ignore all write operations until the user has been notified
+ */
+ if (infoPtr->writeError) {
+ break;
+ }
+ if (blockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite,
+ &bytesWritten, &myWrite) == FALSE) {
+ infoPtr->writeError = GetLastError();
+ break;
+ }
+ if (bytesWritten != toWrite) {
+ /* Write timeout */
+ infoPtr->writeError = ERROR_WRITE_FAULT;
+ break;
+ }
+ toWrite -= bytesWritten;
+ buf += bytesWritten;
+ }
+
+ CloseHandle(myWrite.hEvent);
+ /*
+ * Signal the main thread by signalling the evWritable event and
+ * then waking up the notifier thread.
+ */
+ SetEvent(infoPtr->evWritable);
+
+ /*
+ * Alert the foreground thread. Note that we need to treat this like
+ * a critical section so the foreground thread does not terminate
+ * this thread while we are holding a mutex in the notifier code.
+ */
+
+ Tcl_MutexLock(&serialMutex);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ Tcl_MutexUnlock(&serialMutex);
+ }
+ return 0; /* NOT REACHED */
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinSerialReopen --
+ *
+ * Reopens the serial port with the OVERLAPPED FLAG set
+ *
+ * Results:
+ * Returns the new handle, or INVALID_HANDLE_VALUE
+ * Normally there shouldn't be any error,
+ * because the same channel has previously been succeesfully opened.
+ *
+ * Side effects:
+ * May close the original handle
+ *
+ *----------------------------------------------------------------------
+ */
+
+HANDLE
+TclWinSerialReopen(handle, name, access)
+ HANDLE handle;
+ CONST TCHAR *name;
+ DWORD access;
+{
+ ThreadSpecificData *tsdPtr;
+
+ tsdPtr = SerialInit();
+
+ /*
+ * Multithreaded I/O needs the overlapped flag set
+ * otherwise ClearCommError blocks under Windows NT/2000 until serial
+ * output is finished
+ */
+ if (CloseHandle(handle) == FALSE) {
+ return INVALID_HANDLE_VALUE;
+ }
+ handle = (*tclWinProcs->createFileProc)(name, access,
+ 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
+ return handle;
+}
/*
*----------------------------------------------------------------------
*
{
SerialInfo *infoPtr;
ThreadSpecificData *tsdPtr;
+ DWORD id;
tsdPtr = SerialInit();
- SetupComm(handle, 4096, 4096);
- PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
- | PURGE_RXCLEAR);
-
- /*
- * default is blocking
- */
-
- SetCommTimeouts(handle, &timeout_sync);
-
infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
(ClientData) infoPtr, permissions);
-
- infoPtr->readable = infoPtr->writable = 0;
+ infoPtr->readable = 0;
+ infoPtr->writable = 1;
+ infoPtr->toWrite = infoPtr->writeQueue = 0;
infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
+ infoPtr->lastEventTime = 0;
infoPtr->lastError = infoPtr->error = 0;
+ infoPtr->threadId = Tcl_GetCurrentThread();
+ infoPtr->sysBufRead = infoPtr->sysBufWrite = 4096;
+
+ SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite);
+ PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
+ | PURGE_RXCLEAR);
+
+ /*
+ * default is blocking
+ */
+ SetCommTimeouts(handle, &no_timeout);
+
+
+ if (permissions & TCL_READABLE) {
+ infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
+ }
+ if (permissions & TCL_WRITABLE) {
+ /*
+ * Initially the channel is writable
+ * and the writeThread is idle.
+ */
+ infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL);
+ infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
+ InitializeCriticalSection(&infoPtr->csWrite);
+ infoPtr->writeThread = CreateThread(NULL, 8000, SerialWriterThread,
+ infoPtr, 0, &id);
+ }
/*
* Files have default translation of AUTO and ^Z eof char, which
return infoPtr->channel;
}
-\f
+
/*
*----------------------------------------------------------------------
*
Tcl_DString *dsPtr; /* Where to store string */
{
if( (error & CE_RXOVER) != 0) {
- Tcl_DStringAppendElement(dsPtr, "RXOVER");
+ Tcl_DStringAppendElement(dsPtr, "RXOVER");
}
if( (error & CE_OVERRUN) != 0) {
- Tcl_DStringAppendElement(dsPtr, "OVERRUN");
+ Tcl_DStringAppendElement(dsPtr, "OVERRUN");
}
if( (error & CE_RXPARITY) != 0) {
- Tcl_DStringAppendElement(dsPtr, "RXPARITY");
+ Tcl_DStringAppendElement(dsPtr, "RXPARITY");
}
if( (error & CE_FRAME) != 0) {
- Tcl_DStringAppendElement(dsPtr, "FRAME");
+ Tcl_DStringAppendElement(dsPtr, "FRAME");
}
if( (error & CE_BREAK) != 0) {
- Tcl_DStringAppendElement(dsPtr, "BREAK");
+ Tcl_DStringAppendElement(dsPtr, "BREAK");
}
if( (error & CE_TXFULL) != 0) {
- Tcl_DStringAppendElement(dsPtr, "TXFULL");
+ Tcl_DStringAppendElement(dsPtr, "TXFULL");
+ }
+ if( (error & CE_PTO) != 0) { /* PTO used to signal WRITE-TIMEOUT */
+ Tcl_DStringAppendElement(dsPtr, "TIMEOUT");
}
if( (error & ~(SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS)) != 0) {
- char buf[TCL_INTEGER_SPACE + 1];
- wsprintfA(buf, "%d", error);
- Tcl_DStringAppendElement(dsPtr, buf);
+ char buf[TCL_INTEGER_SPACE + 1];
+ wsprintfA(buf, "%d", error);
+ Tcl_DStringAppendElement(dsPtr, buf);
}
}
-\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialModemStatusStr --
+ *
+ * Converts a Win32 modem status list of readable flags
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+SerialModemStatusStr(status, dsPtr)
+ DWORD status; /* Win32 modem status */
+ Tcl_DString *dsPtr; /* Where to store string */
+{
+ Tcl_DStringAppendElement(dsPtr, "CTS");
+ Tcl_DStringAppendElement(dsPtr, (status & MS_CTS_ON) ? "1" : "0");
+ Tcl_DStringAppendElement(dsPtr, "DSR");
+ Tcl_DStringAppendElement(dsPtr, (status & MS_DSR_ON) ? "1" : "0");
+ Tcl_DStringAppendElement(dsPtr, "RING");
+ Tcl_DStringAppendElement(dsPtr, (status & MS_RING_ON) ? "1" : "0");
+ Tcl_DStringAppendElement(dsPtr, "DCD");
+ Tcl_DStringAppendElement(dsPtr, (status & MS_RLSD_ON) ? "1" : "0");
+}
+
/*
*----------------------------------------------------------------------
*
*
*----------------------------------------------------------------------
*/
-
static int
SerialSetOptionProc(instanceData, interp, optionName, value)
ClientData instanceData; /* File state. */
Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Which option to set? */
- char *value; /* New value for option. */
+ CONST char *optionName; /* Which option to set? */
+ CONST char *value; /* New value for option. */
{
SerialInfo *infoPtr;
DCB dcb;
- int len;
- BOOL result;
+ BOOL result, flag;
+ size_t len, vlen;
Tcl_DString ds;
- TCHAR *native;
+ CONST TCHAR *native;
+ int argc;
+ char **argv;
infoPtr = (SerialInfo *) instanceData;
+ /*
+ * Parse options
+ */
len = strlen(optionName);
- if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
- if (GetCommState(infoPtr->handle, &dcb)) {
- native = Tcl_WinUtfToTChar(value, -1, &ds);
- result = (*tclWinProcs->buildCommDCBProc)(native, &dcb);
- Tcl_DStringFree(&ds);
-
- if ((result == FALSE) ||
- (SetCommState(infoPtr->handle, &dcb) == FALSE)) {
- /*
- * one should separate the 2 errors...
- */
-
- if (interp) {
- Tcl_AppendResult(interp,
- "bad value for -mode: should be ",
- "baud,parity,data,stop", NULL);
- }
- return TCL_ERROR;
- } else {
- return TCL_OK;
- }
- } else {
- if (interp) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
- }
- return TCL_ERROR;
- }
- } else if ((len > 1) &&
- (strncmp(optionName, "-pollinterval", len) == 0)) {
- if ( Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) {
- return TCL_ERROR;
- }
- } else {
- return Tcl_BadChannelOption(interp, optionName,
- "mode pollinterval");
+ vlen = strlen(value);
+
+ /*
+ * Option -mode baud,parity,databits,stopbits
+ */
+ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
+
+ if (! GetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't get comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ native = Tcl_WinUtfToTChar(value, -1, &ds);
+ result = (*tclWinProcs->buildCommDCBProc)(native, &dcb);
+ Tcl_DStringFree(&ds);
+
+ if (result == FALSE) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad value for -mode: should be baud,parity,data,stop",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ /* Default settings for serial communications */
+ dcb.fBinary = TRUE;
+ dcb.fErrorChar = FALSE;
+ dcb.fNull = FALSE;
+ dcb.fAbortOnError = FALSE;
+
+ if (! SetCommState(infoPtr->handle, &dcb) ) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
}
- return TCL_OK;
+
+ /*
+ * Option -handshake none|xonxoff|rtscts|dtrdsr
+ */
+ if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
+
+ if (! GetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't get comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ /*
+ * Reset all handshake options
+ * DTR and RTS are ON by default
+ */
+ dcb.fOutX = dcb.fInX = FALSE;
+ dcb.fOutxCtsFlow = dcb.fOutxDsrFlow = dcb.fDsrSensitivity = FALSE;
+ dcb.fDtrControl = DTR_CONTROL_ENABLE;
+ dcb.fRtsControl = RTS_CONTROL_ENABLE;
+ dcb.fTXContinueOnXoff = FALSE;
+
+ /*
+ * Adjust the handshake limits.
+ * Yes, the XonXoff limits seem to influence even hardware handshake
+ */
+ dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
+ dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
+
+ if (strnicmp(value, "NONE", vlen) == 0) {
+ /* leave all handshake options disabled */
+ } else if (strnicmp(value, "XONXOFF", vlen) == 0) {
+ dcb.fOutX = dcb.fInX = TRUE;
+ } else if (strnicmp(value, "RTSCTS", vlen) == 0) {
+ dcb.fOutxCtsFlow = TRUE;
+ dcb.fRtsControl = RTS_CONTROL_HANDSHAKE;
+ } else if (strnicmp(value, "DTRDSR", vlen) == 0) {
+ dcb.fOutxDsrFlow = TRUE;
+ dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp, "bad value for -handshake: ",
+ "must be one of xonxoff, rtscts, dtrdsr or none",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ if (! SetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Option -xchar {\x11 \x13}
+ */
+ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
+
+ if (! GetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't get comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (argc == 2) {
+ dcb.XonChar = argv[0][0];
+ dcb.XoffChar = argv[1][0];
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad value for -xchar: should be a list of two elements",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (! SetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
+ */
+ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
+
+ if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if ((argc % 2) == 1) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad value for -ttycontrol: should be a list of signal,value pairs",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ while (argc > 1) {
+ if (Tcl_GetBoolean(interp, argv[1], &flag) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (strnicmp(argv[0], "DTR", strlen(argv[0])) == 0) {
+ if (! EscapeCommFunction(infoPtr->handle, flag ? SETDTR : CLRDTR)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set DTR signal", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else if (strnicmp(argv[0], "RTS", strlen(argv[0])) == 0) {
+ if (! EscapeCommFunction(infoPtr->handle, flag ? SETRTS : CLRRTS)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set RTS signal", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else if (strnicmp(argv[0], "BREAK", strlen(argv[0])) == 0) {
+ if (! EscapeCommFunction(infoPtr->handle, flag ? SETBREAK : CLRBREAK)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set BREAK signal", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad signal for -ttycontrol: must be DTR, RTS or BREAK",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ argc -= 2, argv += 2;
+ } /* while (argc > 1) */
+
+ return TCL_OK;
+ }
+
+ /*
+ * Option -sysbuffer {read_size write_size}
+ * Option -sysbuffer read_size
+ */
+ if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) {
+
+ /*
+ * -sysbuffer 4096 or -sysbuffer {64536 4096}
+ */
+ size_t inSize = -1, outSize = -1;
+
+ if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (argc == 1) {
+ inSize = atoi(argv[0]);
+ outSize = infoPtr->sysBufWrite;
+ } else if (argc == 2) {
+ inSize = atoi(argv[0]);
+ outSize = atoi(argv[1]);
+ }
+ if ( (inSize <= 0) || (outSize <= 0) ) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "bad value for -sysbuffer: should be a list of one or two integers > 0",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (! SetupComm(infoPtr->handle, inSize, outSize)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't setup comm buffers", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ infoPtr->sysBufRead = inSize;
+ infoPtr->sysBufWrite = outSize;
+
+ /*
+ * Adjust the handshake limits.
+ * Yes, the XonXoff limits seem to influence even hardware handshake
+ */
+ if (! GetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't get comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
+ dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
+ if (! SetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Option -pollinterval msec
+ */
+ if ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0)) {
+
+ if ( Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Option -timeout msec
+ */
+ if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
+ int msec;
+ COMMTIMEOUTS tout = {0,0,0,0,0};
+
+ if ( Tcl_GetInt(interp, value, &msec) != TCL_OK ) {
+ return TCL_ERROR;
+ }
+ tout.ReadTotalTimeoutConstant = msec;
+ if (! SetCommTimeouts(infoPtr->handle, &tout)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't set comm timeouts", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+ }
+
+ return Tcl_BadChannelOption(interp, optionName,
+ "mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
}
-\f
+
/*
*----------------------------------------------------------------------
*
SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
ClientData instanceData; /* File state. */
Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Option to get. */
+ CONST char *optionName; /* Option to get. */
Tcl_DString *dsPtr; /* Where to store value(s). */
{
SerialInfo *infoPtr;
DCB dcb;
- int len;
+ size_t len;
int valid = 0; /* flag if valid option parsed */
-
+
infoPtr = (SerialInfo *) instanceData;
-
+
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
-
+
/*
- * get option -mode
- */
-
+ * get option -mode
+ */
+
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
}
if ((len == 0) ||
- ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) {
- valid = 1;
- if (GetCommState(infoPtr->handle, &dcb) == 0) {
- /*
- * shouldn't we flag an error instead ?
- */
-
- Tcl_DStringAppendElement(dsPtr, "");
-
- } else {
- char parity;
- char *stop;
- char buf[2 * TCL_INTEGER_SPACE + 16];
-
- parity = 'n';
- if (dcb.Parity < 4) {
- parity = "noems"[dcb.Parity];
+ ((len > 2) && (strncmp(optionName, "-mode", len) == 0))) {
+
+ char parity;
+ char *stop;
+ char buf[2 * TCL_INTEGER_SPACE + 16];
+
+ if (! GetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't get comm state", (char *) NULL);
}
-
- stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
- (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
-
- wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity,
- dcb.ByteSize, stop);
- Tcl_DStringAppendElement(dsPtr, buf);
+ return TCL_ERROR;
+ }
+
+ valid = 1;
+ parity = 'n';
+ if (dcb.Parity <= 4) {
+ parity = "noems"[dcb.Parity];
}
+ stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
+ (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
+
+ wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity,
+ dcb.ByteSize, stop);
+ Tcl_DStringAppendElement(dsPtr, buf);
}
-
+
/*
- * get option -pollinterval
- */
+ * get option -pollinterval
+ */
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-pollinterval");
if ((len == 0) ||
((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0))) {
char buf[TCL_INTEGER_SPACE + 1];
-
+
valid = 1;
wsprintfA(buf, "%d", infoPtr->blockTime);
Tcl_DStringAppendElement(dsPtr, buf);
}
+
+ /*
+ * get option -sysbuffer
+ */
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-sysbuffer");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ if ((len == 0) ||
+ ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0))) {
+
+ char buf[TCL_INTEGER_SPACE + 1];
+ valid = 1;
+ wsprintfA(buf, "%d", infoPtr->sysBufRead);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ wsprintfA(buf, "%d", infoPtr->sysBufWrite);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ }
+
/*
- * get option -lasterror
- * option is readonly and returned by [fconfigure chan -lasterror]
- * but not returned by unnamed [fconfigure chan]
- */
+ * get option -xchar
+ */
+
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-xchar");
+ Tcl_DStringStartSublist(dsPtr);
+ }
+ if ((len == 0) ||
+ ((len > 1) && (strncmp(optionName, "-xchar", len) == 0))) {
+
+ char buf[4];
+ valid = 1;
+
+ if (! GetCommState(infoPtr->handle, &dcb)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't get comm state", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ sprintf(buf, "%c", dcb.XonChar);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ sprintf(buf, "%c", dcb.XoffChar);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+ if (len == 0) {
+ Tcl_DStringEndSublist(dsPtr);
+ }
+ /*
+ * get option -lasterror
+ * option is readonly and returned by [fconfigure chan -lasterror]
+ * but not returned by unnamed [fconfigure chan]
+ */
+
if ( (len > 1) && (strncmp(optionName, "-lasterror", len) == 0) ) {
- valid = 1;
- SerialErrorStr(infoPtr->lastError, dsPtr);
+ valid = 1;
+ SerialErrorStr(infoPtr->lastError, dsPtr);
}
+
+ /*
+ * get option -queue
+ * option is readonly and returned by [fconfigure chan -queue]
+ */
+
+ if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
+ char buf[TCL_INTEGER_SPACE + 1];
+ COMSTAT cStat;
+ int error;
+ int inBuffered, outBuffered, count;
+
+ valid = 1;
+
+ /*
+ * Query the pending data in Tcl's internal queues
+ */
+ inBuffered = Tcl_InputBuffered(infoPtr->channel);
+ outBuffered = Tcl_OutputBuffered(infoPtr->channel);
+ /*
+ * Query the number of bytes in our output queue:
+ * 1. The bytes pending in the output thread
+ * 2. The bytes in the system drivers buffer
+ * The writer thread should not interfere this action.
+ */
+ EnterCriticalSection(&infoPtr->csWrite);
+ ClearCommError( infoPtr->handle, &error, &cStat );
+ count = (int)cStat.cbOutQue + infoPtr->writeQueue;
+ LeaveCriticalSection(&infoPtr->csWrite);
+
+ wsprintfA(buf, "%d", inBuffered + cStat.cbInQue);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ wsprintfA(buf, "%d", outBuffered + count);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+
+ /*
+ * get option -ttystatus
+ * option is readonly and returned by [fconfigure chan -ttystatus]
+ * but not returned by unnamed [fconfigure chan]
+ */
+ if ( (len > 4) && (strncmp(optionName, "-ttystatus", len) == 0) ) {
+
+ DWORD status;
+
+ if (! GetCommModemStatus(infoPtr->handle, &status)) {
+ if (interp) {
+ Tcl_AppendResult(interp,
+ "can't get tty status", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ valid = 1;
+ SerialModemStatusStr(status, dsPtr);
+ }
+
if (valid) {
return TCL_OK;
} else {
return Tcl_BadChannelOption(interp, optionName,
- "mode pollinterval lasterror");
+ "mode pollinterval lasterror queue sysbuffer ttystatus xchar");
}
}
-
*/
static SocketInfo * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp,
- int port, char *host, int server, char *myaddr,
- int myport, int async));
+ int port, CONST char *host, int server,
+ CONST char *myaddr, int myport, int async));
static int CreateSocketAddress _ANSI_ARGS_(
(struct sockaddr_in *sockaddrPtr,
- char *host, int port));
+ CONST char *host, int port));
static void InitSockets _ANSI_ARGS_((void));
static SocketInfo * NewSocketInfo _ANSI_ARGS_((SOCKET socket));
static void SocketCheckProc _ANSI_ARGS_((ClientData clientData,
static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp));
static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
+ Tcl_Interp *interp, CONST char *optionName,
Tcl_DString *optionValue));
static int TcpInputProc _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCode));
+ CONST char *buf, int toWrite, int *errorCode));
static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData,
int mask));
static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData,
TcpWatchProc, /* Set up notifier to watch this channel. */
TcpGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
- TcpBlockProc, /* Set blocking/non-blocking mode. */
+ TcpBlockProc, /* Set socket into (non-)blocking mode. */
NULL, /* flush proc. */
NULL, /* handler proc. */
};
if ((*winSock.select)(0, &readFds, NULL, NULL, &timeout) != 0) {
mask |= TCL_READABLE;
} else {
+ infoPtr->readyEvents &= ~(FD_READ);
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) SELECT, (LPARAM) infoPtr);
- infoPtr->readyEvents &= ~(FD_READ);
}
}
if (events & (FD_WRITE | FD_CONNECT)) {
CreateSocket(interp, port, host, server, myaddr, myport, async)
Tcl_Interp *interp; /* For error reporting; can be NULL. */
int port; /* Port number to open. */
- char *host; /* Name of host on which to open port. */
+ CONST char *host; /* Name of host on which to open port. */
int server; /* 1 if socket should be a server socket,
* else 0 for a client socket. */
- char *myaddr; /* Optional client-side address */
+ CONST char *myaddr; /* Optional client-side address */
int myport; /* Optional client-side port */
int async; /* If nonzero, connect client socket
* asynchronously. */
static int
CreateSocketAddress(sockaddrPtr, host, port)
struct sockaddr_in *sockaddrPtr; /* Socket address */
- char *host; /* Host. NULL implies INADDR_ANY */
+ CONST char *host; /* Host. NULL implies INADDR_ANY */
int port; /* Port number */
{
struct hostent *hostent; /* Host database entry */
Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
Tcl_Interp *interp; /* For error reporting; can be NULL. */
int port; /* Port number to open. */
- char *host; /* Host on which to open port. */
- char *myaddr; /* Client-side address */
+ CONST char *host; /* Host on which to open port. */
+ CONST char *myaddr; /* Client-side address */
int myport; /* Client-side port */
int async; /* If nonzero, should connect
* client socket asynchronously. */
Tcl_Interp *interp; /* For error reporting - may be
* NULL. */
int port; /* Port number to open. */
- char *host; /* Name of local host. */
+ CONST char *host; /* Name of local host. */
Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections
* from new clients. */
ClientData acceptProcData; /* Data for the callback. */
static int
TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
ClientData instanceData; /* The socket state. */
- char *buf; /* Where to get data. */
+ CONST char *buf; /* Where to get data. */
int toWrite; /* Maximum number of bytes to write. */
int *errorCodePtr; /* Where to store error codes. */
{
TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
ClientData instanceData; /* Socket state. */
Tcl_Interp *interp; /* For error reporting - can be NULL */
- char *optionName; /* Name of the option to
+ CONST char *optionName; /* Name of the option to
* retrieve the value for, or
* NULL to get all options and
* their values. */
}
Tcl_DStringAppendElement(dsPtr,
(*winSock.inet_ntoa)(peername.sin_addr));
- hostEntPtr = (*winSock.gethostbyaddr)(
- (char *) &(peername.sin_addr), sizeof(peername.sin_addr),
- AF_INET);
+
+ if (peername.sin_addr.s_addr == 0) {
+ hostEntPtr = (struct hostent *) NULL;
+ } else {
+ hostEntPtr = (*winSock.gethostbyaddr)(
+ (char *) &(peername.sin_addr), sizeof(peername.sin_addr),
+ AF_INET);
+ }
if (hostEntPtr != (struct hostent *) NULL) {
Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
} else {
}
Tcl_DStringAppendElement(dsPtr,
(*winSock.inet_ntoa)(sockname.sin_addr));
- hostEntPtr = (*winSock.gethostbyaddr)(
- (char *) &(sockname.sin_addr), sizeof(peername.sin_addr),
- AF_INET);
+ if (sockname.sin_addr.s_addr == 0) {
+ hostEntPtr = (struct hostent *) NULL;
+ } else {
+ hostEntPtr = (*winSock.gethostbyaddr)(
+ (char *) &(sockname.sin_addr), sizeof(peername.sin_addr),
+ AF_INET);
+ }
if (hostEntPtr != (struct hostent *) NULL) {
Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
} else {
SocketInfo *infoPtr = (SocketInfo *) instanceData;
/*
- * Update the watch events mask.
+ * Update the watch events mask. Only if the socket is not a
+ * server socket. Fix for SF Tcl Bug #557878.
*/
-
- infoPtr->watchEvents = 0;
- if (mask & TCL_READABLE) {
- infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
- }
- if (mask & TCL_WRITABLE) {
- infoPtr->watchEvents |= (FD_WRITE|FD_CONNECT);
- }
- /*
- * If there are any conditions already set, then tell the notifier to poll
- * rather than block.
- */
+ if (!infoPtr->acceptProc) {
+ infoPtr->watchEvents = 0;
+ if (mask & TCL_READABLE) {
+ infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
+ }
+ if (mask & TCL_WRITABLE) {
+ infoPtr->watchEvents |= (FD_WRITE|FD_CONNECT);
+ }
+
+ /*
+ * If there are any conditions already set, then tell the notifier to poll
+ * rather than block.
+ */
- if (infoPtr->readyEvents & infoPtr->watchEvents) {
- Tcl_Time blockTime = { 0, 0 };
- Tcl_SetMaxBlockTime(&blockTime);
- }
+ if (infoPtr->readyEvents & infoPtr->watchEvents) {
+ Tcl_Time blockTime = { 0, 0 };
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+ }
}
\f
/*
*/
#ifdef _WIN64
- SetWindowLongPtr(tsdPtr->hwnd, GWLP_USERDATA, (LONG) tsdPtr);
+ SetWindowLongPtr(tsdPtr->hwnd, GWLP_USERDATA, (LONG_PTR) tsdPtr);
#else
SetWindowLong(tsdPtr->hwnd, GWL_USERDATA, (LONG) tsdPtr);
#endif
*----------------------------------------------------------------------
*/
-char *
+CONST char *
Tcl_GetHostName()
{
DWORD length;
}
-
* RCS: @(#) $Id$
*/
+#define USE_COMPAT_CONST
#include "tclWinInt.h"
/*
static int TestvolumetypeCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+static int TestwinclockCmd _ANSI_ARGS_(( ClientData dummy,
+ Tcl_Interp* interp,
+ int objc,
+ Tcl_Obj *CONST objv[] ));
\f
/*
*----------------------------------------------------------------------
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
\f
return TCL_OK;
#undef VOL_BUF_SIZE
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestclockCmd --
+ *
+ * Command that returns the seconds and microseconds portions of
+ * the system clock and of the Tcl clock so that they can be
+ * compared to validate that the Tcl clock is staying in sync.
+ *
+ * Usage:
+ * testclock
+ *
+ * Parameters:
+ * None.
+ *
+ * Results:
+ * Returns a standard Tcl result comprising a four-element list:
+ * the seconds and microseconds portions of the system clock,
+ * and the seconds and microseconds portions of the Tcl clock.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+TestwinclockCmd( ClientData dummy,
+ /* Unused */
+ Tcl_Interp* interp,
+ /* Tcl interpreter */
+ int objc,
+ /* Argument count */
+ Tcl_Obj *CONST objv[] )
+ /* Argument vector */
+{
+ CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
+ /* The Posix epoch, expressed as a
+ * Windows FILETIME */
+ Tcl_Time tclTime; /* Tcl clock */
+ FILETIME sysTime; /* System clock */
+ Tcl_Obj* result; /* Result of the command */
+ LARGE_INTEGER t1, t2;
+ if ( objc != 1 ) {
+ Tcl_WrongNumArgs( interp, 1, objv, "" );
+ return TCL_ERROR;
+ }
+
+ Tcl_GetTime( &tclTime );
+ GetSystemTimeAsFileTime( &sysTime );
+ t1.LowPart = posixEpoch.dwLowDateTime;
+ t1.HighPart = posixEpoch.dwHighDateTime;
+ t2.LowPart = sysTime.dwLowDateTime;
+ t2.HighPart = sysTime.dwHighDateTime;
+ t2.QuadPart -= t1.QuadPart;
+
+ result = Tcl_NewObj();
+ Tcl_ListObjAppendElement
+ ( interp, result, Tcl_NewIntObj( (int) (t2.QuadPart / 10000000 ) ) );
+ Tcl_ListObjAppendElement
+ ( interp, result,
+ Tcl_NewIntObj( (int) ( (t2.QuadPart / 10 ) % 1000000 ) ) );
+ Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.sec ) );
+ Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.usec ) );
+
+ Tcl_SetObjResult( interp, result );
+
+ return TCL_OK;
+}
static Tcl_Mutex allocLockPtr = (Tcl_Mutex) &allocLock;
/*
+ * The joinLock serializes Create- and ExitThread. This is necessary to
+ * prevent a race where a new joinable thread exits before the creating
+ * thread had the time to create the necessary data structures in the
+ * emulation layer.
+ */
+
+static CRITICAL_SECTION joinLock;
+
+/*
* Condition variables are implemented with a combination of a
* per-thread Windows Event and a per-condition waiting queue.
* The idea is that each thread has its own Event that it waits
struct ThreadSpecificData *lastPtr;
} WinCondition;
-static void FinalizeConditionEvent(ClientData data);
-
\f
/*
*----------------------------------------------------------------------
{
HANDLE tHandle;
-#ifdef __CYGWIN__
+ EnterCriticalSection(&joinLock);
+
+#if defined(__MSVCRT__) || defined(__BORLANDC__)
+ tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, proc,
+ clientData, 0, (unsigned *)idPtr);
+#else
tHandle = CreateThread(NULL, (DWORD) stackSize,
- (LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData,
- (DWORD) 0, (LPDWORD)idPtr);
+ (LPTHREAD_START_ROUTINE) proc, (LPVOID) clientData,
+ (DWORD) 0, (LPDWORD)idPtr);
+#endif
+
if (tHandle == NULL) {
-#else
- tHandle = (HANDLE) _beginthreadex(NULL, (unsigned)stackSize, proc,
- clientData, (unsigned) 0, (unsigned *)idPtr);
- if (tHandle == 0) {
-#endif /* __CYGWIN__ */
+ LeaveCriticalSection(&joinLock);
return TCL_ERROR;
} else {
+ if (flags & TCL_THREAD_JOINABLE) {
+ TclRememberJoinableThread (*idPtr);
+ }
+
+ /*
+ * The only purpose of this is to decrement the reference count so the
+ * OS resources will be reaquired when the thread closes.
+ */
+
CloseHandle(tHandle);
+ LeaveCriticalSection(&joinLock);
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
+ * Tcl_JoinThread --
+ *
+ * This procedure waits upon the exit of the specified thread.
+ *
+ * Results:
+ * TCL_OK if the wait was successful, TCL_ERROR else.
+ *
+ * Side effects:
+ * The result area is set to the exit code of the thread we
+ * waited upon.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_JoinThread(id, result)
+ Tcl_ThreadId id; /* Id of the thread to wait upon */
+ int* result; /* Reference to the storage the result
+ * of the thread we wait upon will be
+ * written into. */
+{
+ return TclJoinThread (id, result);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
* TclpThreadExit --
*
* This procedure terminates the current thread.
TclpThreadExit(status)
int status;
{
-#ifdef __CYGWIN__
- ExitThread((DWORD) status);
-#else
+ EnterCriticalSection(&joinLock);
+ TclSignalExitThread (Tcl_GetCurrentThread (), status);
+ LeaveCriticalSection(&joinLock);
+
+#if defined(__MSVCRT__) || defined(__BORLANDC__)
_endthreadex((unsigned) status);
-#endif /* __CYGWIN__ */
+#else
+ ExitThread((DWORD) status);
+#endif
}
\f
* more threads that create interpreters in parallel.
*/
init = 1;
+ InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&masterLock);
}
* more threads that create interpreters in parallel.
*/
init = 1;
+ InitializeCriticalSection(&joinLock);
InitializeCriticalSection(&initLock);
InitializeCriticalSection(&masterLock);
}
Tcl_GetAllocMutex()
{
#ifdef TCL_THREADS
- InitializeCriticalSection(&allocLock);
+ static int once = 0;
+
+ if (!once) {
+ InitializeCriticalSection(&allocLock);
+ once = 1;
+ }
return &allocLockPtr;
#else
return NULL;
\f
#ifdef TCL_THREADS
+
+/* locally used prototype */
+static void FinalizeConditionEvent(ClientData data);
+
/*
*----------------------------------------------------------------------
*
{
CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
if (csPtr != NULL) {
+ DeleteCriticalSection(csPtr);
ckfree((char *)csPtr);
*mutexPtr = NULL;
}
VOID *result;
DWORD *indexPtr;
+#ifdef USE_THREAD_ALLOC
+ TclWinFreeAllocCache();
+#endif
if (*keyPtr != NULL) {
indexPtr = *(DWORD **)keyPtr;
result = (VOID *)TlsGetValue(*indexPtr);
* Tcl_ConditionWait --
*
* This procedure is invoked to wait on a condition variable.
- * The mutex is automically released as part of the wait, and
+ * The mutex is atomically released as part of the wait, and
* automatically grabbed when the condition is signaled.
*
* The mutex must be held when this procedure is called.
}
/*
- * Self initialize the two parts of the contition.
+ * Self initialize the two parts of the condition.
* The per-condition and per-thread parts need to be
* handled independently.
*/
if (doExit) {
/*
* Create a per-thread exit handler to clean up the condEvent.
- * We must be careful do do this outside the Master Lock
+ * We must be careful to do this outside the Master Lock
* because Tcl_CreateThreadExitHandler uses its own
* ThreadSpecificData, and initializing that may drop
* back into the Master Lock.
*/
if (winCondPtr != NULL) {
+ DeleteCriticalSection(&winCondPtr->condLock);
ckfree((char *)winCondPtr);
*condPtr = NULL;
}
}
+
+/*
+ * Additions by AOL for specialized thread memory allocator.
+ */
+#ifdef USE_THREAD_ALLOC
+static DWORD key;
+
+Tcl_Mutex *
+TclpNewAllocMutex(void)
+{
+ struct lock {
+ Tcl_Mutex tlock;
+ CRITICAL_SECTION wlock;
+ } *lockPtr;
+
+ lockPtr = malloc(sizeof(struct lock));
+ if (lockPtr == NULL) {
+ panic("could not allocate lock");
+ }
+ lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock;
+ InitializeCriticalSection(&lockPtr->wlock);
+ return &lockPtr->tlock;
+}
+
+void *
+TclpGetAllocCache(void)
+{
+ static int once = 0;
+
+ if (!once) {
+ /*
+ * We need to make sure that TclWinFreeAllocCache is called
+ * on each thread that calls this, but only on threads that
+ * call this.
+ */
+ key = TlsAlloc();
+ once = 1;
+ if (key == TLS_OUT_OF_INDEXES) {
+ panic("could not allocate thread local storage");
+ }
+ }
+ return TlsGetValue(key);
+}
+
+void
+TclpSetAllocCache(void *ptr)
+{
+ TlsSetValue(key, ptr);
+}
+
+void
+TclWinFreeAllocCache(void)
+{
+ void *ptr;
+
+ ptr = TlsGetValue(key);
+ if (ptr != NULL) {
+ TlsSetValue(key, NULL);
+ TclFreeAllocCache(ptr);
+ }
+}
+
+#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */
#endif /* TCL_THREADS */
#endif /* _TCLWINTHRD */
-
-
static Tcl_ThreadDataKey dataKey;
/*
+ * Calibration interval for the high-resolution timer, in msec
+ */
+
+static CONST unsigned long clockCalibrateWakeupInterval = 10000;
+ /* FIXME: 10 s -- should be about 10 min! */
+
+/*
+ * Data for managing high-resolution timers.
+ */
+
+typedef struct TimeInfo {
+
+ CRITICAL_SECTION cs; /* Mutex guarding this structure */
+
+ int initialized; /* Flag == 1 if this structure is
+ * initialized. */
+
+ int perfCounterAvailable; /* Flag == 1 if the hardware has a
+ * performance counter */
+
+ HANDLE calibrationThread; /* Handle to the thread that keeps the
+ * virtual clock calibrated. */
+
+ HANDLE readyEvent; /* System event used to
+ * trigger the requesting thread
+ * when the clock calibration procedure
+ * is initialized for the first time */
+ HANDLE exitEvent; /* Event to signal out of an exit handler
+ * to tell the calibration loop to
+ * terminate */
+
+
+ /*
+ * The following values are used for calculating virtual time.
+ * Virtual time is always equal to:
+ * lastFileTime + (current perf counter - lastCounter)
+ * * 10000000 / curCounterFreq
+ * and lastFileTime and lastCounter are updated any time that
+ * virtual time is returned to a caller.
+ */
+
+ ULARGE_INTEGER lastFileTime;
+ LARGE_INTEGER lastCounter;
+ LARGE_INTEGER curCounterFreq;
+
+ /*
+ * The next two values are used only in the calibration thread, to track
+ * the frequency of the performance counter.
+ */
+
+ LONGLONG lastPerfCounter; /* Performance counter the last time
+ * that UpdateClockEachSecond was called */
+ LONGLONG lastSysTime; /* System clock at the last time
+ * that UpdateClockEachSecond was called */
+ LONGLONG estPerfCounterFreq;
+ /* Current estimate of the counter frequency
+ * using the system clock as the standard */
+
+} TimeInfo;
+
+static TimeInfo timeInfo = {
+ { NULL },
+ 0,
+ 0,
+ (HANDLE) NULL,
+ (HANDLE) NULL,
+ (HANDLE) NULL,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0,
+ 0
+};
+
+CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
+
+/*
* Declarations for functions defined later in this file.
*/
static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp));
+static void StopCalibration _ANSI_ARGS_(( ClientData ));
+static DWORD WINAPI CalibrationThread _ANSI_ARGS_(( LPVOID arg ));
+static void UpdateTimeEachSecond _ANSI_ARGS_(( void ));
\f
/*
*----------------------------------------------------------------------
unsigned long
TclpGetSeconds()
{
- return (unsigned long) time((time_t *) NULL);
+ Tcl_Time t;
+ Tcl_GetTime( &t );
+ return t.sec;
}
\f
/*
unsigned long
TclpGetClicks()
{
- return GetTickCount();
+ /*
+ * Use the Tcl_GetTime abstraction to get the time in microseconds,
+ * as nearly as we can, and return it.
+ */
+
+ Tcl_Time now; /* Current Tcl time */
+ unsigned long retval; /* Value to return */
+
+ Tcl_GetTime( &now );
+ retval = ( now.sec * 1000000 ) + now.usec;
+ return retval;
+
}
\f
/*
/*
*----------------------------------------------------------------------
*
- * TclpGetTime --
+ * Tcl_GetTime --
*
* Gets the current system time in seconds and microseconds
* since the beginning of the epoch: 00:00 UCT, January 1, 1970.
* Returns the current time in timePtr.
*
* Side effects:
- * None.
+ * On the first call, initializes a set of static variables to
+ * keep track of the base value of the performance counter, the
+ * corresponding wall clock (obtained through ftime) and the
+ * frequency of the performance counter. Also spins a thread
+ * whose function is to wake up periodically and monitor these
+ * values, adjusting them as necessary to correct for drift
+ * in the performance counter's oscillator.
*
*----------------------------------------------------------------------
*/
void
-TclpGetTime(timePtr)
+Tcl_GetTime(timePtr)
Tcl_Time *timePtr; /* Location to store time information. */
{
+
struct timeb t;
- ftime(&t);
- timePtr->sec = t.time;
- timePtr->usec = t.millitm * 1000;
+ /* Initialize static storage on the first trip through. */
+
+ /*
+ * Note: Outer check for 'initialized' is a performance win
+ * since it avoids an extra mutex lock in the common case.
+ */
+
+ if ( !timeInfo.initialized ) {
+ TclpInitLock();
+ if ( !timeInfo.initialized ) {
+ timeInfo.perfCounterAvailable
+ = QueryPerformanceFrequency( &timeInfo.curCounterFreq );
+
+ /*
+ * Some hardware abstraction layers use the CPU clock
+ * in place of the real-time clock as a performance counter
+ * reference. This results in:
+ * - inconsistent results among the processors on
+ * multi-processor systems.
+ * - unpredictable changes in performance counter frequency
+ * on "gearshift" processors such as Transmeta and
+ * SpeedStep.
+ *
+ * There seems to be no way to test whether the performance
+ * counter is reliable, but a useful heuristic is that
+ * if its frequency is 1.193182 MHz or 3.579545 MHz, it's
+ * derived from a colorburst crystal and is therefore
+ * the RTC rather than the TSC.
+ *
+ * A sloppier but serviceable heuristic is that the RTC crystal
+ * is normally less than 15 MHz while the TSC crystal is
+ * virtually assured to be greater than 100 MHz. Since Win98SE
+ * appears to fiddle with the definition of the perf counter
+ * frequency (perhaps in an attempt to calibrate the clock?)
+ * we use the latter rule rather than an exact match.
+ */
+
+ if ( timeInfo.perfCounterAvailable
+ /* The following lines would do an exact match on
+ * crystal frequency:
+ * && timeInfo.curCounterFreq.QuadPart != (LONGLONG) 1193182
+ * && timeInfo.curCounterFreq.QuadPart != (LONGLONG) 3579545
+ */
+ && timeInfo.curCounterFreq.QuadPart > (LONGLONG) 15000000 ) {
+ timeInfo.perfCounterAvailable = FALSE;
+ }
+
+ /*
+ * If the performance counter is available, start a thread to
+ * calibrate it.
+ */
+
+ if ( timeInfo.perfCounterAvailable ) {
+ DWORD id;
+ InitializeCriticalSection( &timeInfo.cs );
+ timeInfo.readyEvent = CreateEvent( NULL, FALSE, FALSE, NULL );
+ timeInfo.exitEvent = CreateEvent( NULL, FALSE, FALSE, NULL );
+ timeInfo.calibrationThread = CreateThread( NULL,
+ 8192,
+ CalibrationThread,
+ (LPVOID) NULL,
+ 0,
+ &id );
+ SetThreadPriority( timeInfo.calibrationThread,
+ THREAD_PRIORITY_HIGHEST );
+
+ /*
+ * Wait for the thread just launched to start running,
+ * and create an exit handler that kills it so that it
+ * doesn't outlive unloading tclXX.dll
+ */
+
+ WaitForSingleObject( timeInfo.readyEvent, INFINITE );
+ CloseHandle( timeInfo.readyEvent );
+ Tcl_CreateExitHandler( StopCalibration, (ClientData) NULL );
+ }
+ timeInfo.initialized = TRUE;
+ }
+ TclpInitUnlock();
+ }
+
+ if ( timeInfo.perfCounterAvailable ) {
+
+ /*
+ * Query the performance counter and use it to calculate the
+ * current time.
+ */
+
+ LARGE_INTEGER curCounter;
+ /* Current performance counter */
+
+ LONGLONG curFileTime;
+ /* Current estimated time, expressed
+ * as 100-ns ticks since the Windows epoch */
+
+ static LARGE_INTEGER posixEpoch;
+ /* Posix epoch expressed as 100-ns ticks
+ * since the windows epoch */
+
+ LONGLONG usecSincePosixEpoch;
+ /* Current microseconds since Posix epoch */
+
+ posixEpoch.LowPart = 0xD53E8000;
+ posixEpoch.HighPart = 0x019DB1DE;
+
+ EnterCriticalSection( &timeInfo.cs );
+
+ QueryPerformanceCounter( &curCounter );
+ curFileTime = timeInfo.lastFileTime.QuadPart
+ + ( ( curCounter.QuadPart - timeInfo.lastCounter.QuadPart )
+ * 10000000 / timeInfo.curCounterFreq.QuadPart );
+ timeInfo.lastFileTime.QuadPart = curFileTime;
+ timeInfo.lastCounter.QuadPart = curCounter.QuadPart;
+ usecSincePosixEpoch = ( curFileTime - posixEpoch.QuadPart ) / 10;
+ timePtr->sec = (time_t) ( usecSincePosixEpoch / 1000000 );
+ timePtr->usec = (unsigned long ) ( usecSincePosixEpoch % 1000000 );
+
+ LeaveCriticalSection( &timeInfo.cs );
+
+
+ } else {
+
+ /* High resolution timer is not available. Just use ftime */
+
+ ftime(&t);
+ timePtr->sec = t.time;
+ timePtr->usec = t.millitm * 1000;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * StopCalibration --
+ *
+ * Turns off the calibration thread in preparation for exiting the
+ * process.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets the 'exitEvent' event in the 'timeInfo' structure to ask
+ * the thread in question to exit, and waits for it to do so.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+StopCalibration( ClientData unused )
+ /* Client data is unused */
+{
+ SetEvent( timeInfo.exitEvent );
+ WaitForSingleObject( timeInfo.calibrationThread, INFINITE );
+ CloseHandle( timeInfo.exitEvent );
+ CloseHandle( timeInfo.calibrationThread );
}
\f
/*
return tmPtr;
}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * CalibrationThread --
+ *
+ * Thread that manages calibration of the hi-resolution time
+ * derived from the performance counter, to keep it synchronized
+ * with the system clock.
+ *
+ * Parameters:
+ * arg -- Client data from the CreateThread call. This parameter
+ * points to the static TimeInfo structure.
+ *
+ * Return value:
+ * None. This thread embeds an infinite loop.
+ *
+ * Side effects:
+ * At an interval of clockCalibrateWakeupInterval ms, this thread
+ * performs virtual time discipline.
+ *
+ * Note: When this thread is entered, TclpInitLock has been called
+ * to safeguard the static storage. There is therefore no synchronization
+ * in the body of this procedure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+CalibrationThread( LPVOID arg )
+{
+ FILETIME curFileTime;
+ DWORD waitResult;
+
+ /* Get initial system time and performance counter */
+
+ GetSystemTimeAsFileTime( &curFileTime );
+ QueryPerformanceCounter( &timeInfo.lastCounter );
+ QueryPerformanceFrequency( &timeInfo.curCounterFreq );
+ timeInfo.lastFileTime.LowPart = curFileTime.dwLowDateTime;
+ timeInfo.lastFileTime.HighPart = curFileTime.dwHighDateTime;
+
+ /* Initialize the working storage for the calibration callback */
+
+ timeInfo.lastPerfCounter = timeInfo.lastCounter.QuadPart;
+ timeInfo.estPerfCounterFreq = timeInfo.curCounterFreq.QuadPart;
+
+ /*
+ * Wake up the calling thread. When it wakes up, it will release the
+ * initialization lock.
+ */
+
+ SetEvent( timeInfo.readyEvent );
+
+ /* Run the calibration once a second */
+
+ for ( ; ; ) {
+
+ /* If the exitEvent is set, break out of the loop. */
+
+ waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
+ if ( waitResult == WAIT_OBJECT_0 ) {
+ break;
+ }
+ UpdateTimeEachSecond();
+ }
+
+ /* lint */
+ return (DWORD) 0;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateTimeEachSecond --
+ *
+ * Callback from the waitable timer in the clock calibration thread
+ * that updates system time.
+ *
+ * Parameters:
+ * info -- Pointer to the static TimeInfo structure
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Performs virtual time calibration discipline.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateTimeEachSecond()
+{
+
+ LARGE_INTEGER curPerfCounter;
+ /* Current value returned from
+ * QueryPerformanceCounter */
+
+ LONGLONG perfCounterDiff; /* Difference between the current value
+ * and the value of 1 second ago */
+
+ FILETIME curSysTime; /* Current system time */
+
+ LARGE_INTEGER curFileTime; /* File time at the time this callback
+ * was scheduled. */
+
+ LONGLONG fileTimeDiff; /* Elapsed time on the system clock
+ * since the last time this procedure
+ * was called */
+
+ LONGLONG instantFreq; /* Instantaneous estimate of the
+ * performance counter frequency */
+ LONGLONG delta; /* Increment to add to the estimated
+ * performance counter frequency in the
+ * loop filter */
+ LONGLONG fuzz; /* Tolerance for the perf counter frequency */
+
+ LONGLONG lowBound; /* Lower bound for the frequency assuming
+ * 1000 ppm tolerance */
+
+ LONGLONG hiBound; /* Upper bound for the frequency */
+
+ /*
+ * Get current performance counter and system time.
+ */
+
+ QueryPerformanceCounter( &curPerfCounter );
+ GetSystemTimeAsFileTime( &curSysTime );
+ curFileTime.LowPart = curSysTime.dwLowDateTime;
+ curFileTime.HighPart = curSysTime.dwHighDateTime;
+
+ EnterCriticalSection( &timeInfo.cs );
+
+ /*
+ * Find out how many ticks of the performance counter and the
+ * system clock have elapsed since we got into this procedure.
+ * Estimate the current frequency.
+ */
+
+ perfCounterDiff = curPerfCounter.QuadPart - timeInfo.lastPerfCounter;
+ timeInfo.lastPerfCounter = curPerfCounter.QuadPart;
+ fileTimeDiff = curFileTime.QuadPart - timeInfo.lastSysTime;
+ timeInfo.lastSysTime = curFileTime.QuadPart;
+ instantFreq = ( 10000000 * perfCounterDiff / fileTimeDiff );
+
+ /*
+ * Consider this a timing glitch if instant frequency varies
+ * significantly from the current estimate.
+ */
+
+ fuzz = timeInfo.estPerfCounterFreq >> 10;
+ lowBound = timeInfo.estPerfCounterFreq - fuzz;
+ hiBound = timeInfo.estPerfCounterFreq + fuzz;
+ if ( instantFreq < lowBound || instantFreq > hiBound ) {
+ LeaveCriticalSection( &timeInfo.cs );
+ return;
+ }
+
+ /*
+ * Update the current estimate of performance counter frequency.
+ * This code is equivalent to the loop filter of a phase locked
+ * loop.
+ */
+
+ delta = ( instantFreq - timeInfo.estPerfCounterFreq ) >> 6;
+ timeInfo.estPerfCounterFreq += delta;
+
+ /*
+ * Update the current virtual time.
+ */
+
+ timeInfo.lastFileTime.QuadPart
+ += ( ( curPerfCounter.QuadPart - timeInfo.lastCounter.QuadPart )
+ * 10000000 / timeInfo.curCounterFreq.QuadPart );
+ timeInfo.lastCounter.QuadPart = curPerfCounter.QuadPart;
+
+ delta = curFileTime.QuadPart - timeInfo.lastFileTime.QuadPart;
+ if ( delta > 10000000 || delta < -10000000 ) {
+
+ /*
+ * If the virtual time slip exceeds one second, then adjusting
+ * the counter frequency is hopeless (it'll take over fifteen
+ * minutes to line up with the system clock). The most likely
+ * cause of this large a slip is a sudden change to the system
+ * clock, perhaps because it was being corrected by wristwatch
+ * and eyeball. Accept the system time, and set the performance
+ * counter frequency to the current estimate.
+ */
+
+ timeInfo.lastFileTime.QuadPart = curFileTime.QuadPart;
+ timeInfo.curCounterFreq.QuadPart = timeInfo.estPerfCounterFreq;
+
+ } else {
+
+ /*
+ * Compute a counter frequency that will cause virtual time to line
+ * up with system time one second from now, assuming that the
+ * performance counter continues to tick at timeInfo.estPerfCounterFreq.
+ */
+
+ timeInfo.curCounterFreq.QuadPart
+ = 10000000 * timeInfo.estPerfCounterFreq / ( delta + 10000000 );
+
+ /*
+ * Limit frequency excursions to 1000 ppm from estimate
+ */
+
+ if ( timeInfo.curCounterFreq.QuadPart < lowBound ) {
+ timeInfo.curCounterFreq.QuadPart = lowBound;
+ } else if ( timeInfo.curCounterFreq.QuadPart > hiBound ) {
+ timeInfo.curCounterFreq.QuadPart = hiBound;
+ }
+ }
+
+ LeaveCriticalSection( &timeInfo.cs );
+
+}
+++ /dev/null
-/*
- * tclWinUtil.c --
- *
- * This file contains a collection of utility procedures that
- * are present in Tcl's Windows core but not in the generic
- * core. For example, they do file manipulation and process
- * manipulation.
- *
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclWinUtil.c 1.9 96/01/16 10:31:48
- */
-
-#include "tclInt.h"
-#include "tclPort.h"
-
-\f
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_WaitPid --
- *
- * Does the waitpid system call.
- *
- * Results:
- * Returns return value of pid it's waiting for.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_WaitPid(pid, statPtr, options)
- pid_t pid;
- int *statPtr;
- int options;
-{
- int flags;
- DWORD ret;
-
- if (options & WNOHANG) {
- flags = 0;
- } else {
- flags = INFINITE;
- }
- ret = WaitForSingleObject((HANDLE)pid, flags);
- if (ret == WAIT_TIMEOUT) {
- *statPtr = 0;
- return 0;
- } else if (ret != WAIT_FAILED) {
- GetExitCodeProcess((HANDLE)pid, (DWORD*)statPtr);
- *statPtr = ((*statPtr << 8) & 0xff00);
- CloseHandle((HANDLE)pid);
- return pid;
- } else {
- errno = ECHILD;
- return -1;
- }
-}
-
-
// RCS: @(#) $Id$
//
-// Version
+// Version Resource Script
//
-#define VS_VERSION_INFO 1
-
-#define RESOURCE_INCLUDED
+#include <winver.h>
#include <tcl.h>
+//
+// build-up the name suffix that defines the type of build this is.
+//
+#ifdef TCL_THREADS
+#define SUFFIX_THREADS "t"
+#else
+#define SUFFIX_THREADS ""
+#endif
+
+#ifdef STATIC_BUILD
+#define SUFFIX_STATIC "s"
+#else
+#define SUFFIX_STATIC ""
+#endif
+
+#ifdef DEBUG
+#define SUFFIX_DEBUG "d"
+#else
+#define SUFFIX_DEBUG ""
+#endif
+
+#define SUFFIX SUFFIX_THREADS SUFFIX_STATIC SUFFIX_DEBUG
+
+
LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
VS_VERSION_INFO VERSIONINFO
FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
FILEFLAGSMASK 0x3fL
+#ifdef DEBUG
+ FILEFLAGS VS_FF_DEBUG
+#else
FILEFLAGS 0x0L
- FILEOS 0x4 /* VOS__WINDOWS32 */
- FILETYPE 0x2 /* VFT_DLL */
+#endif
+ FILEOS VOS__WINDOWS32
+ FILETYPE VFT_APP
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "Tclsh Application\0"
- VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".exe\0"
- VALUE "CompanyName", "Scriptics Corporation\0"
+ VALUE "OriginalFilename", "tclsh" STRINGIFY(JOIN(TCL_MAJOR_VERSION,TCL_MINOR_VERSION)) SUFFIX ".exe\0"
+ VALUE "CompanyName", "ActiveState Corporation\0"
VALUE "FileVersion", TCL_PATCH_LEVEL
- VALUE "LegalCopyright", "Copyright (c) 2000 by Scriptics Corporation\0"
+ VALUE "LegalCopyright", "Copyright \251 2000 by ActiveState Corporation, et al\0"
VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
VALUE "ProductVersion", TCL_PATCH_LEVEL
END
//
tclsh ICON DISCARDABLE "tclsh.ico"
-
-
+++ /dev/null
-/*
- * winDumpExts.c --
- * Author: Gordon Chaffee, Scott Stanton
- *
- * History: The real functionality of this file was written by
- * Matt Pietrek in 1993 in his pedump utility. I've
- * modified it to dump the externals in a bunch of object
- * files to create a .def file.
- *
- * 10/12/95 Modified by Scott Stanton to support Relocatable Object Module
- * Format files for Borland C++ 4.5.
- *
- * Notes: Visual C++ puts an underscore before each exported symbol.
- * This file removes them. I don't know if this is a problem
- * this other compilers. If _MSC_VER is defined,
- * the underscore is removed. If not, it isn't. To get a
- * full dump of an object file, use the -f option. This can
- * help determine the something that may be different with a
- * compiler other than Visual C++.
- *----------------------------------------------------------------------
- *
- * RCS: @(#) $Id$
- */
-
-#include <windows.h>
-#include <stdio.h>
-#include <string.h>
-#include <process.h>
-
-#ifdef _ALPHA_
-#define e_magic_number IMAGE_FILE_MACHINE_ALPHA
-#else
-#define e_magic_number IMAGE_FILE_MACHINE_I386
-#endif
-
-/*
- *----------------------------------------------------------------------
- * GetArgcArgv --
- *
- * Break up a line into argc argv
- *----------------------------------------------------------------------
- */
-int
-GetArgcArgv(char *s, char **argv)
-{
- int quote = 0;
- int argc = 0;
- char *bp;
-
- bp = s;
- while (1) {
- while (isspace(*bp)) {
- bp++;
- }
- if (*bp == '\n' || *bp == '\0') {
- *bp = '\0';
- return argc;
- }
- if (*bp == '\"') {
- quote = 1;
- bp++;
- }
- argv[argc++] = bp;
-
- while (*bp != '\0') {
- if (quote) {
- if (*bp == '\"') {
- quote = 0;
- *bp = '\0';
- bp++;
- break;
- }
- bp++;
- continue;
- }
- if (isspace(*bp)) {
- *bp = '\0';
- bp++;
- break;
- }
- bp++;
- }
- }
-}
-
-/*
- * The names of the first group of possible symbol table storage classes
- */
-char * SzStorageClass1[] = {
- "NULL","AUTOMATIC","EXTERNAL","STATIC","REGISTER","EXTERNAL_DEF","LABEL",
- "UNDEFINED_LABEL","MEMBER_OF_STRUCT","ARGUMENT","STRUCT_TAG",
- "MEMBER_OF_UNION","UNION_TAG","TYPE_DEFINITION","UNDEFINED_STATIC",
- "ENUM_TAG","MEMBER_OF_ENUM","REGISTER_PARAM","BIT_FIELD"
-};
-
-/*
- * The names of the second group of possible symbol table storage classes
- */
-char * SzStorageClass2[] = {
- "BLOCK","FUNCTION","END_OF_STRUCT","FILE","SECTION","WEAK_EXTERNAL"
-};
-
-/*
- *----------------------------------------------------------------------
- * GetSZStorageClass --
- *
- * Given a symbol storage class value, return a descriptive
- * ASCII string
- *----------------------------------------------------------------------
- */
-PSTR
-GetSZStorageClass(BYTE storageClass)
-{
- if ( storageClass <= IMAGE_SYM_CLASS_BIT_FIELD )
- return SzStorageClass1[storageClass];
- else if ( (storageClass >= IMAGE_SYM_CLASS_BLOCK)
- && (storageClass <= IMAGE_SYM_CLASS_WEAK_EXTERNAL) )
- return SzStorageClass2[storageClass-IMAGE_SYM_CLASS_BLOCK];
- else
- return "???";
-}
-
-/*
- *----------------------------------------------------------------------
- * GetSectionName --
- *
- * Used by DumpSymbolTable, it gives meaningful names to
- * the non-normal section number.
- *
- * Results:
- * A name is returned in buffer
- *----------------------------------------------------------------------
- */
-void
-GetSectionName(WORD section, PSTR buffer, unsigned cbBuffer)
-{
- char tempbuffer[10];
-
- switch ( (SHORT)section )
- {
- case IMAGE_SYM_UNDEFINED: strcpy(tempbuffer, "UNDEF"); break;
- case IMAGE_SYM_ABSOLUTE: strcpy(tempbuffer, "ABS "); break;
- case IMAGE_SYM_DEBUG: strcpy(tempbuffer, "DEBUG"); break;
- default: wsprintf(tempbuffer, "%-5X", section);
- }
-
- strncpy(buffer, tempbuffer, cbBuffer-1);
-}
-
-/*
- *----------------------------------------------------------------------
- * DumpSymbolTable --
- *
- * Dumps a COFF symbol table from an EXE or OBJ. We only use
- * it to dump tables from OBJs.
- *----------------------------------------------------------------------
- */
-void
-DumpSymbolTable(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols)
-{
- unsigned i;
- PSTR stringTable;
- char sectionName[10];
-
- fprintf(fout, "Symbol Table - %X entries (* = auxillary symbol)\n",
- cSymbols);
-
- fprintf(fout,
- "Indx Name Value Section cAux Type Storage\n"
- "---- -------------------- -------- ---------- ----- ------- --------\n");
-
- /*
- * The string table apparently starts right after the symbol table
- */
- stringTable = (PSTR)&pSymbolTable[cSymbols];
-
- for ( i=0; i < cSymbols; i++ ) {
- fprintf(fout, "%04X ", i);
- if ( pSymbolTable->N.Name.Short != 0 )
- fprintf(fout, "%-20.8s", pSymbolTable->N.ShortName);
- else
- fprintf(fout, "%-20s", stringTable + pSymbolTable->N.Name.Long);
-
- fprintf(fout, " %08X", pSymbolTable->Value);
-
- GetSectionName(pSymbolTable->SectionNumber, sectionName,
- sizeof(sectionName));
- fprintf(fout, " sect:%s aux:%X type:%02X st:%s\n",
- sectionName,
- pSymbolTable->NumberOfAuxSymbols,
- pSymbolTable->Type,
- GetSZStorageClass(pSymbolTable->StorageClass) );
-#if 0
- if ( pSymbolTable->NumberOfAuxSymbols )
- DumpAuxSymbols(pSymbolTable);
-#endif
-
- /*
- * Take into account any aux symbols
- */
- i += pSymbolTable->NumberOfAuxSymbols;
- pSymbolTable += pSymbolTable->NumberOfAuxSymbols;
- pSymbolTable++;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- * DumpExternals --
- *
- * Dumps a COFF symbol table from an EXE or OBJ. We only use
- * it to dump tables from OBJs.
- *----------------------------------------------------------------------
- */
-void
-DumpExternals(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols)
-{
- unsigned i;
- PSTR stringTable;
- char *s, *f;
- char symbol[1024];
-
- /*
- * The string table apparently starts right after the symbol table
- */
- stringTable = (PSTR)&pSymbolTable[cSymbols];
-
- for ( i=0; i < cSymbols; i++ ) {
- if (pSymbolTable->SectionNumber > 0 && pSymbolTable->Type == 0x20) {
- if (pSymbolTable->StorageClass == IMAGE_SYM_CLASS_EXTERNAL) {
- if (pSymbolTable->N.Name.Short != 0) {
- strncpy(symbol, pSymbolTable->N.ShortName, 8);
- symbol[8] = 0;
- } else {
- s = stringTable + pSymbolTable->N.Name.Long;
- strcpy(symbol, s);
- }
- s = symbol;
- f = strchr(s, '@');
- if (f) {
- *f = 0;
- }
-#if defined(_MSC_VER) && defined(_X86_)
- if (symbol[0] == '_') {
- s = &symbol[1];
- }
-#endif
- if ((stricmp(s, "DllEntryPoint") != 0)
- && (stricmp(s, "DllMain") != 0)) {
- fprintf(fout, "\t%s\n", s);
- }
- }
- }
-
- /*
- * Take into account any aux symbols
- */
- i += pSymbolTable->NumberOfAuxSymbols;
- pSymbolTable += pSymbolTable->NumberOfAuxSymbols;
- pSymbolTable++;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- * DumpObjFile --
- *
- * Dump an object file--either a full listing or just the exported
- * symbols.
- *----------------------------------------------------------------------
- */
-void
-DumpObjFile(PIMAGE_FILE_HEADER pImageFileHeader, FILE *fout, int full)
-{
- PIMAGE_SYMBOL PCOFFSymbolTable;
- DWORD COFFSymbolCount;
-
- PCOFFSymbolTable = (PIMAGE_SYMBOL)
- ((DWORD)pImageFileHeader + pImageFileHeader->PointerToSymbolTable);
- COFFSymbolCount = pImageFileHeader->NumberOfSymbols;
-
- if (full) {
- DumpSymbolTable(PCOFFSymbolTable, fout, COFFSymbolCount);
- } else {
- DumpExternals(PCOFFSymbolTable, fout, COFFSymbolCount);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- * SkipToNextRecord --
- *
- * Skip over the current ROMF record and return the type of the
- * next record.
- *----------------------------------------------------------------------
- */
-
-BYTE
-SkipToNextRecord(BYTE **ppBuffer)
-{
- int length;
- (*ppBuffer)++; /* Skip over the type.*/
- length = *((WORD*)(*ppBuffer))++; /* Retrieve the length. */
- *ppBuffer += length; /* Skip over the rest. */
- return **ppBuffer; /* Return the type. */
-}
-
-/*
- *----------------------------------------------------------------------
- * DumpROMFObjFile --
- *
- * Dump a Relocatable Object Module Format file, displaying only
- * the exported symbols.
- *----------------------------------------------------------------------
- */
-void
-DumpROMFObjFile(LPVOID pBuffer, FILE *fout)
-{
- BYTE type, length;
- char symbol[1024], *s;
-
- while (1) {
- type = SkipToNextRecord(&(BYTE*)pBuffer);
- if (type == 0x90) { /* PUBDEF */
- if (((BYTE*)pBuffer)[4] != 0) {
- length = ((BYTE*)pBuffer)[5];
- strncpy(symbol, ((char*)pBuffer) + 6, length);
- symbol[length] = '\0';
- s = symbol;
- if ((stricmp(s, "DllEntryPoint") != 0)
- && (stricmp(s, "DllMain") != 0)) {
- if (s[0] == '_') {
- s++;
- fprintf(fout, "\t_%s\n\t%s=_%s\n", s, s, s);
- } else {
- fprintf(fout, "\t%s\n", s);
- }
- }
- }
- } else if (type == 0x8B || type == 0x8A) { /* MODEND */
- break;
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- * DumpFile --
- *
- * Open up a file, memory map it, and call the appropriate
- * dumping routine
- *----------------------------------------------------------------------
- */
-void
-DumpFile(LPSTR filename, FILE *fout, int full)
-{
- HANDLE hFile;
- HANDLE hFileMapping;
- LPVOID lpFileBase;
- PIMAGE_DOS_HEADER dosHeader;
-
- hFile = CreateFile(filename, GENERIC_READ, FILE_SHARE_READ, NULL,
- OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
-
- if (hFile == INVALID_HANDLE_VALUE) {
- fprintf(stderr, "Couldn't open file with CreateFile()\n");
- return;
- }
-
- hFileMapping = CreateFileMapping(hFile, NULL, PAGE_READONLY, 0, 0, NULL);
- if (hFileMapping == 0) {
- CloseHandle(hFile);
- fprintf(stderr, "Couldn't open file mapping with CreateFileMapping()\n");
- return;
- }
-
- lpFileBase = MapViewOfFile(hFileMapping, FILE_MAP_READ, 0, 0, 0);
- if (lpFileBase == 0) {
- CloseHandle(hFileMapping);
- CloseHandle(hFile);
- fprintf(stderr, "Couldn't map view of file with MapViewOfFile()\n");
- return;
- }
-
- dosHeader = (PIMAGE_DOS_HEADER)lpFileBase;
- if (dosHeader->e_magic == IMAGE_DOS_SIGNATURE) {
-#if 0
- DumpExeFile( dosHeader );
-#else
- fprintf(stderr, "File is an executable. I don't dump those.\n");
- return;
-#endif
- }
- /* Does it look like a i386 COFF OBJ file??? */
- else if ((dosHeader->e_magic == e_magic_number)
- && (dosHeader->e_sp == 0)) {
- /*
- * The two tests above aren't what they look like. They're
- * really checking for IMAGE_FILE_HEADER.Machine == i386 (0x14C)
- * and IMAGE_FILE_HEADER.SizeOfOptionalHeader == 0;
- */
- DumpObjFile((PIMAGE_FILE_HEADER) lpFileBase, fout, full);
- } else if (*((BYTE *)lpFileBase) == 0x80) {
- /*
- * This file looks like it might be a ROMF file.
- */
- DumpROMFObjFile(lpFileBase, fout);
- } else {
- printf("unrecognized file format\n");
- }
- UnmapViewOfFile(lpFileBase);
- CloseHandle(hFileMapping);
- CloseHandle(hFile);
-}
-
-void
-main(int argc, char **argv)
-{
- char *fargv[1000];
- char cmdline[10000];
- int i, arg;
- FILE *fout;
- int pos;
- int full = 0;
- char *outfile = NULL;
-
- if (argc < 3) {
- Usage:
- fprintf(stderr, "Usage: %s ?-o outfile? ?-f(ull)? <dllname> <object filenames> ..\n", argv[0]);
- exit(1);
- }
-
- arg = 1;
- while (argv[arg][0] == '-') {
- if (strcmp(argv[arg], "--") == 0) {
- arg++;
- break;
- } else if (strcmp(argv[arg], "-f") == 0) {
- full = 1;
- } else if (strcmp(argv[arg], "-o") == 0) {
- arg++;
- if (arg == argc) {
- goto Usage;
- }
- outfile = argv[arg];
- }
- arg++;
- }
- if (arg == argc) {
- goto Usage;
- }
-
- if (outfile) {
- fout = fopen(outfile, "w+");
- if (fout == NULL) {
- fprintf(stderr, "Unable to open \'%s\' for writing:\n",
- argv[arg]);
- perror("");
- exit(1);
- }
- } else {
- fout = stdout;
- }
-
- if (! full) {
- char *dllname = argv[arg];
- arg++;
- if (arg == argc) {
- goto Usage;
- }
- fprintf(fout, "LIBRARY %s\n", dllname);
- fprintf(fout, "EXETYPE WINDOWS\n");
- fprintf(fout, "CODE PRELOAD MOVEABLE DISCARDABLE\n");
- fprintf(fout, "DATA PRELOAD MOVEABLE MULTIPLE\n\n");
- fprintf(fout, "EXPORTS\n");
- }
-
- for (; arg < argc; arg++) {
- if (argv[arg][0] == '@') {
- FILE *fargs = fopen(&argv[arg][1], "r");
- if (fargs == NULL) {
- fprintf(stderr, "Unable to open \'%s\' for reading:\n",
- argv[arg]);
- perror("");
- exit(1);
- }
- pos = 0;
- for (i = 0; i < arg; i++) {
- strcpy(&cmdline[pos], argv[i]);
- pos += strlen(&cmdline[pos]) + 1;
- fargv[i] = argv[i];
- }
- fgets(&cmdline[pos], sizeof(cmdline), fargs);
- fprintf(stderr, "%s\n", &cmdline[pos]);
- fclose(fargs);
- i += GetArgcArgv(&cmdline[pos], &fargv[i]);
- argc = i;
- argv = fargv;
- }
- DumpFile(argv[arg], fout, full);
- }
- exit(0);
-}
OSDN Git Service
